From 016ec0a646faef2fc968cdf8287302beaa0f70dc Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Tue, 24 May 2022 17:23:43 +0000
Subject: Performance test scripts for list commands
---
tests-perf/comparePerf.tcl | 371 ++++++++++++++
tests-perf/listPerf.tcl | 1225 ++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 1596 insertions(+)
create mode 100644 tests-perf/comparePerf.tcl
create mode 100644 tests-perf/listPerf.tcl
diff --git a/tests-perf/comparePerf.tcl b/tests-perf/comparePerf.tcl
new file mode 100644
index 0000000..f35da21
--- /dev/null
+++ b/tests-perf/comparePerf.tcl
@@ -0,0 +1,371 @@
+#!/usr/bin/tclsh
+# ------------------------------------------------------------------------
+#
+# comparePerf.tcl --
+#
+# Script to compare performance data from multiple runs.
+#
+# ------------------------------------------------------------------------
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file.
+#
+# Usage:
+# tclsh comparePerf.tcl [--regexp RE] [--ratio time|rate] [--combine] [--base BASELABEL] PERFFILE ...
+#
+# The test data from each input file is tabulated so as to compare the results
+# of test runs. If a PERFFILE does not exist, it is retried by adding the
+# .perf extension. If the --regexp is specified, only test results whose
+# id matches RE are examined.
+#
+# If the --combine option is specified, results of test sets with the same
+# label are combined and averaged in the output.
+#
+# If the --base option is specified, the BASELABEL is used as the label to use
+# the base timing. Otherwise, the label of the first data file is used.
+#
+# If --ratio option is "time" the ratio of test timing vs base test timing
+# is shown. If "rate" (default) the inverse is shown.
+#
+# If --no-header is specified, the header describing test configuration is
+# not output.
+#
+# The format of input files is as follows:
+#
+# Each line must begin with one of the characters below followed by a space
+# followed by a string whose semantics depend on the initial character.
+# E - Full path to the Tcl executable that was used to generate the file
+# V - The Tcl patchlevel of the implementation
+# D - A description for the test run for human consumption
+# L - A label used to identify run environment. The --combine option will
+# average all measuremets that have the same label. An input file without
+# a label is treated as having a unique label and not combined with any other.
+# P - A test measurement (see below)
+# R - The number of runs made for the each test
+# # - A comment, may be an arbitrary string. Usually included in performance
+# data to describe the test. This is silently ignored
+#
+# Any lines not matching one of the above are ignored with a warning to stderr.
+#
+# A line beginning with the "P" marker is a test measurement. The first word
+# following is a floating point number representing the test runtime.
+# The remaining line (after trimming of whitespace) is the id of the test.
+# Test generators are encouraged to make the id a well-defined machine-parseable
+# as well human readable description of the test. The id must not appear more
+# than once. An example test measurement line:
+# P 2.32280 linsert in unshared L[10000] 1 elems 10000 times at 0 (var)
+# Note here the iteration count is not present.
+#
+
+namespace eval perf::compare {
+ # List of dictionaries, one per input file
+ variable PerfData
+}
+
+proc perf::compare::warn {message} {
+ puts stderr "Warning: $message"
+}
+proc perf::compare::print {text} {
+ puts stdout $text
+}
+proc perf::compare::slurp {testrun_path} {
+ variable PerfData
+
+ set runtimes [dict create]
+
+ set path [file normalize $testrun_path]
+ set fd [open $path]
+ array set header {}
+ while {[gets $fd line] >= 0} {
+ set line [regsub -all {\s+} [string trim $line] " "]
+ switch -glob -- $line {
+ "#*" {
+ # Skip comments
+ }
+ "R *" -
+ "L *" -
+ "D *" -
+ "V *" -
+ "T *" -
+ "E *" {
+ set marker [lindex $line 0]
+ if {[info exists header($marker)]} {
+ warn "Ignoring $marker record (duplicate): \"$line\""
+ }
+ set header($marker) [string range $line 2 end]
+ }
+ "P *" {
+ if {[scan $line "P %f %n" runtime id_start] == 2} {
+ set id [string range $line $id_start end]
+ if {[dict exists $runtimes $id]} {
+ warn "Ignoring duplicate test id \"$id\""
+ } else {
+ dict set runtimes $id $runtime
+ }
+ } else {
+ warn "Invalid test result line format: \"$line\""
+ }
+ }
+ default {
+ puts stderr "Warning: ignoring unrecognized line \"$line\""
+ }
+ }
+ }
+ close $fd
+
+ set result [dict create Input $path Runtimes $runtimes]
+ foreach {c k} {
+ L Label
+ V Version
+ E Executable
+ D Description
+ } {
+ if {[info exists header($c)]} {
+ dict set result $k $header($c)
+ }
+ }
+
+ return $result
+}
+
+proc perf::compare::burp {test_sets} {
+ variable Options
+
+ # Print the key for each test run
+ set header " "
+ set separator " "
+ foreach test_set $test_sets {
+ set test_set_key "\[[incr test_set_num]\]"
+ if {! $Options(--no-header)} {
+ print "$test_set_key"
+ foreach k {Label Executable Version Input Description} {
+ if {[dict exists $test_set $k]} {
+ print "$k: [dict get $test_set $k]"
+ }
+ }
+ }
+ append header $test_set_key $separator
+ set separator " "; # Expand because later columns have ratio
+ }
+ set header [string trimright $header]
+
+ if {! $Options(--no-header)} {
+ print ""
+ if {$Options(--ratio) eq "rate"} {
+ set ratio_description "ratio of baseline to the measurement (higher is faster)."
+ } else {
+ set ratio_description "ratio of measurement to the baseline (lower is faster)."
+ }
+ print "The first column \[1\] is the baseline measurement."
+ print "Subsequent columns are pairs of the additional measurement and "
+ print $ratio_description
+ print ""
+ }
+
+ # Print the actual test run data
+
+ print $header
+ set test_sets [lassign $test_sets base_set]
+ set fmt {%#10.5f}
+ set fmt_ratio {%-6.2f}
+ foreach {id base_runtime} [dict get $base_set Runtimes] {
+ if {[info exists Options(--regexp)]} {
+ if {![regexp $Options(--regexp) $id]} {
+ continue
+ }
+ }
+ if {$Options(--print-test-number)} {
+ set line "[format %-4s [incr counter].]"
+ } else {
+ set line ""
+ }
+ append line [format $fmt $base_runtime]
+ foreach test_set $test_sets {
+ if {[dict exists $test_set Runtimes $id]} {
+ set runtime [dict get $test_set Runtimes $id]
+ if {$Options(--ratio) eq "time"} {
+ if {$base_runtime != 0} {
+ set ratio [format $fmt_ratio [expr {$runtime/$base_runtime}]]
+ } else {
+ if {$runtime == 0} {
+ set ratio "NaN "
+ } else {
+ set ratio "Inf "
+ }
+ }
+ } else {
+ if {$runtime != 0} {
+ set ratio [format $fmt_ratio [expr {$base_runtime/$runtime}]]
+ } else {
+ if {$base_runtime == 0} {
+ set ratio "NaN "
+ } else {
+ set ratio "Inf "
+ }
+ }
+ }
+ append line "|" [format $fmt $runtime] "|" $ratio
+ } else {
+ append line [string repeat { } 11]
+ }
+ }
+ append line "|" $id
+ print $line
+ }
+}
+
+proc perf::compare::chew {test_sets} {
+ variable Options
+
+ # Combine test sets that have the same label, averaging the values
+ set unlabeled_sets {}
+ array set labeled_sets {}
+
+ foreach test_set $test_sets {
+ # If there is no label, treat as independent set
+ if {![dict exists $test_set Label]} {
+ lappend unlabeled_sets $test_set
+ } else {
+ lappend labeled_sets([dict get $test_set Label]) $test_set
+ }
+ }
+
+ foreach label [array names labeled_sets] {
+ set combined_set [lindex $labeled_sets($label) 0]
+ set runtimes [dict get $combined_set Runtimes]
+ foreach test_set [lrange $labeled_sets($label) 1 end] {
+ dict for {id timing} [dict get $test_set Runtimes] {
+ dict lappend runtimes $id $timing
+ }
+ }
+ dict for {id timings} $runtimes {
+ set total [tcl::mathop::+ {*}$timings]
+ dict set runtimes $id [expr {$total/[llength $timings]}]
+ }
+ dict set combined_set Runtimes $runtimes
+ set labeled_sets($label) $combined_set
+ }
+
+ # Choose the "base" test set
+ if {![info exists Options(--base)]} {
+ set first_set [lindex $test_sets 0]
+ if {[dict exists $first_set Label]} {
+ # Use label of first as the base
+ set Options(--base) [dict get $first_set Label]
+ }
+ }
+
+ if {[info exists Options(--base)] && $Options(--base) ne ""} {
+ lappend combined_sets $labeled_sets($Options(--base));# Will error if no such
+ unset labeled_sets($Options(--base))
+ } else {
+ lappend combined_sets [lindex $unlabeled_sets 0]
+ set unlabeled_sets [lrange $unlabeled_sets 1 end]
+ }
+ foreach label [array names labeled_sets] {
+ lappend combined_sets $labeled_sets($label)
+ }
+ lappend combined_sets {*}$unlabeled_sets
+
+ return $combined_sets
+}
+
+proc perf::compare::setup {argv} {
+ variable Options
+
+ array set Options {
+ --ratio rate
+ --combine 0
+ --print-test-number 0
+ --no-header 0
+ }
+ while {[llength $argv]} {
+ set argv [lassign $argv arg]
+ switch -glob -- $arg {
+ -r -
+ --regexp {
+ if {[llength $argv] == 0} {
+ error "Missing value for option $arg"
+ }
+ set argv [lassign $argv val]
+ set Options(--regexp) $val
+ }
+ --ratio {
+ if {[llength $argv] == 0} {
+ error "Missing value for option $arg"
+ }
+ set argv [lassign $argv val]
+ if {$val ni {time rate}} {
+ error "Value for option $arg must be either \"time\" or \"rate\""
+ }
+ set Options(--ratio) $val
+ }
+ --print-test-number -
+ --combine -
+ --no-header {
+ set Options($arg) 1
+ }
+ --base {
+ if {[llength $argv] == 0} {
+ error "Missing value for option $arg"
+ }
+ set argv [lassign $argv val]
+ set Options($arg) $val
+ }
+ -- {
+ # Remaining will be passed back to the caller
+ break
+ }
+ --* {
+ error "Unknown option $arg"
+ }
+ -* {
+ error "Unknown option -[lindex $arg 0]"
+ }
+ default {
+ # Remaining will be passed back to the caller
+ set argv [linsert $argv 0 $arg]
+ break;
+ }
+ }
+ }
+
+ set paths {}
+ foreach path $argv {
+ set path [file join $path]; # Convert from native else glob fails
+ if {[file isfile $path]} {
+ lappend paths $path
+ continue
+ }
+ if {[file isfile $path.perf]} {
+ lappend paths $path.perf
+ continue
+ }
+ lappend paths {*}[glob -nocomplain $path]
+ }
+ return $paths
+}
+proc perf::compare::main {} {
+ variable Options
+
+ set paths [setup $::argv]
+ if {[llength $paths] == 0} {
+ error "No test data files specified."
+ }
+ set test_data [list ]
+ set seen [dict create]
+ foreach path $paths {
+ if {![dict exists $seen $path]} {
+ lappend test_data [slurp $path]
+ dict set seen $path ""
+ }
+ }
+
+ if {$Options(--combine)} {
+ set test_data [chew $test_data]
+ }
+
+ burp $test_data
+}
+
+perf::compare::main
diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl
new file mode 100644
index 0000000..1252870
--- /dev/null
+++ b/tests-perf/listPerf.tcl
@@ -0,0 +1,1225 @@
+#!/usr/bin/tclsh
+# ------------------------------------------------------------------------
+#
+# listPerf.tcl --
+#
+# This file provides performance tests for list operations.
+#
+# ------------------------------------------------------------------------
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file.
+#
+# Note: this file does not use the test-performance.tcl framework as we want
+# more direct control over timerate options.
+
+catch {package require twapi}
+
+namespace eval perf::list {
+ variable perfScript [file normalize [info script]]
+
+ # Test for each of these lengths
+ variable Lengths {10 100 1000 10000}
+
+ variable RunTimes
+ set RunTimes(command) 0.0
+ set RunTimes(total) 0.0
+
+ variable Options
+ array set Options {
+ --print-comments 0
+ --print-iterations 0
+ }
+
+ # Procs used for calibrating overhead
+ proc proc2args {a b} {}
+ proc proc3args {a b c} {}
+
+ proc print {s} {
+ puts $s
+ }
+ proc print_usage {} {
+ puts stderr "Usage: [file tail [info nameofexecutable]] $::argv0 \[options\] \[command ...\]"
+ puts stderr "\t--description DESC\tHuman readable description of test run"
+ puts stderr "\t--label LABEL\tA label used to identify test environment"
+ puts stderr "\t--print-comments\tPrint comment for each test"
+ puts stderr "\t--print-iterations\tPrint number of iterations run for each test"
+ }
+
+ proc setup {argv} {
+ variable Options
+ variable Lengths
+
+ while {[llength $argv]} {
+ set argv [lassign $argv arg]
+ switch -glob -- $arg {
+ --print-comments -
+ --print-iterations {
+ set Options($arg) 1
+ }
+ --label -
+ --description {
+ if {[llength $argv] == 0} {
+ error "Missing value for option $arg"
+ }
+ set argv [lassign $argv val]
+ set Options($arg) $val
+ }
+ --lengths {
+ if {[llength $argv] == 0} {
+ error "Missing value for option $arg"
+ }
+ set argv [lassign $argv val]
+ set Lengths $val
+
+ }
+ -- {
+ # Remaining will be passed back to the caller
+ break
+ }
+ --* {
+ error "Unknown option $arg"
+ }
+ default {
+ # Remaining will be passed back to the caller
+ set argv [linsert $argv 0 $arg]
+ break;
+ }
+ }
+ }
+
+ return $argv
+ }
+ proc format_timings {us iters} {
+ variable Options
+ if {!$Options(--print-iterations)} {
+ return "[format {%#10.4f} $us]"
+ }
+ return "[format {%#10.4f} $us] [format {%8d} $iters]"
+ }
+ proc measure {id script args} {
+ variable NullOverhead
+ variable RunTimes
+ variable Options
+
+ set opts(-overhead) ""
+ set opts(-runs) 5
+ while {[llength $args]} {
+ set args [lassign $args opt]
+ if {[llength $args] == 0} {
+ error "No argument supplied for $opt option. Test: $id"
+ }
+ set args [lassign $args val]
+ switch $opt {
+ -setup -
+ -cleanup -
+ -overhead -
+ -time -
+ -runs -
+ -reps {
+ set opts($opt) $val
+ }
+ default {
+ error "Unknown option $opt. Test: $id"
+ }
+ }
+ }
+
+ set timerate_args {}
+ if {[info exists opts(-time)]} {
+ lappend timerate_args $opts(-time)
+ }
+ if {[info exists opts(-reps)]} {
+ if {[info exists opts(-time)]} {
+ set timerate_args [list $opts(-time) $opts(-reps)]
+ } else {
+ # Force the default for first time option
+ set timerate_args [list 1000 $opts(-reps)]
+ }
+ } elseif {[info exists opts(-time)]} {
+ set timerate_args [list $opts(-time)]
+ }
+ if {[info exists opts(-setup)]} {
+ uplevel 1 $opts(-setup)
+ }
+ # Cache the empty overhead to prevent unnecessary delays. Note if you modify
+ # to cache other scripts, the cache key must be AFTER substituting the
+ # overhead script in the caller's context.
+ if {$opts(-overhead) eq ""} {
+ if {![info exists NullOverhead]} {
+ set NullOverhead [lindex [timerate {}] 0]
+ }
+ set overhead_us $NullOverhead
+ } else {
+ # The overhead measurements might use setup so we need to setup
+ # first and then cleanup in preparation for setting up again for
+ # the script to be measured
+ if {[info exists opts(-setup)]} {
+ uplevel 1 $opts(-setup)
+ }
+ set overhead_us [lindex [uplevel 1 [list timerate $opts(-overhead)]] 0]
+ if {[info exists opts(-cleanup)]} {
+ uplevel 1 $opts(-cleanup)
+ }
+ }
+ set timings {}
+ for {set i 0} {$i < $opts(-runs)} {incr i} {
+ if {[info exists opts(-setup)]} {
+ uplevel 1 $opts(-setup)
+ }
+ lappend timings [uplevel 1 [list timerate -overhead $overhead_us $script {*}$timerate_args]]
+ if {[info exists opts(-cleanup)]} {
+ uplevel 1 $opts(-cleanup)
+ }
+ }
+ set timings [lsort -real -index 0 $timings]
+ if {$opts(-runs) > 15} {
+ set ignore [expr {$opts(-runs)/8}]
+ } elseif {$opts(-runs) >= 5} {
+ set ignore 2
+ } else {
+ set ignore 0
+ }
+ # Ignore highest and lowest
+ set timings [lrange $timings 0 end-$ignore]
+ # Average it out
+ set us 0
+ set iters 0
+ foreach timing $timings {
+ set us [expr {$us + [lindex $timing 0]}]
+ set iters [expr {$iters + [lindex $timing 2]}]
+ }
+ set us [expr {$us/[llength $timings]}]
+ set iters [expr {$iters/[llength $timings]}]
+
+ set RunTimes(command) [expr {$RunTimes(command) + $us}]
+ print "P [format_timings $us $iters] $id"
+ }
+ proc comment {args} {
+ variable Options
+ if {$Options(--print-comments)} {
+ print "# [join $args { }]"
+ }
+ }
+ proc spanned_list {len} {
+ # Note - for small len, this will not create a spanned list
+ set delta [expr {$len/8}]
+ return [lrange [lrepeat [expr {$len+(2*$delta)}] a] $delta [expr {$delta+$len-1}]]
+ }
+ proc print_separator {command} {
+ comment [string repeat = 80]
+ comment Command: $command
+ }
+
+ oo::class create ListPerf {
+ constructor {args} {
+ my variable Opts
+ # Note default Opts can be overridden in construct as well as in measure
+ set Opts [dict merge {
+ -setup {
+ set L [lrepeat $len a]
+ set Lspan [perf::list::spanned_list $len]
+ } -cleanup {
+ unset -nocomplain L
+ unset -nocomplain Lspan
+ unset -nocomplain L2
+ }
+ } $args]
+ }
+ method measure {comment script locals args} {
+ my variable Opts
+ dict with locals {}
+ ::perf::list::measure $comment $script {*}[dict merge $Opts $args]
+ }
+ method option {opt val} {
+ my variable Opts
+ dict set Opts $opt $val
+ }
+ method option_unset {opt} {
+ my variable Opts
+ unset -nocomplain Opts($opt)
+ }
+ }
+
+ proc linsert_describe {share_mode len at num iters} {
+ return "linsert L\[$len\] $share_mode $num elems $iters times at $at"
+ }
+ proc linsert_perf {} {
+ variable Lengths
+
+ print_separator linsert
+
+ comment == Insert into empty lists
+ comment Insert one element into empty list
+ measure [linsert_describe empty 0 "0 (const)" 1 1] {linsert {} 0 ""}
+
+ ListPerf create perf -overhead {set L {}} -time 1000
+
+ # Note: Const indices take different path through bytecode than variable
+ # indices hence separate cases below
+ foreach len $Lengths {
+ if {$len >= 10000} {
+ set reps 100
+ } else {
+ set reps [expr {100000/$len}]
+ }
+ perf option -reps $reps
+ foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
+
+ # Const index
+ comment Insert once to shared list with const index
+ perf measure [linsert_describe shared $len "$idx (const)" 1 1] \
+ "linsert \$L $idx x" [list len $len] -overhead {}
+
+ comment Insert multiple times to shared list with const index
+ perf measure [linsert_describe shared $len "$idx (const)" 1 $reps] \
+ "set L \[linsert \$L $idx X\]" [list len $len]
+
+ # Variable index
+ comment Insert once to shared list with variable index
+ perf measure [linsert_describe shared $len "$idx (var)" 1 1] \
+ {linsert $L $idx x} [list len $len idx $idx] -overhead {}
+
+ comment Insert multiple times to shared list with variable index
+ perf measure [linsert_describe shared $len "$idx (var)" 1 $reps] {
+ set L [linsert $L $idx X]
+ } [list len $len idx $idx]
+ }
+
+ # Multiple items at a time
+ # Not in loop above because of desired output ordering
+ foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
+ comment Insert multiple items multiple times to shared list with const index
+ perf measure [linsert_describe shared $len "$idx (const)" 5 $reps] \
+ "set L \[linsert \$L $idx X X X X X\]" [list len $len]
+
+ comment Insert multiple items multiple times to shared list with variable index
+ perf measure [linsert_describe shared $len "$idx (var)" 5 $reps] {
+ set L [linsert $L $idx X X X X X]
+ } [list len $len idx $idx]
+ }
+
+ }
+
+ # Not in loop above because of how we want order in output
+
+ foreach len $Lengths {
+ if {$len > 100000} {
+ set reps 10
+ } else {
+ set reps [expr {100000/$len}]
+ }
+ perf option -reps $reps
+ foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
+ # NOTE : the Insert once case is left out for unshared lists
+ # because it requires re-init on every iteration resulting
+ # in a lot of measurement noise
+
+ # Const index
+ comment Insert multiple times to unshared list with const index
+ perf measure [linsert_describe unshared $len "$idx (const)" 1 $reps] \
+ "set L \[linsert \$L\[set L {}\] $idx X]" [list len $len]
+
+ comment Insert multiple items multiple times to unshared list with const index
+ perf measure [linsert_describe unshared $len "$idx (const)" 5 $reps] \
+ "set L \[linsert \$L\[set L {}\] $idx X X X X X]" [list len $len]
+
+ # Variable index
+
+ comment Insert multiple times to unshared list with variable index
+ perf measure [linsert_describe unshared $len "$idx (var)" 1 $reps] {
+ set L [linsert $L[set L {}] $idx X]
+ } [list len $len idx $idx]
+
+ comment Insert multiple items multiple times to unshared list with variable index
+ perf measure [linsert_describe unshared $len "$idx (var)" 5 $reps] {
+ set L [linsert $L[set L {}] $idx X X X X X]
+ } [list len $len idx $idx]
+
+ }
+ }
+
+ # Note: no span tests because the inserts above will themselves create
+ # spanned lists
+
+ perf destroy
+ }
+
+ proc lappend_describe {share_mode len num iters} {
+ return "lappend L\[$len\] $share_mode $num elems $iters times"
+ }
+ proc lappend_perf {} {
+ variable Lengths
+
+ print_separator lappend
+
+ ListPerf create perf -setup {set L [lrepeat [expr {$len/4}] x]}
+
+ # Shared
+ foreach len $Lengths {
+ comment Append to a shared list variable multiple times
+ perf measure [lappend_describe shared [expr {$len/2}] 1 $len] {
+ set L2 $L; # Make shared
+ lappend L x
+ } [list len $len] -reps $len -overhead {set L2 $L}
+ }
+
+ # Unshared
+ foreach len $Lengths {
+ comment Append to a unshared list variable multiple times
+ perf measure [lappend_describe unshared [expr {$len/2}] 1 $len] {
+ lappend L x
+ } [list len $len] -reps $len
+ }
+
+ # Span
+ foreach len $Lengths {
+ comment Append to a unshared-span list variable multiple times
+ perf measure [lappend_describe unshared-span [expr {$len/2}] 1 $len] {
+ lappend Lspan x
+ } [list len $len] -reps $len
+ }
+
+ perf destroy
+ }
+
+ proc lpop_describe {share_mode len at reps} {
+ return "lpop L\[$len\] $share_mode at $at $reps times"
+ }
+ proc lpop_perf {} {
+ variable Lengths
+
+ print_separator lpop
+
+ ListPerf create perf
+
+ # Shared
+ perf option -overhead {set L2 $L}
+ foreach len $Lengths {
+ set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
+ foreach idx {0 1 end-1 end} {
+ comment Pop element at position $idx from a shared list variable
+ perf measure [lpop_describe shared $len $idx $reps] {
+ set L2 $L
+ lpop L $idx
+ } [list len $len idx $idx] -reps $reps
+ }
+ }
+
+ # Unshared
+ perf option -overhead {}
+ foreach len $Lengths {
+ set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
+ foreach idx {0 1 end-1 end} {
+ comment Pop element at position $idx from an unshared list variable
+ perf measure [lpop_describe unshared $len $idx $reps] {
+ lpop L $idx
+ } [list len $len idx $idx] -reps $reps
+ }
+ }
+
+ perf destroy
+
+ # Nested
+ ListPerf create perf -setup {
+ set L [lrepeat $len [list a b]]
+ }
+
+ # Shared, nested index
+ perf option -overhead {set L2 $L; set L L2}
+ foreach len $Lengths {
+ set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
+ foreach idx {0 1 end-1 end} {
+ perf measure [lpop_describe shared $len "{$idx 0}" $reps] {
+ set L2 $L
+ lpop L $idx 0
+ set L $L2
+ } [list len $len idx $idx] -reps $reps
+ }
+ }
+
+ # TODO - Nested Unshared
+ # Not sure how to measure performance. When unshared there is no copy
+ # so deleting a nested index repeatedly is not feasible
+
+ perf destroy
+ }
+
+ proc lassign_describe {share_mode len num reps} {
+ return "lassign L\[$len\] $share_mode $num elems $reps times"
+ }
+ proc lassign_perf {} {
+ variable Lengths
+
+ print_separator lassign
+
+ ListPerf create perf
+
+ foreach len $Lengths {
+ set reps 1000
+ comment Reflexive lassign - shared
+ perf measure [lassign_describe shared $len 1 $reps] {
+ set L2 $L
+ set L2 [lassign $L2 v]
+ } [list len $len] -overhead {set L2 $L} -reps $reps
+
+ set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}]
+ comment Reflexive lassign - unshared
+ perf measure [lassign_describe unshared $len 1 $reps] {
+ set L [lassign $L v]
+ } [list len $len] -reps $reps
+
+ set reps 1000
+ comment Reflexive lassign - shared, multiple
+ perf measure [lassign_describe shared $len 5 $reps] {
+ set L2 $L
+ set L2 [lassign $L2 a b c d e]
+ } [list len $len] -overhead {set L2 $L} -reps $reps
+ }
+ perf destroy
+ }
+
+ proc lrepeat_describe {len num} {
+ return "lrepeat L\[$len\] $num elems at a time"
+ }
+ proc lrepeat_perf {} {
+ variable Lengths
+
+ print_separator lrepeat
+
+ ListPerf create perf -reps 100000
+ foreach len $Lengths {
+ comment Generate a list from a single repeated element
+ perf measure [lrepeat_describe $len 1] {
+ lrepeat $len a
+ } [list len $len]
+
+ comment Generate a list from multiple repeated elements
+ perf measure [lrepeat_describe $len 5] {
+ lrepeat $len a b c d e
+ } [list len $len]
+ }
+
+ perf destroy
+ }
+
+ proc lreverse_describe {share_mode len} {
+ return "lreverse L\[$len\] $share_mode"
+ }
+ proc lreverse_perf {} {
+ variable Lengths
+
+ print_separator lreverse
+
+ ListPerf create perf -reps 10000
+
+ foreach len $Lengths {
+ comment Reverse a shared list
+ perf measure [lreverse_describe shared $len] {
+ lreverse $L
+ } [list len $len]
+
+ comment Reverse a unshared list
+ perf measure [lreverse_describe unshared $len] {
+ set L [lreverse $L[set L {}]]
+ } [list len $len] -overhead {set L $L; set L {}}
+
+ if {$len >= 100} {
+ comment Reverse a shared-span list
+ perf measure [lreverse_describe shared-span $len] {
+ lreverse $Lspan
+ } [list len $len]
+
+ comment Reverse a unshared-span list
+ perf measure [lreverse_describe unshared-span $len] {
+ set Lspan [lreverse $Lspan[set Lspan {}]]
+ } [list len $len] -overhead {set Lspan $Lspan; set Lspan {}}
+ }
+ }
+
+ perf destroy
+ }
+
+ proc llength_describe {share_mode len} {
+ return "llength L\[$len\] $share_mode"
+ }
+ proc llength_perf {} {
+ variable Lengths
+
+ print_separator llength
+
+ ListPerf create perf -reps 100000
+
+ foreach len $Lengths {
+ comment Length of a list
+ perf measure [llength_describe shared $len] {
+ llength $L
+ } [list len $len]
+
+ if {$len >= 100} {
+ comment Length of a span list
+ perf measure [llength_describe shared-span $len] {
+ llength $Lspan
+ } [list len $len]
+ }
+ }
+
+ perf destroy
+ }
+
+ proc lindex_describe {share_mode len at} {
+ return "lindex L\[$len\] $share_mode at $at"
+ }
+ proc lindex_perf {} {
+ variable Lengths
+
+ print_separator lindex
+
+ ListPerf create perf -reps 100000
+
+ foreach len $Lengths {
+ comment Index into a list
+ set idx [expr {$len/2}]
+ perf measure [lindex_describe shared $len $idx] {
+ lindex $L $idx
+ } [list len $len idx $idx]
+
+ if {$len >= 100} {
+ comment Index into a span list
+ perf measure [lindex_describe shared-span $len $idx] {
+ lindex $Lspan $idx
+ } [list len $len idx $idx]
+ }
+ }
+
+ perf destroy
+ }
+
+ proc lrange_describe {share_mode len range} {
+ return "lrange L\[$len\] $share_mode range $range"
+ }
+
+ proc lrange_perf {} {
+ variable Lengths
+
+ print_separator lrange
+
+ ListPerf create perf -time 1000 -reps 100000
+
+ foreach share_mode {shared unshared} {
+ foreach len $Lengths {
+ set eighth [expr {$len/8}]
+ set ranges [list \
+ [list 0 0] [list 0 end-1] \
+ [list $eighth [expr {3*$eighth}]] \
+ [list $eighth [expr {7*$eighth}]] \
+ [list 1 end] [list end-1 end] \
+ ]
+ foreach range $ranges {
+ comment Range $range in $share_mode list of length $len
+ if {$share_mode eq "shared"} {
+ perf measure [lrange_describe shared $len $range] \
+ "lrange \$L $range" [list len $len range $range]
+ } else {
+ perf measure [lrange_describe unshared $len $range] \
+ "lrange \[lrepeat \$len\ a] $range" \
+ [list len $len range $range] -overhead {lrepeat $len a}
+ }
+ }
+
+ if {$len >= 100} {
+ foreach range $ranges {
+ comment Range $range in ${share_mode}-span list of length $len
+ if {$share_mode eq "shared"} {
+ perf measure [lrange_describe shared-span $len $range] \
+ "lrange \$Lspan {*}$range" [list len $len range $range]
+ } else {
+ perf measure [lrange_describe unshared-span $len $range] \
+ "lrange \[perf::list::spanned_list \$len\] $range" \
+ [list len $len range $range] -overhead {perf::list::spanned_list $len}
+ }
+ }
+ }
+ }
+ }
+
+ perf destroy
+ }
+
+ proc lset_describe {share_mode len at} {
+ return "lset L\[$len\] $share_mode at $at"
+ }
+ proc lset_perf {} {
+ variable Lengths
+
+ print_separator lset
+
+ ListPerf create perf -reps 10000
+
+ # Shared
+ foreach share_mode {shared unshared} {
+ foreach len $Lengths {
+ foreach idx {0 1 end-1 end end+1} {
+ comment lset at position $idx in a $share_mode list variable
+ if {$share_mode eq "shared"} {
+ perf measure [lset_describe shared $len $idx] {
+ set L2 $L
+ lset L $idx X
+ } [list len $len idx $idx] -overhead {set L2 $L}
+ } else {
+ perf measure [lset_describe unshared $len $idx] {
+ lset L $idx X
+ } [list len $len idx $idx]
+ }
+ }
+ }
+ }
+
+ perf destroy
+
+ # Nested
+ ListPerf create perf -setup {
+ set L [lrepeat $len [list a b]]
+ }
+
+ foreach share_mode {shared unshared} {
+ foreach len $Lengths {
+ foreach idx {0 1 end-1 end} {
+ comment lset at position $idx in a $share_mode list variable
+ if {$share_mode eq "shared"} {
+ perf measure [lset_describe shared $len "{$idx 0}"] {
+ set L2 $L
+ lset L $idx 0 X
+ } [list len $len idx $idx] -overhead {set L2 $L}
+ } else {
+ perf measure [lset_describe unshared $len "{$idx 0}"] {
+ lset L $idx 0 {X Y}
+ } [list len $len idx $idx]
+ }
+ }
+ }
+ }
+
+ perf destroy
+ }
+
+ proc lremove_describe {share_mode len at nremoved} {
+ return "lremove L\[$len\] $share_mode $nremoved elements at $at"
+ }
+ proc lremove_perf {} {
+ variable Lengths
+
+ print_separator lremove
+
+ ListPerf create perf -reps 10000
+
+ foreach share_mode {shared unshared} {
+ foreach len $Lengths {
+ foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
+ if {$share_mode eq "shared"} {
+ comment Remove one element from shared list
+ perf measure [lremove_describe shared $len $idx 1] \
+ {lremove $L $idx} [list len $len idx $idx]
+
+ } else {
+ comment Remove one element from unshared list
+ set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}]
+ perf measure [lremove_describe unshared $len $idx 1] \
+ {set L [lremove $L[set L {}] $idx]} [list len $len idx $idx] \
+ -overhead {set L $L; set L {}} -reps $reps
+ }
+ }
+ if {$share_mode eq "shared"} {
+ comment Remove multiple elements from shared list
+ perf measure [lremove_describe shared $len [list 0 1 [expr {$len/2}] end-1 end] 5] {
+ lremove $L 0 1 [expr {$len/2}] end-1 end
+ } [list len $len]
+ }
+ }
+ # Span
+ foreach len $Lengths {
+ foreach idx [list 0 1 [expr {$len/2}] end-1 end] {
+ if {$share_mode eq "shared"} {
+ comment Remove one element from shared-span list
+ perf measure [lremove_describe shared-span $len $idx 1] \
+ {lremove $Lspan $idx} [list len $len idx $idx]
+ } else {
+ comment Remove one element from unshared-span list
+ set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}]
+ perf measure [lremove_describe unshared-span $len $idx 1] \
+ {set Lspan [lremove $Lspan[set Lspan {}] $idx]} [list len $len idx $idx] \
+ -overhead {set Lspan $Lspan; set Lspan {}} -reps $reps
+ }
+ }
+ if {$share_mode eq "shared"} {
+ comment Remove multiple elements from shared-span list
+ perf measure [lremove_describe shared-span $len [list 0 1 [expr {$len/2}] end-1 end] 5] {
+ lremove $Lspan 0 1 [expr {$len/2}] end-1 end
+ } [list len $len]
+ }
+ }
+ }
+
+ perf destroy
+ }
+
+ proc lreplace_describe {share_mode len first last ninsert {times 1}} {
+ if {$last < $first} {
+ return "lreplace L\[$len\] $share_mode 0 ($first:$last) elems at $first with $ninsert elems $times times."
+ }
+ return "lreplace L\[$len\] $share_mode $first:$last with $ninsert elems $times times."
+ }
+ proc lreplace_perf {} {
+ variable Lengths
+
+ print_separator lreplace
+
+ set default_reps 10000
+ ListPerf create perf -reps $default_reps
+
+ foreach share_mode {shared unshared} {
+ # Insert only
+ foreach len $Lengths {
+ set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
+ foreach first [list 0 1 [expr {$len/2}] end-1 end] {
+ if {$share_mode eq "shared"} {
+ comment Insert one to shared list
+ perf measure [lreplace_describe shared $len $first -1 1] {
+ lreplace $L $first -1 x
+ } [list len $len first $first]
+
+ comment Insert multiple to shared list
+ perf measure [lreplace_describe shared $len $first -1 10] {
+ lreplace $L $first -1 X X X X X X X X X X
+ } [list len $len first $first]
+
+ comment Insert one to shared list repeatedly
+ perf measure [lreplace_describe shared $len $first -1 1 $reps] {
+ set L [lreplace $L $first -1 x]
+ } [list len $len first $first] -reps $reps
+
+ comment Insert multiple to shared list repeatedly
+ perf measure [lreplace_describe shared $len $first -1 10 $reps] {
+ set L [lreplace $L $first -1 X X X X X X X X X X]
+ } [list len $len first $first] -reps $reps
+
+ } else {
+ comment Insert one to unshared list
+ perf measure [lreplace_describe unshared $len $first -1 1] {
+ set L [lreplace $L[set L {}] $first -1 x]
+ } [list len $len first $first] -overhead {
+ set L $L; set L {}
+ } -reps $reps
+
+ comment Insert multiple to unshared list
+ perf measure [lreplace_describe unshared $len $first -1 10] {
+ set L [lreplace $L[set L {}] $first -1 X X X X X X X X X X]
+ } [list len $len first $first] -overhead {
+ set L $L; set L {}
+ } -reps $reps
+ }
+ }
+ }
+
+ # Delete only
+ foreach len $Lengths {
+ set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
+ foreach first [list 0 1 [expr {$len/2}] end-1 end] {
+ if {$share_mode eq "shared"} {
+ comment Delete one from shared list
+ perf measure [lreplace_describe shared $len $first $first 0] {
+ lreplace $L $first $first
+ } [list len $len first $first]
+ } else {
+ comment Delete one from unshared list
+ perf measure [lreplace_describe unshared $len $first $first 0] {
+ set L [lreplace $L[set L {}] $first $first x]
+ } [list len $len first $first] -overhead {
+ set L $L; set L {}
+ } -reps $reps
+ }
+ }
+ }
+
+ # Insert + delete
+ foreach len $Lengths {
+ set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
+ foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] {
+ lassign $range first last
+ if {$share_mode eq "shared"} {
+ comment Insertions more than deletions from shared list
+ perf measure [lreplace_describe shared $len $first $last 3] {
+ lreplace $L $first $last X Y Z
+ } [list len $len first $first last $last]
+
+ comment Insertions same as deletions from shared list
+ perf measure [lreplace_describe shared $len $first $last 2] {
+ lreplace $L $first $last X Y
+ } [list len $len first $first last $last]
+
+ comment Insertions fewer than deletions from shared list
+ perf measure [lreplace_describe shared $len $first $last 1] {
+ lreplace $L $first $last X
+ } [list len $len first $first last $last]
+ } else {
+ comment Insertions more than deletions from unshared list
+ perf measure [lreplace_describe unshared $len $first $last 3] {
+ set L [lreplace $L[set L {}] $first $last X Y Z]
+ } [list len $len first $first last $last] -overhead {
+ set L $L; set L {}
+ } -reps $reps
+
+ comment Insertions same as deletions from unshared list
+ perf measure [lreplace_describe unshared $len $first $last 2] {
+ set L [lreplace $L[set L {}] $first $last X Y ]
+ } [list len $len first $first last $last] -overhead {
+ set L $L; set L {}
+ } -reps $reps
+
+ comment Insertions fewer than deletions from unshared list
+ perf measure [lreplace_describe unshared $len $first $last 1] {
+ set L [lreplace $L[set L {}] $first $last X]
+ } [list len $len first $first last $last] -overhead {
+ set L $L; set L {}
+ } -reps $reps
+ }
+ }
+ }
+ # Spanned Insert + delete
+ foreach len $Lengths {
+ set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}]
+ foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] {
+ lassign $range first last
+ if {$share_mode eq "shared"} {
+ comment Insertions more than deletions from shared-span list
+ perf measure [lreplace_describe shared-span $len $first $last 3] {
+ lreplace $Lspan $first $last X Y Z
+ } [list len $len first $first last $last]
+
+ comment Insertions same as deletions from shared-span list
+ perf measure [lreplace_describe shared-span $len $first $last 2] {
+ lreplace $Lspan $first $last X Y
+ } [list len $len first $first last $last]
+
+ comment Insertions fewer than deletions from shared-span list
+ perf measure [lreplace_describe shared-span $len $first $last 1] {
+ lreplace $Lspan $first $last X
+ } [list len $len first $first last $last]
+ } else {
+ comment Insertions more than deletions from unshared-span list
+ perf measure [lreplace_describe unshared-span $len $first $last 3] {
+ set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y Z]
+ } [list len $len first $first last $last] -overhead {
+ set Lspan $Lspan; set Lspan {}
+ } -reps $reps
+
+ comment Insertions same as deletions from unshared-span list
+ perf measure [lreplace_describe unshared-span $len $first $last 2] {
+ set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y ]
+ } [list len $len first $first last $last] -overhead {
+ set Lspan $Lspan; set Lspan {}
+ } -reps $reps
+
+ comment Insertions fewer than deletions from unshared-span list
+ perf measure [lreplace_describe unshared-span $len $first $last 1] {
+ set Lspan [lreplace $Lspan[set Lspan {}] $first $last X]
+ } [list len $len first $first last $last] -overhead {
+ set Lspan $Lspan; set Lspan {}
+ } -reps $reps
+ }
+ }
+ }
+ }
+
+ perf destroy
+ }
+
+ proc join_describe {share_mode len} {
+ return "join L\[$len\] $share_mode"
+ }
+ proc join_perf {} {
+ variable Lengths
+
+ print_separator join
+
+ ListPerf create perf -reps 10000
+ foreach len $Lengths {
+ comment Join a list
+ perf measure [join_describe shared $len] {
+ join $L
+ } [list len $len]
+ }
+ foreach len $Lengths {
+ comment Join a spanned list
+ perf measure [join_describe shared-span $len] {
+ join $Lspan
+ } [list len $len]
+ }
+ perf destroy
+ }
+
+ proc lsearch_describe {share_mode len} {
+ return "lsearch L\[$len\] $share_mode"
+ }
+ proc lsearch_perf {} {
+ variable Lengths
+
+ print_separator lsearch
+
+ ListPerf create perf -reps 100000
+ foreach len $Lengths {
+ comment Search a list
+ perf measure [lsearch_describe shared $len] {
+ lsearch $L needle
+ } [list len $len]
+ }
+ foreach len $Lengths {
+ comment Search a spanned list
+ perf measure [lsearch_describe shared-span $len] {
+ lsearch $Lspan needle
+ } [list len $len]
+ }
+ perf destroy
+ }
+
+ proc foreach_describe {share_mode len} {
+ return "foreach L\[$len\] $share_mode"
+ }
+ proc foreach_perf {} {
+ variable Lengths
+
+ print_separator foreach
+
+ ListPerf create perf -reps 10000
+ foreach len $Lengths {
+ comment Iterate through a list
+ perf measure [foreach_describe shared $len] {
+ foreach e $L {}
+ } [list len $len]
+ }
+ foreach len $Lengths {
+ comment Iterate a spanned list
+ perf measure [foreach_describe shared-span $len] {
+ foreach e $Lspan {}
+ } [list len $len]
+ }
+ perf destroy
+ }
+
+ proc lmap_describe {share_mode len} {
+ return "lmap L\[$len\] $share_mode"
+ }
+ proc lmap_perf {} {
+ variable Lengths
+
+ print_separator lmap
+
+ ListPerf create perf -reps 10000
+ foreach len $Lengths {
+ comment Iterate through a list
+ perf measure [lmap_describe shared $len] {
+ lmap e $L {}
+ } [list len $len]
+ }
+ foreach len $Lengths {
+ comment Iterate a spanned list
+ perf measure [lmap_describe shared-span $len] {
+ lmap e $Lspan {}
+ } [list len $len]
+ }
+ perf destroy
+ }
+
+ proc get_sort_sample {{spanned 0}} {
+ variable perfScript
+ variable sortSampleText
+
+ if {![info exists sortSampleText]} {
+ set fd [open $perfScript]
+ set sortSampleText [split [read $fd] ""]
+ close $fd
+ }
+ set sortSampleText [string range $sortSampleText 0 9999]
+
+ # NOTE: do NOT cache list result in a variable as we need it unshared
+ if {$spanned} {
+ return [lrange [split $sortSampleText ""] 1 end-1]
+ } else {
+ return [split $sortSampleText ""]
+ }
+ }
+ proc lsort_describe {share_mode len} {
+ return "lsort L\[$len] $share_mode"
+ }
+ proc lsort_perf {} {
+ print_separator lsort
+
+ ListPerf create perf -setup {}
+
+ comment Sort a shared list
+ perf measure [lsort_describe shared [llength [perf::list::get_sort_sample]]] {
+ lsort $L
+ } {} -setup {set L [perf::list::get_sort_sample]}
+
+ comment Sort an unshared list
+ perf measure [lsort_describe unshared [llength [perf::list::get_sort_sample]]] {
+ lsort [perf::list::get_sort_sample]
+ } {} -overhead {perf::list::get_sort_sample}
+
+ comment Sort a shared-span list
+ perf measure [lsort_describe shared-span [llength [perf::list::get_sort_sample 1]]] {
+ lsort $L
+ } {} -setup {set L [perf::list::get_sort_sample 1]}
+
+ comment Sort an unshared-span list
+ perf measure [lsort_describe unshared-span [llength [perf::list::get_sort_sample 1]]] {
+ lsort [perf::list::get_sort_sample 1]
+ } {} -overhead {perf::list::get_sort_sample 1}
+
+ perf destroy
+ }
+
+ proc concat_describe {canonicality len elemlen} {
+ return "concat L\[$len\] $canonicality with elements of length $elemlen"
+ }
+ proc concat_perf {} {
+ variable Lengths
+
+ print_separator concat
+
+ ListPerf create perf -reps 100000
+
+ foreach len $Lengths {
+ foreach elemlen {1 100} {
+ comment Pure lists (no string representation)
+ perf measure [concat_describe "pure lists" $len $elemlen] {
+ concat $L $L
+ } [list len $len elemlen $elemlen] -setup {
+ set L [lrepeat $len [string repeat a $elemlen]]
+ }
+
+ comment Canonical lists (with string representation)
+ perf measure [concat_describe "canonical lists" $len $elemlen] {
+ concat $L $L
+ } [list len $len elemlen $elemlen] -setup {
+ set L [lrepeat $len [string repeat a $elemlen]]
+ append x x $L; # Generate string while keeping internal rep list
+ unset x
+ }
+
+ comment Non-canonical lists
+ perf measure [concat_describe "non-canonical lists" $len $elemlen] {
+ concat $L $L
+ } [list len $len elemlen $elemlen] -setup {
+ set L [string repeat "[string repeat a $elemlen] " $len]
+ llength $L
+ }
+ }
+ }
+
+ # Span version
+ foreach len $Lengths {
+ foreach elemlen {1 100} {
+ comment Pure span lists (no string representation)
+ perf measure [concat_describe "pure spanned lists" $len $elemlen] {
+ concat $L $L
+ } [list len $len elemlen $elemlen] -setup {
+ set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1]
+ }
+
+ comment Canonical span lists (with string representation)
+ perf measure [concat_describe "canonical spanned lists" $len $elemlen] {
+ concat $L $L
+ } [list len $len elemlen $elemlen] -setup {
+ set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1]
+ append x x $L; # Generate string while keeping internal rep list
+ unset x
+ }
+ }
+ }
+
+ perf destroy
+ }
+
+ proc test {} {
+ variable RunTimes
+ variable Options
+
+ set selections [perf::list::setup $::argv]
+ if {[llength $selections] == 0} {
+ set commands [info commands ::perf::list::*_perf]
+ } else {
+ set commands [lmap sel $selections {
+ if {$sel eq "help"} {
+ print_usage
+ continue
+ }
+ set cmd ::perf::list::${sel}_perf
+ if {$cmd ni [info commands ::perf::list::*_perf]} {
+ puts stderr "Error: command $sel is not known or supported. Skipping."
+ continue
+ }
+ set cmd
+ }]
+ }
+ comment Setting up
+ timerate -calibrate {}
+ if {[info exists Options(--label)]} {
+ print "L $Options(--label)"
+ }
+ print "V [info patchlevel]"
+ print "E [info nameofexecutable]"
+ if {[info exists Options(--description)]} {
+ print "D $Options(--description)"
+ }
+ set twapi_keys {-privatebytes -workingset -workingsetpeak}
+ if {[info commands ::twapi::get_process_memory_info] ne ""} {
+ set twapi_vm_pre [::twapi::get_process_memory_info]
+ }
+ foreach cmd [lsort -dictionary $commands] {
+ set RunTimes(command) 0.0
+ $cmd
+ set RunTimes(total) [expr {$RunTimes(total)+$RunTimes(command)}]
+ print "P [format_timings $RunTimes(command) 1] [string range $cmd 14 end-5] total run time"
+ }
+ # Print total runtime in same format as timerate output
+ print "P [format_timings $RunTimes(total) 1] Total run time"
+
+ if {[info exists twapi_vm_pre]} {
+ set twapi_vm_post [::twapi::get_process_memory_info]
+ set MB 1048576.0
+ foreach key $twapi_keys {
+ set pre [expr {[dict get $twapi_vm_pre $key]/$MB}]
+ set post [expr {[dict get $twapi_vm_post $key]/$MB}]
+ print "P [format_timings $pre 1] Memory (MB) $key pre-test"
+ print "P [format_timings $post 1] Memory (MB) $key post-test"
+ print "P [format_timings [expr {$post-$pre}] 1] Memory (MB) delta $key"
+ }
+ }
+ if {[info commands memory] ne ""} {
+ foreach line [split [memory info] \n] {
+ if {$line eq ""} continue
+ set line [split $line]
+ set val [expr {[lindex $line end]/1000.0}]
+ set line [string trim [join [lrange $line 0 end-1]]]
+ print "P [format_timings $val 1] memdbg $line (in thousands)"
+ }
+ print "# Allocations not freed on exit written to the lost-memory.tmp file."
+ print "# These will have to be manually compared."
+ # env TCL_FINALIZE_ON_EXIT must be set to 1 for this.
+ # DO NOT SET HERE - set ::env(TCL_FINALIZE_ON_EXIT) 1
+ # Must be set in environment before starting tclsh else bogus results
+ if {[info exists Options(--label)]} {
+ set dump_file list-memory-$Options(--label).memdmp
+ } else {
+ set dump_file list-memory-[pid].memdmp
+ }
+ memory onexit $dump_file
+ }
+ }
+}
+
+
+if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
+ ::perf::list::test
+}
--
cgit v0.12