added performance test-cases to cover timer-events speed resp. event-driven tcl-handling

(cherry-picked and back-ported from tclSE-9)

2 files changed, 270 insertions, 0 deletions

diff --git a/tests-perf/test-performance.tcl b/tests-perf/test-performance.tcl
new file mode 100644
index 0000000..b0cbb17
--- /dev/null
+++ b/tests-perf/test-performance.tcl
@@ -0,0 +1,121 @@
+# ------------------------------------------------------------------------
+#
+# 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 (c) 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 interpeter 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 nett 0
+  set wtm 0
+  set wcnt 0
+  set i 0
+  foreach tm $_(itm) {
+    if {[llength $tm] > 6} {
+      set nett [expr {$nett + [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 {$nett > 0} {
+    append s [format " (%.2f nett-sec.)" [expr {$nett / 1000.0}]]
+  }
+  puts "Total $s:"
+  lset _(m) 0 [format %.6f $wtm]
+  lset _(m) 2 $wcnt
+  lset _(m) 4 [format %.3f [expr {$wcnt / (($nett ? $nett : ($tcnt * $_(reptime))) / 1000.0)}]]
+  if {[llength $_(m)] > 6} {
+    lset _(m) 6 [format %.3f $nett]
+  }
+  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 ""
+}
+
+proc _test_run {reptime lst {outcmd {puts $_(r)}}} {
+  upvar _ _
+  array set _ [list itm {} reptime $reptime starttime [clock milliseconds]]
+
+  foreach _(c) [_test_get_commands $lst] {
+    puts "% [regsub -all {\n[ \t]*} $_(c) {; }]"
+    if {[regexp {^\s*\#} $_(c)]} continue
+    if {[regexp {^\s*(?:setup|cleanup)\s+} $_(c)]} {
+      puts [if 1 [lindex $_(c) 1]]
+      continue
+    }
+    if {$reptime > 1} {; #if not once:
+      set _(r) [if 1 $_(c)]
+      if {$outcmd ne {}} $outcmd
+    }
+    puts [set _(m) [timerate $_(c) $reptime]]
+    lappend _(itm) $_(m)
+    puts ""
+  }
+  _test_out_total
+}
+
+}; # end of namespace ::tclTestPerf
diff --git a/tests-perf/timer-event.perf.tcl b/tests-perf/timer-event.perf.tcl
new file mode 100644
index 0000000..fdca695
--- /dev/null
+++ b/tests-perf/timer-event.perf.tcl
@@ -0,0 +1,149 @@
+#!/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 (c) 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 {howmuch} {
+
+  # 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 "*** $howmuch events ***"
+  _test_run 0 [string map [list \$howmuch $howmuch \\# \#] {
+    # update / after idle:
+    setup {puts [time {after idle {set foo bar}} $howmuch]}
+    {update; \# $howmuch idle-events}
+    # update idletasks / after idle:
+    setup {puts [time {after idle {set foo bar}} $howmuch]}
+    {update idletasks; \# $howmuch idle-events}
+
+    # update / after 0:
+    setup {puts [time {after 0 {set foo bar}} $howmuch]}
+    {update; \# $howmuch timer-events}
+    # update / after 1:
+    setup {puts [time {after 1 {set foo bar}} $howmuch]; after 1}
+    {update; \# $howmuch timer-events}
+
+    # cancel forwards "after idle" / $howmuch idle-events in queue:
+    setup {set i 0; time {set ev([incr i]) [after idle {set foo bar}]} $howmuch}
+    {set i 0; time {after cancel $ev([incr i])} $howmuch}
+    cleanup {update}
+    # cancel backwards "after idle" / $howmuch idle-events in queue:
+    setup {set i 0; time {set ev([incr i]) [after idle {set foo bar}]} $howmuch}
+    {incr i; time {after cancel $ev([incr i -1])} $howmuch}
+    cleanup {update}
+
+    # cancel forwards "after 0" / $howmuch timer-events in queue:
+    setup {set i 0; time {set ev([incr i]) [after 0 {set foo bar}]} $howmuch}
+    {set i 0; time {after cancel $ev([incr i])} $howmuch}
+    cleanup {update}
+    # cancel backwards "after 0" / $howmuch timer-events in queue:
+    setup {set i 0; time {set ev([incr i]) [after 0 {set foo bar}]} $howmuch}
+    {incr i; time {after cancel $ev([incr i -1])} $howmuch}
+    cleanup {update}
+    # end $howmuch events.
+  }]
+}
+
+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}
+  }
+}
+
+proc test-exec-new {{reptime 1000}} {
+  _test_run $reptime {
+    # conditional update pure idle only (without window):
+    {update -idle}
+    # conditional update without idle events:
+    {update -noidle}
+    # conditional update timers only:
+    {update -timer}
+    # conditional update AIO only:
+    {update -async}
+
+    # conditional vwait with zero timeout: pure idle only (without window):
+    {vwait -idle 0 x}
+    # conditional vwait with zero timeout: without idle events:
+    {vwait -noidle 0 x}
+    # conditional vwait with zero timeout: timers only:
+    {vwait -timer 0 x}
+    # conditional vwait with zero timeout: AIO only:
+    {vwait -async 0 x}
+  }
+}
+
+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
+  if {![catch {update -noidle}]} {
+    test-exec-new $reptime
+  }
+  test-long $reptime
+
+  puts ""
+  foreach howmuch { 10000 20000 40000 60000 } {
+    test-queue $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)
+}