path: root/bench.tcl

set batchmode 0
set benchmarks {}
# Run each benchmark for this long (ms)
# Can be changed with the -time parameter
set benchtime 1000

# If the timerate command doesn't exist, implement it in Tcl
if {[info commands timerate] eq ""} {
    proc timerate {script {ms 1000}} {
        set start [clock micros]
        set stop [expr {$start + $ms * 1000}]
        set count 0
        while {1} {
            uplevel 1 $script
            incr count
            set now [clock micros]
            if {$now >= $stop} {
                break
            }
        }
        set elapsed [expr {$now - $start}]

        # Now try to account for the Tcl overhead
        set start [clock micros]
        set n 0
        while {1} {
            uplevel 1 {}
            incr n
            set now [clock micros]
            if {$n >= $count} {
                break
            }
        }
        set elapsed [expr {$elapsed - ($now - $start)}]

        list us_per_iter [expr {1.0 * $elapsed / $count}] iters_per_sec [expr {1e6 * $count / $elapsed}] \
            count $count elapsed_us $elapsed
    }
}

proc format_us_time {us} {
    set units {2 {ps 1e6} 1 {ns 1e3} 0 {us 1} -1 {ms 1e-3} -2 {s 1e-6}}

    if {$us >= 1e8} {
            # >= 100 seconds
            return [format "%.0fs" [expr {$us / 1e6}]]
    }

    # Avoid using log10 here in case math functions aren't enabled

    # How many digits to the left of the decimal place?
    lassign [split [format %e $us] e] - exp
    # Work around Tcl's stupid auto-octal detection
    set exp [regsub -all {([-+])(0+)?(\d)} $exp {\1\3}]
    set leftdigits [expr {$exp + 1}]
    #set leftdigits [expr {int(floor(log10($us)) + 1)}]
    #puts "$leftdigits1 $leftdigits"
    # Work out how much to shift by, in increments of 10^3
    set shift3 [expr {(-$leftdigits / 3) + 1}]
    set shift [expr {$shift3 * 3}]
    # Always show 3 significant digits
    set decimals [expr {3 - ($leftdigits + $shift)}]
    lassign [dict get $units $shift3] name mult
    set value [expr {$us * $mult}]
    return [format "%.${decimals}f%s" $value $name]
}

proc bench {title script} {
    global benchmarks batchmode

    set Title [string range "$title                     " 0 20]

    catch {collect}
    set failed [catch {timerate $script $::benchtime} res]
    if {$failed} {
        if {!$batchmode} {puts "$Title - This test can't run on this interpreter ($res)"}
        lappend benchmarks $title F
    } else {
        set us [dict get $res us_per_iter]
        set count [dict get $res count]
        set ms [expr {$us / 1000}]
        lappend benchmarks $title $ms
        if {!$batchmode} { puts "$Title - [format_us_time $us] per iteration" }
    }
    catch { collect }
}

### BUSY LOOP ##################################################################

proc whilebusyloop {n} {
    set i 0
    while {$i < $n} {
        set a $i
        incr i
    }
}

proc forbusyloop {n} {
    for {set i 0} {$i < $n} {incr i} {
        set a $i
    }
}

proc loopbusyloop {n} {
    loop i 0 $n {
        set a $i
    }
}

### FIBONACCI ##################################################################

proc fibonacci {x} {
    if {$x <= 1} {
	expr 1
    } else {
	expr {[fibonacci [expr {$x-1}]] + [fibonacci [expr {$x-2}]]}
    }
}

### HEAPSORT ###################################################################

set IM 139968
set IA   3877
set IC  29573

set last 42

proc make_gen_random {} {
    global IM IA IC
    set params [list IM $IM IA $IA IC $IC]
    set body [string map $params {
        global last
        expr {($max * [set last [expr {($last * IA + IC) % IM}]]) / IM}
    }]
    proc gen_random {max} $body
}

proc heapsort {ra_name} {
    upvar 1 $ra_name ra
    set n [llength $ra]
    set l [expr {$n / 2}]
    set ir [expr {$n - 1}]
    while 1 {
        if {$l} {
            set rra [lindex $ra [incr l -1]]
        } else {
	    set rra [lindex $ra $ir]
	    lset ra $ir [lindex $ra 0]
	    if {[incr ir -1] == 0} {
                lset ra 0 $rra
		break
            }
        }
	set i $l
	set j [expr {(2 * $l) + 1}]
        while {$j <= $ir} {
	    set tmp [lindex $ra $j]
	    if {$j < $ir} {
		if {$tmp < [lindex $ra [expr {$j + 1}]]} {
		    set tmp [lindex $ra [incr j]]
		}
	    }
            if {$rra >= $tmp} {
		break
	    }
	    lset ra $i $tmp
	    incr j [set i $j]
        }
        lset ra $i $rra
    }
}

proc heapsort_main {n} {
    make_gen_random

    set data {}
    for {set i 1} {$i <= $n} {incr i} {
	lappend data [gen_random 1.0]
    }
    heapsort data
}

### SIEVE ######################################################################

proc sieve {num} {
    while {$num > 0} {
	incr num -1
	set count 0
	for {set i 2} {$i <= 8192} {incr i} {
	    set flags($i) 1
	}
	for {set i 2} {$i <= 8192} {incr i} {
	    if {$flags($i) == 1} {
		# remove all multiples of prime: i
		for {set k [expr {$i+$i}]} {$k <= 8192} {incr k $i} {
		    set flags($k) 0
		}
		incr count
	    }
	}
    }
    return $count
}

proc sieve_dict {num} {
    while {$num > 0} {
	incr num -1
	set count 0
	for {set i 2} {$i <= 8192} {incr i} {
	    dict set flags $i 1
	}
	for {set i 2} {$i <= 8192} {incr i} {
	    if {[dict get $flags $i] == 1} {
		# remove all multiples of prime: i
		for {set k [expr {$i+$i}]} {$k <= 8192} {incr k $i} {
		    dict set flags $k 0
		}
		incr count
	    }
	}
    }
    return $count
}

### ARY ########################################################################

proc ary n {
    for {set i 0} {$i < $n} {incr i} {
	set x($i) $i
    }
    set last [expr {$n - 1}]
    for {set j $last} {$j >= 0} {incr j -1} {
	set y($j) $x($j)
    }
}

proc ary_dict n {
    for {set i 0} {$i < $n} {incr i} {
	dict set x $i $i
    }
    set last [expr {$n - 1}]
    for {set j $last} {$j >= 0} {incr j -1} {
	dict set y $j $x($j)
    }
}

proc ary_static n {
    for {set i 0} {$i < $n} {incr i} {
        set a(b) $i
        set a(c) $i
    }
}

### REPEAT #####################################################################

proc repeat {n body} {
    for {set i 0} {$i < $n} {incr i} {
	uplevel 1 $body
    }
}

proc use_repeat {n} {
    set x 0
    repeat $n {incr x}
}

### UPVAR ######################################################################

proc myincr varname {
    upvar 1 $varname x
    incr x
}

proc upvartest {n} {
    set y 0
    for {set x 0} {$x < $n} {myincr x} {
	myincr y
    }
}

### NESTED LOOPS ###############################################################

proc nestedloops {n} {
    set x 0
    incr n 1
    set a $n
    while {[incr a -1]} {
	set b $n
	while {[incr b -1]} {
	    set c $n
	    while {[incr c -1]} {
		set d $n
		while {[incr d -1]} {
		    set e $n
		    while {[incr e -1]} {
			set f $n
			while {[incr f -1]} {
			    incr x
			}
		    }
		}
	    }
	}
    }
}

### ROTATE #####################################################################

proc rotate {count} {
    set v 1
    for {set n 0} {$n < $count} {incr n} {
	set v [expr {$v <<< 1}]
    }
}

### DYNAMICALLY GENERATED CODE #################################################

proc dyncode {n} {
    for {set i 0} {$i < $n} {incr i} {
        set script "lappend foo $i"
        eval $script
    }
}

proc dyncode_list {n} {
    for {set i 0} {$i < $n} {incr i} {
        set script [list lappend foo $i]
        eval $script
    }
}

### LIST #################################################

proc listcreate {n} {
    for {set i 0} {$i < $n} {incr i} {
        set a [list a b c d e f]
    }
}

### PI DIGITS ##################################################################

proc pi_digits {N} {
 set n [expr {$N * 3}]
 set e 0
 set f {}
 for { set b 0 } { $b <= $n } { incr b } {
     lappend f 2000
 }
 for { set c $n } { $c > 0 } { incr c -14 } {
     set d 0
     set g [expr { $c * 2 }]
     set b $c
     while 1 {
         incr d [expr { [lindex $f $b] * 10000 }]
         lset f $b [expr {$d % [incr g -1]}]
         set d [expr { $d / $g }]
         incr g -1
         if { [incr b -1] == 0 } break
         set d [expr { $d * $b }]
     }
     append result [string range 0000[expr { $e + $d / 10000 }] end-3 end]
     set e [expr { $d % 10000 }]
 }
 #puts $result
}

### EXPAND #####################################################################

proc expand {} {
    set a [list a b c d e f]
    for {set i 0} {$i < 100000} {incr i} {
        lappend b {*}$a
    }
}

### MINLOOPS ###################################################################

proc miniloops {n} {
    for {set i 0} {$i < $n} {incr i} {
        set sum 0
        for {set j 0} {$j < 10} {incr j} {
            # something more or less real
            incr sum $j
        }
    }
}

### wiki.tcl.tk/8566 ###########################################################

 # Internal procedure that indexes into the 2-dimensional array t,
 # which corresponds to the sequence y, looking for the (i,j)th element.

 proc Index { t y i j } {
     set indx [expr { ([llength $y] + 1) * ($i + 1) + ($j + 1) }]
     return [lindex $t $indx]
 }

 # Internal procedure that implements Levenshtein to derive the longest
 # common subsequence of two lists x and y.

 proc ComputeLCS { x y } {
     set t [list]
     for { set i -1 } { $i < [llength $y] } { incr i } {
         lappend t 0
     }
     for { set i 0 } { $i < [llength $x] } { incr i } {
         lappend t 0
         for { set j 0 } { $j < [llength $y] } { incr j } {
             if { [string equal [lindex $x $i] [lindex $y $j]] } {
                 set lastT [Index $t $y [expr { $i - 1 }] [expr {$j - 1}]]
                 set nextT [expr {$lastT + 1}]
             } else {
                 set lastT1 [Index $t $y $i [expr { $j - 1 }]]
                 set lastT2 [Index $t $y [expr { $i - 1 }] $j]
                 if { $lastT1 > $lastT2 } {
                     set nextT $lastT1
                 } else {
                     set nextT $lastT2
                 }
             }
             lappend t $nextT
         }
     }
     return $t
 }

 # Internal procedure that traces through the array built by ComputeLCS
 # and finds a longest common subsequence -- specifically, the one that
 # is lexicographically first.

 proc TraceLCS { t x y } {
     set trace {}
     set i [expr { [llength $x] - 1 }]
     set j [expr { [llength $y] - 1 }]
     set k [expr { [Index $t $y $i $j] - 1 }]
     while { $i >= 0 && $j >= 0 } {
         set im1 [expr { $i - 1 }]
         set jm1 [expr { $j - 1 }]
         if { [Index $t $y $i $j] == [Index $t $y $im1 $jm1] + 1
              && [string equal [lindex $x $i] [lindex $y $j]] } {
             lappend trace xy [list $i $j]
             set i $im1
             set j $jm1
         } elseif { [Index $t $y $im1 $j] > [Index $t $y $i $jm1] } {
             lappend trace x $i
             set i $im1
         } else {
             lappend trace y $j
             set j $jm1
         }
     }
     while { $i >= 0 } {
         lappend trace x $i
         incr i -1
     }
     while { $j >= 0 } {
         lappend trace y $j
         incr j -1
     }
     return $trace
 }

 # list::longestCommonSubsequence::compare --
 #
 #       Compare two lists for the longest common subsequence
 #
 # Arguments:
 #       x, y - Two lists of strings to compare
 #       matched - Callback to execute on matched elements, see below
 #       unmatchedX - Callback to execute on unmatched elements from the
 #                    first list, see below.
 #       unmatchedY - Callback to execute on unmatched elements from the
 #                    second list, see below.
 #
 # Results:
 #       None.
 #
 # Side effects:
 #       Whatever the callbacks do.
 #
 # The 'compare' procedure compares the two lists of strings, x and y.
 # It finds a longest common subsequence between the two.  It then walks
 # the lists in order and makes the following callbacks:
 #
 # For an element that is common to both lists, it appends the index in
 # the first list, the index in the second list, and the string value of
 # the element as three parameters to the 'matched' callback, and executes
 # the result.
 #
 # For an element that is in the first list but not the second, it appends
 # the index in the first list and the string value of the element as two
 # parameters to the 'unmatchedX' callback and executes the result.
 #
 # For an element that is in the second list but not the first, it appends
 # the index in the second list and the string value of the element as two
 # parameters to the 'unmatchedY' callback and executes the result.

 proc compare { x y
                                                matched
                                                unmatchedX unmatchedY } {
     set t [ComputeLCS $x $y]
     set trace [TraceLCS $t $x $y]
     set i [llength $trace]
     while { $i > 0 } {
         set indices [lindex $trace [incr i -1]]
         set type [lindex $trace [incr i -1]]
         switch -exact -- $type {
             xy {
                 set c $matched
                 eval lappend c $indices
                 lappend c [lindex $x [lindex $indices 0]]
                 uplevel 1 $c
             }
             x {
                 set c $unmatchedX
                 lappend c $indices
                 lappend c [lindex $x $indices]
                 uplevel 1 $c
             }
             y {
                 set c $unmatchedY
                 lappend c $indices
                 lappend c [lindex $y $indices]
                 uplevel 1 $c
             }
         }
     }
     return
 }

 proc umx { index value } {
     global lastx
     global xlines
     append xlines "< " $value \n
     set lastx $index
 }

 proc umy { index value } {
     global lasty
     global ylines
     append ylines "> " $value \n
     set lasty $index
 }

 proc matched { index1 index2 value } {
     global lastx
     global lasty
     global xlines
     global ylines
     if { [info exists lastx] && [info exists lasty] } {
     #puts "[expr { $lastx + 1 }],${index1}c[expr {$lasty + 1 }],${index2}"
     #puts -nonewline $xlines
     #puts "----"
     #puts -nonewline $ylines
     } elseif { [info exists lastx] } {
     #puts "[expr { $lastx + 1 }],${index1}d${index2}"
     #puts -nonewline $xlines
     } elseif { [info exists lasty] } {
     #puts  "${index1}a[expr {$lasty + 1 }],${index2}"
     #puts -nonewline $ylines
     }
     catch { unset lastx }
     catch { unset xlines }
     catch { unset lasty }
     catch { unset ylines }
 }

 # Really, we should read the first file in like this:
 #    set f0 [open [lindex $argv 0] r]
 #    set x [split [read $f0] \n]
 #    close $f0
 # But I'll just provide some sample lines:

proc commonsub_test {n} {
 set x {}
 for { set i 0 } { $i < $n } { incr i } {
     lappend x a r a d e d a b r a x
 }

 # The second file, too, should be read in like this:
 #    set f1 [open [lindex $argv 1] r]
 #    set y [split [read $f1] \n]
 #    close $f1
 # Once again, I'll just do some sample lines.

 set y {}
 for { set i 0 } { $i < $n } { incr i } {
     lappend y a b r a c a d a b r a
 }

 compare $x $y matched umx umy
 matched [llength $x] [llength $y] {}
}

### MANDEL #####################################################################

proc mandel {xres yres infx infy supx supy} {
    set incremx [expr {(0.0+$supx-$infx)/$xres}]
    set incremy [expr {(0.0+$supy-$infy)/$yres}]

    for {set j 0} {$j < $yres} {incr j} {
	set cim [expr {$infy+$incremy*$j}]
	set line {}
	for {set i 0} {$i < $xres} {incr i} {
	    set counter 0
	    set zim 0
	    set zre 0
	    set cre [expr {$infx+$incremx*$i}]
	    while {$counter < 255} {
		set dam [expr {$zre*$zre-$zim*$zim+$cre}]
		set zim [expr {2*$zim*$zre+$cim}]
		set zre $dam
		if {$zre*$zre+$zim*$zim > 4} break
		incr counter
	    }
	    # output pixel $i $j
	}
    }
}

### RUN ALL ####################################################################

# bench.tcl ?-batch? ?-time <ms>? ?version?

while [llength $argv] {
    switch -glob -- [lindex $argv 0] {
        -batch {
            set batchmode 1
            set argv [lrange $argv 1 end]
        }
        -time {
            set arg [lindex $argv 1]
            if {$arg ne ""} {
                set benchtime $arg
            }
            set argv [lrange $argv 2 end]
        }
        default {
            break
        }
    }
}
set ver [lindex $argv 0]

bench {[while] busy loop} {whilebusyloop 10}
bench {[for] busy loop} {forbusyloop 10}
bench {[loop] busy loop} {loopbusyloop 10}
bench {mini loops} {miniloops 10}
bench {fibonacci(4)} {fibonacci 4}
bench {heapsort} {heapsort_main 50}
bench {sieve} {sieve 1}
bench {sieve [dict]} {sieve_dict 1}
bench {ary} {ary 20}
bench {ary [dict]} {ary_dict 20}
bench {ary [static]} {ary_static 20}
bench {repeat} {use_repeat 20}
bench {upvar} {upvartest 20}
bench {nested loops} {nestedloops 2}
bench {rotate} {rotate 100}
bench {dynamic code} {dyncode 100}
bench {dynamic code (list)} {dyncode_list 100}
bench {PI digits} {pi_digits 100}
bench {listcreate} {listcreate 100}
bench {expand} {expand}
bench {wiki.tcl.tk/8566} {commonsub_test 10}
bench {mandel} {mandel 30 30 -2 -1.5 1 1.5}

if {$batchmode} {
    if {$ver == ""} {
        if {[catch {info patchlevel} ver]} {
            set ver Jim[info version]
        }
    }
    puts [list $ver $benchmarks]
}