summaryrefslogtreecommitdiffstats
path: root/tests-perf
diff options
context:
space:
mode:
Diffstat (limited to 'tests-perf')
-rw-r--r--tests-perf/chan.perf.tcl93
-rw-r--r--tests-perf/clock.perf.tcl411
-rw-r--r--tests-perf/comparePerf.tcl371
-rw-r--r--tests-perf/list.perf.tcl99
-rw-r--r--tests-perf/listPerf.tcl1295
-rw-r--r--tests-perf/test-performance.tcl199
-rw-r--r--tests-perf/timer-event.perf.tcl182
7 files changed, 0 insertions, 2650 deletions
diff --git a/tests-perf/chan.perf.tcl b/tests-perf/chan.perf.tcl
deleted file mode 100644
index 2ef87cb..0000000
--- a/tests-perf/chan.perf.tcl
+++ /dev/null
@@ -1,93 +0,0 @@
-#!/usr/bin/tclsh
-
-# ------------------------------------------------------------------------
-#
-# chan.perf.tcl --
-#
-# This file provides performance tests for comparison of tcl-speed
-# of channel subsystem.
-#
-# ------------------------------------------------------------------------
-#
-# Copyright (c) 2024 Serg G. Brester (aka sebres)
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
-
-
-if {![namespace exists ::tclTestPerf]} {
- source [file join [file dirname [info script]] test-performance.tcl]
-}
-
-
-namespace eval ::tclTestPerf-Chan {
-
-namespace path {::tclTestPerf}
-
-proc _get_test_chan {{bufSize 4096}} {
- lassign [chan pipe] ch wch;
- fconfigure $ch -translation binary -encoding utf-8 -buffersize $bufSize -buffering full
- fconfigure $wch -translation binary -encoding utf-8 -buffersize $bufSize -buffering full
-
- exec [info nameofexecutable] -- $bufSize >@$wch << {
- set bufSize [lindex $::argv end]
- fconfigure stdout -translation binary -encoding utf-8 -buffersize $bufSize -buffering full
- set buf [string repeat test 1000]; # 4K
- # write ~ 10*1M + 10*2M + 10*10M + 1*20M:
- set i 0; while {$i < int((10*1e6 + 10*2e6 + 10*10e6 + 1*20e6)/4e3)} {
- #puts -nonewline stdout $i\t
- puts stdout $buf
- #flush stdout; # don't flush to use full buffer
- incr i
- }
- } &
- close $wch
- return $ch
-}
-
-# regression tests for [bug-da16d15574] (fix for [db4f2843cd]):
-proc test-read-regress {{reptime {50000 10}}} {
- _test_run -no-result $reptime {
- # with 4KB buffersize:
- setup { set ch [::tclTestPerf-Chan::_get_test_chan 4096]; fconfigure $ch -buffersize }
- # 10 * 1M:
- {read $ch [expr {int(1e6)}]}
- # 10 * 2M:
- {read $ch [expr {int(2e6)}]}
- # 10 * 10M:
- {read $ch [expr {int(10e6)}]}
- # 1 * 20M:
- {read $ch; break}
- cleanup { close $ch }
-
- # with 1MB buffersize:
- setup { set ch [::tclTestPerf-Chan::_get_test_chan 1048576]; fconfigure $ch -buffersize }
- # 10 * 1M:
- {read $ch [expr {int(1e6)}]}
- # 10 * 2M:
- {read $ch [expr {int(2e6)}]}
- # 10 * 10M:
- {read $ch [expr {int(10e6)}]}
- # 1 * 20M:
- {read $ch; break}
- cleanup { close $ch }
- }
-}
-
-proc test {{reptime 1000}} {
- test-read-regress
-
- puts \n**OK**
-}
-
-}; # end of ::tclTestPerf-Chan
-
-# ------------------------------------------------------------------------
-
-# if calling direct:
-if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
- array set in {-time 500}
- array set in $argv
- ::tclTestPerf-Chan::test $in(-time)
-}
diff --git a/tests-perf/clock.perf.tcl b/tests-perf/clock.perf.tcl
deleted file mode 100644
index ad928c2..0000000
--- a/tests-perf/clock.perf.tcl
+++ /dev/null
@@ -1,411 +0,0 @@
-#!/usr/bin/tclsh
-# ------------------------------------------------------------------------
-#
-# test-performance.tcl --
-#
-# This file provides common performance tests for comparison of tcl-speed
-# degradation by switching between branches.
-# (currently for clock ensemble only)
-#
-# ------------------------------------------------------------------------
-#
-# Copyright © 2014 Serg G. Brester (aka sebres)
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
-
-array set in {-time 500}
-if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
- array set in $argv
-}
-
-## common test performance framework:
-if {![namespace exists ::tclTestPerf]} {
- source [file join [file dirname [info script]] test-performance.tcl]
-}
-
-namespace eval ::tclTestPerf-TclClock {
-
-namespace path {::tclTestPerf}
-
-## set testing defaults:
-set ::env(TCL_TZ) :CET
-
-# warm-up interpreter compiler env, clock platform-related features:
-
-## warm-up test-related features (load clock.tcl, system zones, locales, etc.):
-clock scan "" -gmt 1
-clock scan ""
-clock scan "" -timezone :CET
-clock scan "" -format "" -locale en
-clock scan "" -format "" -locale de
-
-## ------------------------------------------
-
-proc test-format {{reptime 1000}} {
- _test_run $reptime {
- # Format : short, week only (in gmt)
- {clock format 1482525936 -format "%u" -gmt 1}
- # Format : short, week only (system zone)
- {clock format 1482525936 -format "%u"}
- # Format : short, week only (CEST)
- {clock format 1482525936 -format "%u" -timezone :CET}
- # Format : date only (in gmt)
- {clock format 1482525936 -format "%Y-%m-%d" -gmt 1}
- # Format : date only (system zone)
- {clock format 1482525936 -format "%Y-%m-%d"}
- # Format : date only (CEST)
- {clock format 1482525936 -format "%Y-%m-%d" -timezone :CET}
- # Format : time only (in gmt)
- {clock format 1482525936 -format "%H:%M" -gmt 1}
- # Format : time only (system zone)
- {clock format 1482525936 -format "%H:%M"}
- # Format : time only (CEST)
- {clock format 1482525936 -format "%H:%M" -timezone :CET}
- # Format : time only (in gmt)
- {clock format 1482525936 -format "%H:%M:%S" -gmt 1}
- # Format : time only (system zone)
- {clock format 1482525936 -format "%H:%M:%S"}
- # Format : time only (CEST)
- {clock format 1482525936 -format "%H:%M:%S" -timezone :CET}
- # Format : default (in gmt)
- {clock format 1482525936 -gmt 1 -locale en}
- # Format : default (system zone)
- {clock format 1482525936 -locale en}
- # Format : default (CEST)
- {clock format 1482525936 -timezone :CET -locale en}
- # Format : ISO date-time (in gmt, numeric zone)
- {clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z" -gmt 1}
- # Format : ISO date-time (system zone, CEST, numeric zone)
- {clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z"}
- # Format : ISO date-time (CEST, numeric zone)
- {clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %z" -timezone :CET}
- # Format : ISO date-time (system zone, CEST)
- {clock format 1246379400 -format "%Y-%m-%dT%H:%M:%S %Z"}
- # Format : julian day with time (in gmt):
- {clock format 1246379415 -format "%J %H:%M:%S" -gmt 1}
- # Format : julian day with time (system zone):
- {clock format 1246379415 -format "%J %H:%M:%S"}
-
- # Format : locale date-time (en):
- {clock format 1246379415 -format "%x %X" -locale en}
- # Format : locale date-time (de):
- {clock format 1246379415 -format "%x %X" -locale de}
-
- # Format : locale lookup table month:
- {clock format 1246379400 -format "%b" -locale en -gmt 1}
- # Format : locale lookup 2 tables - month and day:
- {clock format 1246379400 -format "%b %Od" -locale en -gmt 1}
- # Format : locale lookup 3 tables - week, month and day:
- {clock format 1246379400 -format "%a %b %Od" -locale en -gmt 1}
- # Format : locale lookup 4 tables - week, month, day and year:
- {clock format 1246379400 -format "%a %b %Od %Oy" -locale en -gmt 1}
-
- # Format : dynamic clock value (without converter caches):
- setup {set i 0}
- {clock format [incr i] -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET}
- cleanup {puts [clock format $i -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET]}
- # Format : dynamic clock value (without any converter caches, zone range overflow):
- setup {set i 0}
- {clock format [incr i 86400] -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET}
- cleanup {puts [clock format $i -format "%Y-%m-%dT%H:%M:%S" -locale en -timezone :CET]}
-
- # Format : dynamic format (cacheable)
- {clock format 1246379415 -format [string trim "%d.%m.%Y %H:%M:%S "] -gmt 1}
-
- # Format : all (in gmt, locale en)
- {clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -gmt 1 -locale en}
- # Format : all (in CET, locale de)
- {clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -timezone :CET -locale de}
- }
-}
-
-proc test-scan {{reptime 1000}} {
- _test_run -convert-result {clock format $_(r) -locale en} $reptime {
- # Scan : date (in gmt)
- {clock scan "25.11.2015" -format "%d.%m.%Y" -base 0 -gmt 1}
- # Scan : date (system time zone, with base)
- {clock scan "25.11.2015" -format "%d.%m.%Y" -base 0}
- # Scan : date (system time zone, without base)
- {clock scan "25.11.2015" -format "%d.%m.%Y"}
- # Scan : greedy match
- {clock scan "111" -format "%d%m%y" -base 0 -gmt 1}
- {clock scan "1111" -format "%d%m%y" -base 0 -gmt 1}
- {clock scan "11111" -format "%d%m%y" -base 0 -gmt 1}
- {clock scan "111111" -format "%d%m%y" -base 0 -gmt 1}
- # Scan : greedy match (space separated)
- {clock scan "1 1 1" -format "%d%m%y" -base 0 -gmt 1}
- {clock scan "111 1" -format "%d%m%y" -base 0 -gmt 1}
- {clock scan "1 111" -format "%d%m%y" -base 0 -gmt 1}
- {clock scan "1 11 1" -format "%d%m%y" -base 0 -gmt 1}
- {clock scan "1 11 11" -format "%d%m%y" -base 0 -gmt 1}
- {clock scan "11 11 11" -format "%d%m%y" -base 0 -gmt 1}
-
- # Scan : time (in gmt)
- {clock scan "10:35:55" -format "%H:%M:%S" -base 1000000000 -gmt 1}
- # Scan : time (system time zone, with base)
- {clock scan "10:35:55" -format "%H:%M:%S" -base 1000000000}
- # Scan : time (gmt, without base)
- {clock scan "10:35:55" -format "%H:%M:%S" -gmt 1}
- # Scan : time (system time zone, without base)
- {clock scan "10:35:55" -format "%H:%M:%S"}
-
- # Scan : date-time (in gmt)
- {clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S" -base 0 -gmt 1}
- # Scan : date-time (system time zone with base)
- {clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S" -base 0}
- # Scan : date-time (system time zone without base)
- {clock scan "25.11.2015 10:35:55" -format "%d.%m.%Y %H:%M:%S"}
-
- # Scan : julian day in gmt
- {clock scan 2451545 -format %J -gmt 1}
- # Scan : julian day in system TZ
- {clock scan 2451545 -format %J}
- # Scan : julian day in other TZ
- {clock scan 2451545 -format %J -timezone +0200}
- # Scan : julian day with time:
- {clock scan "2451545 10:20:30" -format "%J %H:%M:%S"}
- # Scan : julian day with time (greedy match):
- {clock scan "2451545 102030" -format "%J%H%M%S"}
-
- # Scan : century, lookup table month
- {clock scan {1970 Jan 2} -format {%C%y %b %d} -locale en -gmt 1}
- # Scan : century, lookup table month and day (both entries are first)
- {clock scan {1970 Jan 01} -format {%C%y %b %Od} -locale en -gmt 1}
- # Scan : century, lookup table month and day (list scan: entries with position 12 / 31)
- {clock scan {2016 Dec 31} -format {%C%y %b %Od} -locale en -gmt 1}
-
- # Scan : ISO date-time (CEST)
- {clock scan "2009-06-30T18:30:00+02:00" -format "%Y-%m-%dT%H:%M:%S%z"}
- {clock scan "2009-06-30T18:30:00 CEST" -format "%Y-%m-%dT%H:%M:%S %z"}
- # Scan : ISO date-time (UTC)
- {clock scan "2009-06-30T18:30:00Z" -format "%Y-%m-%dT%H:%M:%S%z"}
- {clock scan "2009-06-30T18:30:00 UTC" -format "%Y-%m-%dT%H:%M:%S %z"}
-
- # Scan : locale date-time (en):
- {clock scan "06/30/2009 18:30:15" -format "%x %X" -gmt 1 -locale en}
- # Scan : locale date-time (de):
- {clock scan "30.06.2009 18:30:15" -format "%x %X" -gmt 1 -locale de}
-
- # Scan : dynamic format (cacheable)
- {clock scan "25.11.2015 10:35:55" -format [string trim "%d.%m.%Y %H:%M:%S "] -base 0 -gmt 1}
-
- break
- # # Scan : long format test (allock chain)
- # {clock scan "25.11.2015" -format "%d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y" -base 0 -gmt 1}
- # # Scan : dynamic, very long format test (create obj representation, allock chain, GC, etc):
- # {clock scan "25.11.2015" -format [string repeat "[incr i] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
- # # Scan : again:
- # {clock scan "25.11.2015" -format [string repeat "[incr i -1] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
- }
-}
-
-proc test-freescan {{reptime 1000}} {
- _test_run -convert-result {clock format $_(r) -locale en} $reptime {
- # FreeScan : relative date
- {clock scan "5 years 18 months 385 days" -base 0 -gmt 1}
- # FreeScan : relative date with relative weekday
- {clock scan "5 years 18 months 385 days Fri" -base 0 -gmt 1}
- # FreeScan : relative date with ordinal month
- {clock scan "5 years 18 months 385 days next 1 January" -base 0 -gmt 1}
- # FreeScan : relative date with ordinal month and relative weekday
- {clock scan "5 years 18 months 385 days next January Fri" -base 0 -gmt 1}
- # FreeScan : ordinal month
- {clock scan "next January" -base 0 -gmt 1}
- # FreeScan : relative week
- {clock scan "next Fri" -base 0 -gmt 1}
- # FreeScan : relative weekday and week offset
- {clock scan "next January + 2 week" -base 0 -gmt 1}
- # FreeScan : time only with base
- {clock scan "19:18:30" -base 148863600 -gmt 1}
- # FreeScan : time only without base, gmt
- {clock scan "19:18:30" -gmt 1}
- # FreeScan : time only without base, system
- {clock scan "19:18:30"}
- # FreeScan : date, system time zone
- {clock scan "05/08/2016 20:18:30"}
- # FreeScan : date, supplied time zone
- {clock scan "05/08/2016 20:18:30" -timezone :CET}
- # FreeScan : date, supplied gmt (equivalent -timezone :GMT)
- {clock scan "05/08/2016 20:18:30" -gmt 1}
- # FreeScan : date, supplied time zone gmt
- {clock scan "05/08/2016 20:18:30" -timezone :GMT}
- # FreeScan : time only, numeric zone in string, base time gmt (exchange zones between gmt / -0500)
- {clock scan "20:18:30 -0500" -base 148863600 -gmt 1}
- # FreeScan : time only, zone in string (exchange zones between system / gmt)
- {clock scan "19:18:30 GMT" -base 148863600}
- # FreeScan : fast switch of zones in cycle - GMT, MST, CET (system) and EST
- {clock scan "19:18:30 MST" -base 148863600 -gmt 1
- clock scan "19:18:30 EST" -base 148863600
- }
- }
-}
-
-proc test-add {{reptime 1000}} {
- set tests {
- # Add : years
- {clock add 1246379415 5 years -gmt 1}
- # Add : months
- {clock add 1246379415 18 months -gmt 1}
- # Add : weeks
- {clock add 1246379415 20 weeks -gmt 1}
- # Add : days
- {clock add 1246379415 385 days -gmt 1}
- # Add : weekdays
- {clock add 1246379415 3 weekdays -gmt 1}
-
- # Add : hours
- {clock add 1246379415 5 hours -gmt 1}
- # Add : minutes
- {clock add 1246379415 55 minutes -gmt 1}
- # Add : seconds
- {clock add 1246379415 100 seconds -gmt 1}
-
- # Add : +/- in gmt
- {clock add 1246379415 -5 years +21 months -20 weeks +386 days -19 hours +30 minutes -10 seconds -gmt 1}
- # Add : +/- in system timezone
- {clock add 1246379415 -5 years +21 months -20 weeks +386 days -19 hours +30 minutes -10 seconds -timezone :CET}
-
- # Add : gmt
- {clock add 1246379415 -5 years 18 months 366 days 5 hours 30 minutes 10 seconds -gmt 1}
- # Add : system timezone
- {clock add 1246379415 -5 years 18 months 366 days 5 hours 30 minutes 10 seconds -timezone :CET}
-
- # Add : all in gmt
- {clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -gmt 1}
- # Add : all in system timezone
- {clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -timezone :CET}
-
- }
- # if does not support add of weekdays:
- if {[catch {clock add 0 3 weekdays -gmt 1}]} {
- regsub -all {\mweekdays\M} $tests "days" tests
- }
- _test_run -convert-result {clock format $_(r) -locale en} $reptime $tests
-}
-
-proc test-convert {{reptime 1000}} {
- _test_run $reptime {
- # Convert locale (en -> de):
- {clock format [clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en] -format "%a %b %d %Y" -gmt 1 -locale de}
- # Convert locale (de -> en):
- {clock format [clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de] -format "%a %b %d %Y" -gmt 1 -locale en}
-
- # Convert TZ: direct
- {clock format [clock scan "19:18:30" -base 148863600 -timezone EST] -timezone MST}
- {clock format [clock scan "19:18:30" -base 148863600 -timezone MST] -timezone EST}
- # Convert TZ: included in scan string & format
- {clock format [clock scan "19:18:30 EST" -base 148863600] -format "%H:%M:%S %z" -timezone MST}
- {clock format [clock scan "19:18:30 EST" -base 148863600] -format "%H:%M:%S %z" -timezone EST}
-
- # Format locale 1x: comparison values
- {clock format 0 -gmt 1 -locale en}
- {clock format 0 -gmt 1 -locale de}
- {clock format 0 -gmt 1 -locale fr}
- # Format locale 2x: without switching locale (en, en)
- {clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en}
- # Format locale 2x: with switching locale (en, de)
- {clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale de}
- # Format locale 3x: without switching locale (en, en, en)
- {clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale en}
- # Format locale 3x: with switching locale (en, de, fr)
- {clock format 0 -gmt 1 -locale en; clock format 0 -gmt 1 -locale de; clock format 0 -gmt 1 -locale fr}
-
- # Scan locale 2x: without switching locale (en, en) + (de, de)
- {clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en}
- {clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de}
- # Scan locale 2x: with switching locale (en, de)
- {clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de}
- # Scan locale 3x: with switching locale (en, de, fr)
- {clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en; clock scan "Di Mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale de; clock scan "mar. mai 30 2017" -format "%a %b %d %Y" -gmt 1 -locale fr}
-
- # Format TZ 2x: comparison values
- {clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"}
- {clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
- # Format TZ 2x: without switching
- {clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"}
- {clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
- # Format TZ 2x: with switching
- {clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"}
- # Format TZ 3x: with switching (CET, EST, MST)
- {clock format 0 -timezone CET -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone MST -format "%Y-%m-%d %H:%M:%S %z"}
- # Format TZ 3x: with switching (GMT, EST, MST)
- {clock format 0 -gmt 1 -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone EST -format "%Y-%m-%d %H:%M:%S %z"; clock format 0 -timezone MST -format "%Y-%m-%d %H:%M:%S %z"}
-
- # FreeScan TZ 2x (+1 system-default): without switching TZ
- {clock scan "19:18:30 MST" -base 148863600; clock scan "19:18:30 MST" -base 148863600}
- {clock scan "19:18:30 EST" -base 148863600; clock scan "19:18:30 EST" -base 148863600}
- # FreeScan TZ 2x (+1 system-default): with switching TZ
- {clock scan "19:18:30 MST" -base 148863600; clock scan "19:18:30 EST" -base 148863600}
- # FreeScan TZ 2x (+1 gmt, +1 system-default)
- {clock scan "19:18:30 MST" -base 148863600 -gmt 1; clock scan "19:18:30 EST" -base 148863600}
-
- # Scan TZ: comparison included in scan string vs. given
- {clock scan "2009-06-30T18:30:00 CEST" -format "%Y-%m-%dT%H:%M:%S %z"}
- {clock scan "2009-06-30T18:30:00 CET" -format "%Y-%m-%dT%H:%M:%S %z"}
- {clock scan "2009-06-30T18:30:00" -timezone CET -format "%Y-%m-%dT%H:%M:%S"}
- }
-}
-
-proc test-other {{reptime 1000}} {
- _test_run $reptime {
- # Bad zone
- {catch {clock scan "1 day" -timezone BAD_ZONE -locale en}}
-
- # Scan : julian day (overflow)
- {catch {clock scan 5373485 -format %J}}
-
- # Scan : test rotate of GC objects (format is dynamic, so tcl-obj removed with last reference)
- {set i 0; time { clock scan "[incr i] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50}
- # Scan : test reusability of GC objects (format is dynamic, so tcl-obj removed with last reference)
- {set i 50; time { clock scan "[incr i -1] - 25.11.2015" -format "$i - %d.%m.%Y" -base 0 -gmt 1 } 50}
- }
-}
-
-proc test-ensemble-perf {{reptime 1000}} {
- _test_run $reptime {
- # Clock clicks (ensemble)
- {clock clicks}
- # Clock clicks (direct)
- {::tcl::clock::clicks}
- # Clock seconds (ensemble)
- {clock seconds}
- # Clock seconds (direct)
- {::tcl::clock::seconds}
- # Clock microseconds (ensemble)
- {clock microseconds}
- # Clock microseconds (direct)
- {::tcl::clock::microseconds}
- # Clock scan (ensemble)
- {clock scan ""}
- # Clock scan (direct)
- {::tcl::clock::scan ""}
- # Clock format (ensemble)
- {clock format 0 -f %s}
- # Clock format (direct)
- {::tcl::clock::format 0 -f %s}
- }
-}
-
-proc test {{reptime 1000}} {
- puts ""
- test-ensemble-perf [expr {$reptime / 2}]; #fast enough
- test-format $reptime
- test-scan $reptime
- test-freescan $reptime
- test-add $reptime
- test-convert [expr {$reptime / 2}]; #fast enough
- test-other $reptime
-
- puts \n**OK**
-}
-
-}; # end of ::tclTestPerf-TclClock
-
-# ------------------------------------------------------------------------
-
-# if calling direct:
-if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
- ::tclTestPerf-TclClock::test $in(-time)
-}
diff --git a/tests-perf/comparePerf.tcl b/tests-perf/comparePerf.tcl
deleted file mode 100644
index f35da21..0000000
--- a/tests-perf/comparePerf.tcl
+++ /dev/null
@@ -1,371 +0,0 @@
-#!/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/list.perf.tcl b/tests-perf/list.perf.tcl
deleted file mode 100644
index 9fde335..0000000
--- a/tests-perf/list.perf.tcl
+++ /dev/null
@@ -1,99 +0,0 @@
-#!/usr/bin/tclsh
-
-# ------------------------------------------------------------------------
-#
-# list.perf.tcl --
-#
-# This file provides performance tests for comparison of tcl-speed
-# of list facilities.
-#
-# ------------------------------------------------------------------------
-#
-# Copyright (c) 2024 Serg G. Brester (aka sebres)
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
-
-
-if {![namespace exists ::tclTestPerf]} {
- source [file join [file dirname [info script]] test-performance.tcl]
-}
-
-
-namespace eval ::tclTestPerf-List {
-
-namespace path {::tclTestPerf}
-
-proc test-lsearch-regress {{reptime 1000}} {
- _test_run -no-result $reptime {
- # list with 5000 strings with ca. 50 chars elements:
- setup { set str [join [lrepeat 13 "XXX"] /]; set l [lrepeat 5000 $str]; llength $l }
- # lsearch with no option, found immediatelly :
- { lsearch $l $str }
- # lsearch with -glob, found immediatelly :
- { lsearch -glob $l $str }
- # lsearch with -exact, found immediatelly :
- { lsearch -exact $l $str }
- # lsearch with -dictionary, found immediatelly :
- { lsearch -dictionary $l $str }
-
- # lsearch with -nocase only, found immediatelly :
- { lsearch -nocase $l $str }
- # lsearch with -nocase -glob, found immediatelly :
- { lsearch -nocase -glob $l $str }
- # lsearch with -nocase -exact, found immediatelly :
- { lsearch -nocase -exact $l $str }
- # lsearch with -nocase -dictionary, found immediatelly :
- { lsearch -nocase -dictionary $l $str }
- }
-}
-
-proc test-lsearch-nf-regress {{reptime 1000}} {
- _test_run -no-result $reptime {
- # list with 5000 strings with ca. 50 chars elements:
- setup { set str [join [lrepeat 13 "XXX"] /]; set sNF $str/NF; set l [lrepeat 5000 $str]; llength $l }
- # lsearch with no option, not found:
- { lsearch $l $sNF }
- # lsearch with -glob, not found:
- { lsearch -glob $l $sNF }
- # lsearch with -exact, not found:
- { lsearch -exact $l $sNF }
- # lsearch with -dictionary, not found:
- { lsearch -dictionary $l $sNF }
- }
-}
-
-proc test-lsearch-nc-nf-regress {{reptime 1000}} {
- _test_run -no-result $reptime {
- # list with 5000 strings with ca. 50 chars elements:
- setup { set str [join [lrepeat 13 "XXX"] /]; set sNF $str/NF; set l [lrepeat 5000 $str]; llength $l }
- # lsearch with -nocase only, not found:
- { lsearch -nocase $l $sNF }
- # lsearch with -nocase -glob, not found:
- { lsearch -nocase -glob $l $sNF }
- # lsearch with -nocase -exact, not found:
- { lsearch -nocase -exact $l $sNF }
- # lsearch with -nocase -dictionary, not found:
- { lsearch -nocase -dictionary $l $sNF }
- }
-}
-
-proc test {{reptime 1000}} {
- test-lsearch-regress $reptime
- test-lsearch-nf-regress $reptime
- test-lsearch-nc-nf-regress $reptime
-
- puts \n**OK**
-}
-
-}; # end of ::tclTestPerf-List
-
-# ------------------------------------------------------------------------
-
-# if calling direct:
-if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
- array set in {-time 500}
- array set in $argv
- ::tclTestPerf-List::test $in(-time)
-}
diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl
deleted file mode 100644
index 575c78e..0000000
--- a/tests-perf/listPerf.tcl
+++ /dev/null
@@ -1,1295 +0,0 @@
-#!/usr/bin/tclsh
-# ------------------------------------------------------------------------
-#
-# listPerf.tcl --
-#
-# This file provides performance tests for list operations. Run
-# tclsh listPerf.tcl help
-# for options.
-# ------------------------------------------------------------------------
-#
-# 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
- }
- --* {
- puts stderr "Unknown option $arg"
- print_usage
- exit 1
- }
- 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
-
- ListPerf create perf -overhead {set L {}} -time 1000
-
- # Note: Const indices take different path through bytecode than variable
- # indices hence separate cases below
-
-
- # Var case
- foreach share_mode {shared unshared} {
- set idx 0
- if {$share_mode eq "shared"} {
- comment == Insert into empty lists
- comment Insert one element into empty list
- measure [linsert_describe shared 0 "0 (var)" 1 1] {linsert $L $idx ""} -setup {set idx 0; set L {}}
- } else {
- comment == Insert into empty lists
- comment Insert one element into empty list
- measure [linsert_describe unshared 0 "0 (var)" 1 1] {linsert {} $idx ""} -setup {set idx 0}
- }
- foreach idx_str [list 0 1 mid end-1 end] {
- foreach len $Lengths {
- if {$idx_str eq "mid"} {
- set idx [expr {$len/2}]
- } else {
- set idx $idx_str
- }
- # perf option -reps $reps
- set reps 1000
- if {$share_mode eq "shared"} {
- 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 {} -reps 100000
-
- 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] -reps $reps
-
- 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] -reps $reps
- } else {
- # 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
- 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] -reps $reps
- 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] -reps $reps
- }
- }
- }
- }
-
- # Const index
- foreach share_mode {shared unshared} {
- if {$share_mode eq "shared"} {
- comment == Insert into empty lists
- comment Insert one element into empty list
- measure [linsert_describe shared 0 "0 (const)" 1 1] {linsert $L 0 ""} -setup {set L {}}
- } else {
- comment == Insert into empty lists
- comment Insert one element into empty list
- measure [linsert_describe unshared 0 "0 (const)" 1 1] {linsert {} 0 ""}
- }
- foreach idx_str [list 0 1 mid end end-1] {
- foreach len $Lengths {
- # Note end, end-1 explicitly calculated as otherwise they
- # are not treated as const
- if {$idx_str eq "mid"} {
- set idx [expr {$len/2}]
- } elseif {$idx_str eq "end"} {
- set idx [expr {$len-1}]
- } elseif {$idx_str eq "end-1"} {
- set idx [expr {$len-2}]
- } else {
- set idx $idx_str
- }
- #perf option -reps $reps
- set reps 100
- if {$share_mode eq "shared"} {
- 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 {} -reps 10000
-
- 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] -reps $reps
-
- 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] -reps $reps
- } else {
- 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] -reps $reps
-
- 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] -reps $reps
- }
- }
- }
- }
-
- # Note: no span tests because the inserts above will themselves create
- # spanned lists
-
- perf destroy
- }
-
- proc list_describe {len text} {
- return "list L\[$len\] $text"
- }
- proc list_perf {} {
- variable Lengths
-
- print_separator list
-
- ListPerf create perf
- foreach len $Lengths {
- set s [join [lrepeat $len x]]
- comment Create a list from a string
- perf measure [list_describe $len "from a string"] {list $s} [list s $s len $len]
- }
- foreach len $Lengths {
- comment Create a list from expansion - single list (special optimal case)
- perf measure [list_describe $len "from a {*}list"] {list {*}$L} [list len $len]
- comment Create a list from two lists - real test of expansion speed
- perf measure [list_describe $len "from a {*}list {*}list"] {list {*}$L {*}$L} [list len [expr {$len/2}]]
- }
-
- 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 share_mode {shared unshared} {
- foreach len $Lengths {
- if {$share_mode eq "shared"} {
- 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
-
- 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
- } else {
- 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
- }
- }
- }
- 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 share_mode {shared unshared} {
- foreach len $Lengths {
- if {$share_mode eq "shared"} {
- comment Reverse a shared list
- perf measure [lreverse_describe shared $len] {
- lreverse $L
- } [list len $len]
-
- if {$len > 100} {
- comment Reverse a shared-span list
- perf measure [lreverse_describe shared-span $len] {
- lreverse $Lspan
- } [list len $len]
- }
- } else {
- 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 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 split_describe {len} {
- return "split L\[$len\]"
- }
- proc split_perf {} {
- variable Lengths
- print_separator split
-
- ListPerf create perf -setup {set S [string repeat "x " $len]}
- foreach len $Lengths {
- comment Split a string
- perf measure [split_describe $len] {
- split $S " "
- } [list len $len]
- }
- }
-
- 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 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 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 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
- exit 0
- }
- 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
-}
diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl
deleted file mode 100644
index d360426..0000000
--- a/tests-perf/test-performance.tcl
+++ /dev/null
@@ -1,199 +0,0 @@
-# ------------------------------------------------------------------------
-#
-# test-performance.tcl --
-#
-# This file provides common performance tests for comparison of tcl-speed
-# degradation or regression by switching between branches.
-#
-# To execute test case evaluate direct corresponding file "tests-perf\*.perf.tcl".
-#
-# ------------------------------------------------------------------------
-#
-# Copyright © 2014 Serg G. Brester (aka sebres)
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
-
-namespace eval ::tclTestPerf {
-# warm-up interpreter compiler env, calibrate timerate measurement functionality:
-
-# if no timerate here - import from unsupported:
-if {[namespace which -command timerate] eq {}} {
- namespace inscope ::tcl::unsupported {namespace export timerate}
- namespace import ::tcl::unsupported::timerate
-}
-
-# if not yet calibrated:
-if {[lindex [timerate {} 10] 6] >= (10-1)} {
- puts -nonewline "Calibration ... "; flush stdout
- puts "done: [lrange \
- [timerate -calibrate {}] \
- 0 1]"
-}
-
-proc {**STOP**} {args} {
- return -code error -level 4 "**STOP** in [info level [expr {[info level]-2}]] [join $args { }]"
-}
-
-proc _test_get_commands {lst} {
- regsub -all {(?:^|\n)[ \t]*(\#[^\n]*|\msetup\M[^\n]*|\mcleanup\M[^\n]*)(?=\n\s*(?:[\{\#]|setup|cleanup|$))} $lst "\n{\\1}"
-}
-
-proc _test_out_total {} {
- upvar _ _
-
- set tcnt [llength $_(itm)]
- if {!$tcnt} {
- puts ""
- return
- }
-
- set mintm 0x7FFFFFFF
- set maxtm 0
- set nettm 0
- set wtm 0
- set wcnt 0
- set i 0
- foreach tm $_(itm) {
- if {[llength $tm] > 6} {
- set nettm [expr {$nettm + [lindex $tm 6]}]
- }
- set wtm [expr {$wtm + [lindex $tm 0]}]
- set wcnt [expr {$wcnt + [lindex $tm 2]}]
- set tm [lindex $tm 0]
- if {$tm > $maxtm} {set maxtm $tm; set maxi $i}
- if {$tm < $mintm} {set mintm $tm; set mini $i}
- incr i
- }
-
- puts [string repeat ** 40]
- set s [format "%d cases in %.2f sec." $tcnt [expr {([clock milliseconds] - $_(starttime)) / 1000.0}]]
- if {$nettm > 0} {
- append s [format " (%.2f net-sec.)" [expr {$nettm / 1000.0}]]
- }
- puts "Total $s:"
- lset _(m) 0 [format %.6f $wtm]
- lset _(m) 2 $wcnt
- lset _(m) 4 [format %.3f [expr {$wcnt / (($nettm ? $nettm : ($tcnt * [lindex $_(reptime) 0])) / 1000.0)}]]
- if {[llength $_(m)] > 6} {
- lset _(m) 6 [format %.3f $nettm]
- }
- puts $_(m)
- puts "Average:"
- lset _(m) 0 [format %.6f [expr {[lindex $_(m) 0] / $tcnt}]]
- lset _(m) 2 [expr {[lindex $_(m) 2] / $tcnt}]
- if {[llength $_(m)] > 6} {
- lset _(m) 6 [format %.3f [expr {[lindex $_(m) 6] / $tcnt}]]
- lset _(m) 4 [format %.0f [expr {[lindex $_(m) 2] / [lindex $_(m) 6] * 1000}]]
- }
- puts $_(m)
- puts "Min:"
- puts [lindex $_(itm) $mini]
- puts "Max:"
- puts [lindex $_(itm) $maxi]
- puts [string repeat ** 40]
- puts ""
- unset -nocomplain _(itm) _(starttime)
-}
-
-proc _test_start {reptime} {
- upvar _ _
- array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 0]
-}
-
-proc _test_iter {args} {
- if {[llength $args] > 2} {
- return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?level? measure-result\""
- }
- set lvl 1
- if {[llength $args] > 1} {
- set args [lassign $args lvl]
- }
- upvar $lvl _ _
- puts [set _(m) {*}$args]
- lappend _(itm) $_(m)
- puts ""
-}
-
-proc _adjust_maxcount {reptime maxcount} {
- if {[llength $reptime] > 1} {
- lreplace $reptime 1 1 [expr {min($maxcount,[lindex $reptime 1])}]
- } else {
- lappend reptime $maxcount
- }
-}
-
-proc _test_run {args} {
- upvar _ _
- # parse args:
- array set _ {-no-result 0 -uplevel 0 -convert-result {}}
- while {[llength $args] > 2} {
- if {![info exists _([set o [lindex $args 0]])]} {
- break
- }
- if {[string is boolean -strict $_($o)]} {
- set _($o) [expr {! $_($o)}]
- set args [lrange $args 1 end]
- } else {
- if {[llength $args] <= 2} {
- return -code error "value expected for option $o"
- }
- set _($o) [lindex $args 1]
- set args [lrange $args 2 end]
- }
- }
- unset -nocomplain o
- if {[llength $args] < 2 || [llength $args] > 3} {
- return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\""
- }
- set _(outcmd) {puts}
- set args [lassign $args reptime lst]
- if {[llength $args]} {
- set _(outcmd) [lindex $args 0]
- }
- # avoid output if only once:
- if {[lindex $reptime 0] <= 1 || ([llength $reptime] > 1 && [lindex $reptime 1] == 1)} {
- set _(-no-result) 1
- }
- if {![info exists _(itm)]} {
- array set _ [list itm {} reptime $reptime starttime [clock milliseconds] -from-run 1]
- } else {
- array set _ [list reptime $reptime]
- }
-
- # process measurement:
- foreach _(c) [_test_get_commands $lst] {
- {*}$_(outcmd) "% [regsub -all {\n[ \t]*} $_(c) {; }]"
- if {[regexp {^\s*\#} $_(c)]} continue
- if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
- set _(c) [lindex $_(c) 1]
- if {$_(-uplevel)} {
- set _(c) [list uplevel 1 $_(c)]
- }
- {*}$_(outcmd) [if 1 $_(c)]
- continue
- }
- if {$_(-uplevel)} {
- set _(c) [list uplevel 1 $_(c)]
- }
- set _(ittime) $_(reptime)
- # if output result (and not once):
- if {!$_(-no-result)} {
- set _(r) [if 1 $_(c)]
- if {$_(-convert-result) ne ""} { set _(r) [if 1 $_(-convert-result)] }
- {*}$_(outcmd) $_(r)
- if {[llength $_(ittime)] > 1} { # decrement max-count
- lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}]
- }
- }
- {*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]]
- lappend _(itm) $_(m)
- {*}$_(outcmd) ""
- }
- if {$_(-from-run)} {
- _test_out_total
- }
-}
-
-}; # end of namespace ::tclTestPerf
diff --git a/tests-perf/timer-event.perf.tcl b/tests-perf/timer-event.perf.tcl
deleted file mode 100644
index 5d1d3c6..0000000
--- a/tests-perf/timer-event.perf.tcl
+++ /dev/null
@@ -1,182 +0,0 @@
-#!/usr/bin/tclsh
-
-# ------------------------------------------------------------------------
-#
-# timer-event.perf.tcl --
-#
-# This file provides performance tests for comparison of tcl-speed
-# of timer events (event-driven tcl-handling).
-#
-# ------------------------------------------------------------------------
-#
-# Copyright © 2014 Serg G. Brester (aka sebres)
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file.
-#
-
-
-if {![namespace exists ::tclTestPerf]} {
- source [file join [file dirname [info script]] test-performance.tcl]
-}
-
-
-namespace eval ::tclTestPerf-Timer-Event {
-
-namespace path {::tclTestPerf}
-
-proc test-queue {{reptime {1000 10000}}} {
-
- set howmuch [lindex $reptime 1]
-
- # because of extremely short measurement times by tests below, wait a little bit (warming-up),
- # to minimize influence of the time-gradation (just for better dispersion resp. result-comparison)
- timerate {after 0} 156
-
- puts "*** up to $howmuch events ***"
- # single iteration by update, so using -no-result (measure only):
- _test_run -no-result $reptime [string map [list \{*\}\$reptime $reptime \$howmuch $howmuch \\# \#] {
- # generate up to $howmuch idle-events:
- {after idle {set foo bar}}
- # update / after idle:
- {update; if {![llength [after info]]} break}
-
- # generate up to $howmuch idle-events:
- {after idle {set foo bar}}
- # update idletasks / after idle:
- {update idletasks; if {![llength [after info]]} break}
-
- # generate up to $howmuch immediate events:
- {after 0 {set foo bar}}
- # update / after 0:
- {update; if {![llength [after info]]} break}
-
- # generate up to $howmuch 1-ms events:
- {after 1 {set foo bar}}
- setup {after 1}
- # update / after 1:
- {update; if {![llength [after info]]} break}
-
- # generate up to $howmuch immediate events (+ 1 event of the second generation):
- {after 0 {after 0 {}}}
- # update / after 0 (double generation):
- {update; if {![llength [after info]]} break}
-
- # cancel forwards "after idle" / $howmuch idle-events in queue:
- setup {set i 0; timerate {set ev([incr i]) [after idle {set foo bar}]} {*}$reptime}
- setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events}
- {after cancel $ev([incr i]); if {$i >= $le} break}
- cleanup {update; unset -nocomplain ev}
- # cancel backwards "after idle" / $howmuch idle-events in queue:
- setup {set i 0; timerate {set ev([incr i]) [after idle {set foo bar}]} {*}$reptime}
- setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events}
- {after cancel $ev([incr i -1]); if {$i <= 1} break}
- cleanup {update; unset -nocomplain ev}
-
- # cancel forwards "after 0" / $howmuch timer-events in queue:
- setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
- setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events}
- {after cancel $ev([incr i]); if {$i >= $le} break}
- cleanup {update; unset -nocomplain ev}
- # cancel backwards "after 0" / $howmuch timer-events in queue:
- setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
- setup {set le $i; incr i; list $le .. 1; # cancel up to $howmuch events}
- {after cancel $ev([incr i -1]); if {$i <= 1} break}
- cleanup {update; unset -nocomplain ev}
-
- # end $howmuch events.
- cleanup {if [llength [after info]] {error "unexpected: [llength [after info]] events are still there."}}
- }]
-}
-
-proc test-access {{reptime {1000 5000}}} {
- set howmuch [lindex $reptime 1]
-
- _test_run $reptime [string map [list \{*\}\$reptime $reptime \$howmuch $howmuch] {
- # event random access: after idle + after info (by $howmuch events)
- setup {set i -1; timerate {set ev([incr i]) [after idle {}]} {*}$reptime}
- {after info $ev([expr {int(rand()*$i)}])}
- cleanup {update; unset -nocomplain ev}
- # event random access: after 0 + after info (by $howmuch events)
- setup {set i -1; timerate {set ev([incr i]) [after 0 {}]} {*}$reptime}
- {after info $ev([expr {int(rand()*$i)}])}
- cleanup {update; unset -nocomplain ev}
-
- # end $howmuch events.
- cleanup {if [llength [after info]] {error "unexpected: [llength [after info]] events are still there."}}
- }]
-}
-
-proc test-exec {{reptime 1000}} {
- _test_run $reptime {
- # after idle + after cancel
- {after cancel [after idle {set foo bar}]}
- # after 0 + after cancel
- {after cancel [after 0 {set foo bar}]}
- # after idle + update idletasks
- {after idle {set foo bar}; update idletasks}
- # after idle + update
- {after idle {set foo bar}; update}
- # immediate: after 0 + update
- {after 0 {set foo bar}; update}
- # delayed: after 1 + update
- {after 1 {set foo bar}; update}
- # empty update:
- {update}
- # empty update idle tasks:
- {update idletasks}
-
- # simple shortest sleep:
- {after 0}
- }
-}
-
-proc test-nrt-capability {{reptime 1000}} {
- _test_run $reptime {
- # comparison values:
- {after 0 {set a 5}; update}
- {after 0 {set a 5}; vwait a}
-
- # conditional vwait with very brief wait-time:
- {after 1 {set a timeout}; vwait a; expr {$::a ne "timeout" ? 1 : "0[unset ::a]"}}
- {after 0 {set a timeout}; vwait a; expr {$::a ne "timeout" ? 1 : "0[unset ::a]"}}
- }
-}
-
-proc test-long {{reptime 1000}} {
- _test_run $reptime {
- # in-between important event by amount of idle events:
- {time {after idle {after 30}} 10; after 1 {set important 1}; vwait important;}
- cleanup {foreach i [after info] {after cancel $i}}
- # in-between important event (of new generation) by amount of idle events:
- {time {after idle {after 30}} 10; after 1 {after 0 {set important 1}}; vwait important;}
- cleanup {foreach i [after info] {after cancel $i}}
- }
-}
-
-proc test {{reptime 1000}} {
- test-exec $reptime
- foreach howmuch {5000 50000} {
- test-access [list $reptime $howmuch]
- }
- test-nrt-capability $reptime
- test-long $reptime
-
- puts ""
- foreach howmuch { 10000 20000 40000 60000 } {
- test-queue [list $reptime $howmuch]
- }
-
- puts \n**OK**
-}
-
-}; # end of ::tclTestPerf-Timer-Event
-
-# ------------------------------------------------------------------------
-
-# if calling direct:
-if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} {
- array set in {-time 500}
- array set in $argv
- ::tclTestPerf-Timer-Event::test $in(-time)
-}
generated by cgit v0.12 at 2025-12-20 11:47:08 (GMT)