Prevent static analysers from thinking that variable fn might be used whilst null
[jimtcl.git] / bench.tcl
blobf39bef1f3b72babf97d984daea3a32cefb14f7be
1 set batchmode 0
2 set benchmarks {}
4 proc bench {title script} {
5 global benchmarks batchmode
7 set Title [string range "$title " 0 20]
9 set failed [catch {time $script} res]
10 if {$failed} {
11 if {!$batchmode} {puts "$Title - This test can't run on this interpreter ($res)"}
12 lappend benchmarks $title F
13 } else {
14 set t [expr [lindex $res 0] / 1000]
15 lappend benchmarks $title $t
16 set ts " $t"
17 set ts [string range $ts [expr {[string length $ts]-10}] end]
18 if {!$batchmode} {puts "$Title -$ts ms per iteration"}
20 catch { collect }
23 ### BUSY LOOP ##################################################################
25 proc whilebusyloop {} {
26 set i 0
27 while {$i < 1850000} {
28 set a 2
29 incr i
33 proc forbusyloop {} {
34 for {set i 0} {$i < 1850000} {incr i} {
35 set a 2
39 ### FIBONACCI ##################################################################
41 proc fibonacci {x} {
42 if {$x <= 1} {
43 expr 1
44 } else {
45 expr {[fibonacci [expr {$x-1}]] + [fibonacci [expr {$x-2}]]}
49 ### HEAPSORT ###################################################################
51 set IM 139968
52 set IA 3877
53 set IC 29573
55 set last 42
57 proc make_gen_random {} {
58 global IM IA IC
59 set params [list IM $IM IA $IA IC $IC]
60 set body [string map $params {
61 global last
62 expr {($max * [set last [expr {($last * IA + IC) % IM}]]) / IM}
64 proc gen_random {max} $body
67 proc heapsort {ra_name} {
68 upvar 1 $ra_name ra
69 set n [llength $ra]
70 set l [expr {$n / 2}]
71 set ir [expr {$n - 1}]
72 while 1 {
73 if {$l} {
74 set rra [lindex $ra [incr l -1]]
75 } else {
76 set rra [lindex $ra $ir]
77 lset ra $ir [lindex $ra 0]
78 if {[incr ir -1] == 0} {
79 lset ra 0 $rra
80 break
83 set i $l
84 set j [expr {(2 * $l) + 1}]
85 while {$j <= $ir} {
86 set tmp [lindex $ra $j]
87 if {$j < $ir} {
88 if {$tmp < [lindex $ra [expr {$j + 1}]]} {
89 set tmp [lindex $ra [incr j]]
92 if {$rra >= $tmp} {
93 break
95 lset ra $i $tmp
96 incr j [set i $j]
98 lset ra $i $rra
102 proc heapsort_main {} {
103 set n 6100
104 make_gen_random
106 set data {}
107 for {set i 1} {$i <= $n} {incr i} {
108 lappend data [gen_random 1.0]
110 heapsort data
113 ### SIEVE ######################################################################
115 proc sieve {num} {
116 while {$num > 0} {
117 incr num -1
118 set count 0
119 for {set i 2} {$i <= 8192} {incr i} {
120 set flags($i) 1
122 for {set i 2} {$i <= 8192} {incr i} {
123 if {$flags($i) == 1} {
124 # remove all multiples of prime: i
125 for {set k [expr {$i+$i}]} {$k <= 8192} {incr k $i} {
126 set flags($k) 0
128 incr count
132 return $count
135 proc sieve_dict {num} {
136 while {$num > 0} {
137 incr num -1
138 set count 0
139 for {set i 2} {$i <= 8192} {incr i} {
140 dict set flags $i 1
142 for {set i 2} {$i <= 8192} {incr i} {
143 if {[dict get $flags $i] == 1} {
144 # remove all multiples of prime: i
145 for {set k [expr {$i+$i}]} {$k <= 8192} {incr k $i} {
146 dict set flags $k 0
148 incr count
152 return $count
155 ### ARY ########################################################################
157 proc ary n {
158 for {set i 0} {$i < $n} {incr i} {
159 set x($i) $i
161 set last [expr {$n - 1}]
162 for {set j $last} {$j >= 0} {incr j -1} {
163 set y($j) $x($j)
167 proc ary_dict n {
168 for {set i 0} {$i < $n} {incr i} {
169 dict set x $i $i
171 set last [expr {$n - 1}]
172 for {set j $last} {$j >= 0} {incr j -1} {
173 dict set y $j $x($j)
177 proc ary_static n {
178 for {set i 0} {$i < $n} {incr i} {
179 set a(b) $i
180 set a(c) $i
184 ### REPEAT #####################################################################
186 proc repeat {n body} {
187 for {set i 0} {$i < $n} {incr i} {
188 uplevel 1 $body
192 proc use_repeat {} {
193 set x 0
194 repeat {1000000} {incr x}
197 ### UPVAR ######################################################################
199 proc myincr varname {
200 upvar 1 $varname x
201 incr x
204 proc upvartest {} {
205 set y 0
206 for {set x 0} {$x < 100000} {myincr x} {
207 myincr y
211 ### NESTED LOOPS ###############################################################
213 proc nestedloops {} {
214 set n 10
215 set x 0
216 incr n 1
217 set a $n
218 while {[incr a -1]} {
219 set b $n
220 while {[incr b -1]} {
221 set c $n
222 while {[incr c -1]} {
223 set d $n
224 while {[incr d -1]} {
225 set e $n
226 while {[incr e -1]} {
227 set f $n
228 while {[incr f -1]} {
229 incr x
238 ### ROTATE #####################################################################
240 proc rotate {count} {
241 set v 1
242 for {set n 0} {$n < $count} {incr n} {
243 set v [expr {$v <<< 1}]
247 ### DYNAMICALLY GENERATED CODE #################################################
249 proc dyncode {} {
250 for {set i 0} {$i < 100000} {incr i} {
251 set script "lappend foo $i"
252 eval $script
256 proc dyncode_list {} {
257 for {set i 0} {$i < 100000} {incr i} {
258 set script [list lappend foo $i]
259 eval $script
263 ### PI DIGITS ##################################################################
265 proc pi_digits {N} {
266 set n [expr {$N * 3}]
267 set e 0
268 set f {}
269 for { set b 0 } { $b <= $n } { incr b } {
270 lappend f 2000
272 for { set c $n } { $c > 0 } { incr c -14 } {
273 set d 0
274 set g [expr { $c * 2 }]
275 set b $c
276 while 1 {
277 incr d [expr { [lindex $f $b] * 10000 }]
278 lset f $b [expr {$d % [incr g -1]}]
279 set d [expr { $d / $g }]
280 incr g -1
281 if { [incr b -1] == 0 } break
282 set d [expr { $d * $b }]
284 append result [string range 0000[expr { $e + $d / 10000 }] end-3 end]
285 set e [expr { $d % 10000 }]
287 #puts $result
290 ### EXPAND #####################################################################
292 proc expand {} {
293 set a [list a b c d e f]
294 for {set i 0} {$i < 100000} {incr i} {
295 lappend b {*}$a
299 ### MINLOOPS ###################################################################
301 proc miniloops {} {
302 for {set i 0} {$i < 100000} {incr i} {
303 set sum 0
304 for {set j 0} {$j < 10} {incr j} {
305 # something of more or less real
306 incr sum $j
311 ### wiki.tcl.tk/8566 ###########################################################
313 # Internal procedure that indexes into the 2-dimensional array t,
314 # which corresponds to the sequence y, looking for the (i,j)th element.
316 proc Index { t y i j } {
317 set indx [expr { ([llength $y] + 1) * ($i + 1) + ($j + 1) }]
318 return [lindex $t $indx]
321 # Internal procedure that implements Levenshtein to derive the longest
322 # common subsequence of two lists x and y.
324 proc ComputeLCS { x y } {
325 set t [list]
326 for { set i -1 } { $i < [llength $y] } { incr i } {
327 lappend t 0
329 for { set i 0 } { $i < [llength $x] } { incr i } {
330 lappend t 0
331 for { set j 0 } { $j < [llength $y] } { incr j } {
332 if { [string equal [lindex $x $i] [lindex $y $j]] } {
333 set lastT [Index $t $y [expr { $i - 1 }] [expr {$j - 1}]]
334 set nextT [expr {$lastT + 1}]
335 } else {
336 set lastT1 [Index $t $y $i [expr { $j - 1 }]]
337 set lastT2 [Index $t $y [expr { $i - 1 }] $j]
338 if { $lastT1 > $lastT2 } {
339 set nextT $lastT1
340 } else {
341 set nextT $lastT2
344 lappend t $nextT
347 return $t
350 # Internal procedure that traces through the array built by ComputeLCS
351 # and finds a longest common subsequence -- specifically, the one that
352 # is lexicographically first.
354 proc TraceLCS { t x y } {
355 set trace {}
356 set i [expr { [llength $x] - 1 }]
357 set j [expr { [llength $y] - 1 }]
358 set k [expr { [Index $t $y $i $j] - 1 }]
359 while { $i >= 0 && $j >= 0 } {
360 set im1 [expr { $i - 1 }]
361 set jm1 [expr { $j - 1 }]
362 if { [Index $t $y $i $j] == [Index $t $y $im1 $jm1] + 1
363 && [string equal [lindex $x $i] [lindex $y $j]] } {
364 lappend trace xy [list $i $j]
365 set i $im1
366 set j $jm1
367 } elseif { [Index $t $y $im1 $j] > [Index $t $y $i $jm1] } {
368 lappend trace x $i
369 set i $im1
370 } else {
371 lappend trace y $j
372 set j $jm1
375 while { $i >= 0 } {
376 lappend trace x $i
377 incr i -1
379 while { $j >= 0 } {
380 lappend trace y $j
381 incr j -1
383 return $trace
386 # list::longestCommonSubsequence::compare --
388 # Compare two lists for the longest common subsequence
390 # Arguments:
391 # x, y - Two lists of strings to compare
392 # matched - Callback to execute on matched elements, see below
393 # unmatchedX - Callback to execute on unmatched elements from the
394 # first list, see below.
395 # unmatchedY - Callback to execute on unmatched elements from the
396 # second list, see below.
398 # Results:
399 # None.
401 # Side effects:
402 # Whatever the callbacks do.
404 # The 'compare' procedure compares the two lists of strings, x and y.
405 # It finds a longest common subsequence between the two. It then walks
406 # the lists in order and makes the following callbacks:
408 # For an element that is common to both lists, it appends the index in
409 # the first list, the index in the second list, and the string value of
410 # the element as three parameters to the 'matched' callback, and executes
411 # the result.
413 # For an element that is in the first list but not the second, it appends
414 # the index in the first list and the string value of the element as two
415 # parameters to the 'unmatchedX' callback and executes the result.
417 # For an element that is in the second list but not the first, it appends
418 # the index in the second list and the string value of the element as two
419 # parameters to the 'unmatchedY' callback and executes the result.
421 proc compare { x y
422 matched
423 unmatchedX unmatchedY } {
424 set t [ComputeLCS $x $y]
425 set trace [TraceLCS $t $x $y]
426 set i [llength $trace]
427 while { $i > 0 } {
428 set indices [lindex $trace [incr i -1]]
429 set type [lindex $trace [incr i -1]]
430 switch -exact -- $type {
431 xy {
432 set c $matched
433 eval lappend c $indices
434 lappend c [lindex $x [lindex $indices 0]]
435 uplevel 1 $c
438 set c $unmatchedX
439 lappend c $indices
440 lappend c [lindex $x $indices]
441 uplevel 1 $c
444 set c $unmatchedY
445 lappend c $indices
446 lappend c [lindex $y $indices]
447 uplevel 1 $c
451 return
454 proc umx { index value } {
455 global lastx
456 global xlines
457 append xlines "< " $value \n
458 set lastx $index
461 proc umy { index value } {
462 global lasty
463 global ylines
464 append ylines "> " $value \n
465 set lasty $index
468 proc matched { index1 index2 value } {
469 global lastx
470 global lasty
471 global xlines
472 global ylines
473 if { [info exists lastx] && [info exists lasty] } {
474 #puts "[expr { $lastx + 1 }],${index1}c[expr {$lasty + 1 }],${index2}"
475 #puts -nonewline $xlines
476 #puts "----"
477 #puts -nonewline $ylines
478 } elseif { [info exists lastx] } {
479 #puts "[expr { $lastx + 1 }],${index1}d${index2}"
480 #puts -nonewline $xlines
481 } elseif { [info exists lasty] } {
482 #puts "${index1}a[expr {$lasty + 1 }],${index2}"
483 #puts -nonewline $ylines
485 catch { unset lastx }
486 catch { unset xlines }
487 catch { unset lasty }
488 catch { unset ylines }
491 # Really, we should read the first file in like this:
492 # set f0 [open [lindex $argv 0] r]
493 # set x [split [read $f0] \n]
494 # close $f0
495 # But I'll just provide some sample lines:
497 proc commonsub_test {} {
498 set x {}
499 for { set i 0 } { $i < 20 } { incr i } {
500 lappend x a r a d e d a b r a x
503 # The second file, too, should be read in like this:
504 # set f1 [open [lindex $argv 1] r]
505 # set y [split [read $f1] \n]
506 # close $f1
507 # Once again, I'll just do some sample lines.
509 set y {}
510 for { set i 0 } { $i < 20 } { incr i } {
511 lappend y a b r a c a d a b r a
514 compare $x $y matched umx umy
515 matched [llength $x] [llength $y] {}
518 ### MANDEL #####################################################################
520 proc mandel {xres yres infx infy supx supy} {
521 set incremx [expr {(0.0+$supx-$infx)/$xres}]
522 set incremy [expr {(0.0+$supy-$infy)/$yres}]
524 for {set j 0} {$j < $yres} {incr j} {
525 set cim [expr {$infy+$incremy*$j}]
526 set line {}
527 for {set i 0} {$i < $xres} {incr i} {
528 set counter 0
529 set zim 0
530 set zre 0
531 set cre [expr {$infx+$incremx*$i}]
532 while {$counter < 255} {
533 set dam [expr {$zre*$zre-$zim*$zim+$cre}]
534 set zim [expr {2*$zim*$zre+$cim}]
535 set zre $dam
536 if {$zre*$zre+$zim*$zim > 4} break
537 incr counter
539 # output pixel $i $j
544 ### RUN ALL ####################################################################
546 if {[string compare [lindex $argv 0] "-batch"] == 0} {
547 set batchmode 1
548 set argv [lrange $argv 1 end]
550 set ver [lindex $argv 0]
552 bench {[while] busy loop} {whilebusyloop}
553 bench {[for] busy loop} {forbusyloop}
554 bench {mini loops} {miniloops}
555 bench {fibonacci(25)} {fibonacci 25}
556 bench {heapsort} {heapsort_main}
557 bench {sieve} {sieve 10}
558 bench {sieve [dict]} {sieve_dict 10}
559 bench {ary} {ary 100000}
560 bench {ary [dict]} {ary_dict 100000}
561 bench {ary [static]} {ary_static 1000000}
562 bench {repeat} {use_repeat}
563 bench {upvar} {upvartest}
564 bench {nested loops} {nestedloops}
565 bench {rotate} {rotate 100000}
566 bench {dynamic code} {dyncode}
567 bench {dynamic code (list)} {dyncode_list}
568 bench {PI digits} {pi_digits 300}
569 bench {expand} {expand}
570 bench {wiki.tcl.tk/8566} {commonsub_test}
571 bench {mandel} {mandel 60 60 -2 -1.5 1 1.5}
573 if {$batchmode} {
574 if {$ver == ""} {
575 if {[catch {info patchlevel} ver]} {
576 set ver Jim[info version]
579 puts [list $ver $benchmarks]