Tcl Source Code

Check-in [1e109808c9]
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:extended performance test-suite, since max-count is implemented in timerate, usage `::tclTestPerf::_test_run ?-no-result? reptime lst ?outcmd?`; update timer-event.perf.tcl for better readability (covering execution in multiple iterations now regarding max-count, so provides more precise result now); removed unused test-cases here (new cases of event-perf-branch only).
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | sebres-8-5-timerate
Files: files | file ages | folders
SHA3-256: 1e109808c9053b8eb7089f6d65ad38803944eb03a0500b7991af8e4a568561d3
User & Date: sebres 2019-03-05 15:46:31.875
Context
2019-03-08
04:05
merge sebres-8-5-timerate (prepare for consolidation with 8.5) check-in: ca89c4e5a7 user: sebres tags: sebres-8-5-event-perf-branch
2019-03-05
16:25
merge sebres-8-5-timerate (TIP#527 - New measurement facilities in TCL: New command timerate, perfor... check-in: 5c26638643 user: sebres tags: core-8-5-branch
16:13
merge updated 8.5-timerate branch Closed-Leaf check-in: 5246d61897 user: sebres tags: sebres-8-6-timerate
15:46
extended performance test-suite, since max-count is implemented in timerate, usage `::tclTestPerf::_... Closed-Leaf check-in: 1e109808c9 user: sebres tags: sebres-8-5-timerate
12:58
back-porting other performance test (timer-event.perf.tcl) from event-perf-branch check-in: c3a401ee2c user: sebres tags: sebres-8-5-timerate
Changes
Unified Diff Ignore Whitespace Patch
Changes to tests-perf/test-performance.tcl.
︙︙
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100


















101
102

103
104
105
106
107
108
109

110
111
112


113

114
115
116
117
118
119
120
121

  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








|




















|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>







>
|


>
>
|
>
|








71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

  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 * [lindex $_(reptime) 0])) / 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 {args} {
  upvar _ _
  # parse args:
  set _(out-result) 1
  if {[lindex $args 0] eq "-no-result"} {
    set _(out-result) 0
    set args [lrange $args 1 end]
  }
  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 $_(r)}
  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 _(out-result) 0
  }
  array set _ [list itm {} reptime $reptime starttime [clock milliseconds]]

  # process measurement:
  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 output result (and not once):
    if {$_(out-result)} {
      set _(r) [if 1 $_(c)]
      if {$outcmd ne {}} $outcmd
      if {[llength $_(reptime)] > 1} { # decrement max-count
        lset _(reptime) 1 [expr {[lindex $_(reptime) 1] - 1}]
      }
    }
    puts [set _(m) [timerate $_(c) {*}$_(reptime)]]
    lappend _(itm) $_(m)
    puts ""
  }
  _test_out_total
}

}; # end of namespace ::tclTestPerf
Changes to tests-perf/timer-event.perf.tcl.
︙︙
21
22
23
24
25
26
27
28


29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

65
66
67
68

69
70
71
72
73

74
75
76
77

78
79

80

81
82
83
84

85
86
87
88
89
90
91
92
93
94
95


96
97
98
99
100
101
102
103

}


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 \\# \#] {

    # generate $howmuch idle-events:
    {time {after idle {set foo bar}} $howmuch; llength [after info]}
    # update / after idle:
    {update; \# $howmuch idle-events}
    
    # generate $howmuch idle-events:
    {time {after idle {set foo bar}} $howmuch; llength [after info]}
    # update idletasks / after idle:
    {update idletasks; \# $howmuch idle-events}

    # generate $howmuch immediate events:
    {time {after 0 {set foo bar}} $howmuch; llength [after info]}
    # update / after 0:
    {update; \# $howmuch timer-events}
    
    # generate $howmuch 1-ms events:
    {time {after 1 {set foo bar}} $howmuch; llength [after info]}
    setup {after 1}
    # update / after 1:
    {update; \# $howmuch timer-events}

    # generate $howmuch immediate events (+ 1 event of the second generation):
    {time {after 0 {after 0 {}}} $howmuch; llength [after info]}
    # update / after 0 (double generation):
    {while {1} {update; if {![llength [after info]]} break }; \# all generations of 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; unset -nocomplain ev}
    # 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; unset -nocomplain ev}

    # 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; unset -nocomplain ev}
    # 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; unset -nocomplain ev}

    # end $howmuch events.

  }]
}

proc test-access {{reptime 1000}} {

  foreach count {5000 50000} {
  _test_run $reptime [string map [list \$count $count] {
    # event random access: after idle + after info (by $count events)
    setup {set i -1; time {set ev([incr i]) [after idle {}]} $count; array size ev }
    {after info $ev([expr {int(rand()*$count)}])}
    cleanup {update; unset -nocomplain ev}
    # event random access: after 0 + after info (by $count events)
    setup {set i -1; time {set ev([incr i]) [after 0 {}]} $count; array size ev}
    {after info $ev([expr {int(rand()*$count)}])}
    cleanup {update; unset -nocomplain ev}
  }]


  }
}

proc test-exec {{reptime 1000}} {
  _test_run $reptime {
    # after idle + after cancel
    {after cancel [after idle {set foo bar}]}
    # after 0 + after cancel








|
>
>





|
|
|
|
|

|

|
|

|

|
|

|

|
|


|

|
|

|


|
>
|


|
>
|



|
>
|


|
>
|

>

>



|
>
|
|
|
|
|

|
|
|

|
>
>
|








21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114

}


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 >= $howmuch} 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
︙︙
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194

195
196
197
198
199

200
201
202
203
204
205
206
207
208
209
210
211

    {update idletasks}

    # simple shortest sleep:
    {after 0}
  }
}

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-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:
    {vwait 1 a}
    {vwait 0.5 a}
    {vwait 0.2 a}
    {vwait 0.1 a}
    {vwait 0.05 a}
    {vwait 0.02 a}
    {vwait 0.01 a}
    {vwait 0.005 a}
    {vwait 0.001 a}

    # NRT sleep / very brief delays (0.5 - 0.005):
    {after 0.5}
    {after 0.05}
    {after 0.005}
    # NRT sleep / very brief delays (0.1 - 0.001):
    {after 0.1}
    {after 0.01}
    {after 0.001}

    # comparison of update's executing event:
    {after idle {set a 5}; update -idle -timer}
    {after 0 {set a 5}; update -idle -timer}
    {after idle {set a 5}; update -idle}
    # comparison of vwait's executing event:
    {after idle {set a 5}; vwait -idle -timer a}
    {after 0 {set a 5}; vwait -idle -timer a}
    {after idle {set a 5}; vwait -idle 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

  test-access $reptime
  if {![catch {update -noidle}]} {
    test-exec-new $reptime
    test-nrt-capability $reptime
  }

  test-long $reptime

  puts ""
  foreach howmuch { 10000 20000 40000 60000 } {
    test-queue $howmuch
  }

  puts \n**OK**
}

}; # end of ::tclTestPerf-Timer-Event









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
















>
|
<
<
<

>




|








127
128
129
130
131
132
133






















134
135
136
137
138
139
140









141








142








143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160



161
162
163
164
165
166
167
168
169
170
171
172
173
174

    {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
︙︙
This page was generated in about 0.017s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32