├── tcl ├── format.bench ├── namespace.bench ├── array.bench ├── trace.bench ├── wordcount.in ├── data.bench ├── catch.bench ├── unset.bench ├── uplevel.bench ├── loops.bench ├── matrix.bench ├── split.bench ├── methods.bench ├── heapsort.bench ├── file.bench ├── wordcount.bench ├── fcopy.bench ├── conditional.bench ├── encoding.bench ├── binary.bench ├── parse.bench ├── read.bench ├── map.bench ├── expr.bench ├── eval.bench ├── regexp.bench ├── vars.bench ├── klist.bench ├── ascii85.bench ├── list.bench ├── base64.bench └── sha1.bench ├── tk ├── startup.bench ├── entry.bench └── canvas.bench ├── doc ├── normbench.1 ├── libbench.n └── runbench.1 ├── normbench.tcl ├── libbench.tcl ├── ChangeLog └── runbench.tcl /tcl/format.bench: -------------------------------------------------------------------------------- 1 | # -*- tcl -*- 2 | # Benchmark format command 3 | # 4 | # RCS: @(#) $Id$ 5 | # 6 | 7 | proc genKeys {i} { 8 | format "%06d" $i 9 | } 10 | 11 | bench -desc "FORMAT gen" \ 12 | -body {genKeys 50} 13 | -------------------------------------------------------------------------------- /tk/startup.bench: -------------------------------------------------------------------------------- 1 | set file [bench_tmpfile] 2 | set fp [open $file w] 3 | puts $fp "exit" 4 | close $fp 5 | 6 | bench -desc "STARTUP time to launch wish" -iter 100 \ 7 | -body {exec $BENCH(INTERP) $file} 8 | 9 | bench_rm $file 10 | -------------------------------------------------------------------------------- /tk/entry.bench: -------------------------------------------------------------------------------- 1 | proc entry-create {w} { 2 | entry $w 3 | destroy $w 4 | } 5 | 6 | eval destroy [winfo children .] 7 | 8 | bench -iters 100 -desc "ENTRY create" \ 9 | -body {entry-create .e} 10 | 11 | entry .one 12 | 13 | bench -iters 500 -desc "ENTRY create (one exists)" \ 14 | -body {entry-create .e} 15 | 16 | eval destroy [winfo children .] 17 | -------------------------------------------------------------------------------- /tcl/namespace.bench: -------------------------------------------------------------------------------- 1 | if {[info tclversion] < 8.0} { return } 2 | 3 | namespace eval a { 4 | proc aa {} { 5 | format %x 100 6 | } 7 | } 8 | namespace eval b { 9 | proc bb {} { 10 | format %x 100 11 | } 12 | } 13 | 14 | bench -desc "NS alternating" -body { 15 | for {set x 50} {[incr x -1]} {} { 16 | ::a::aa 17 | ::b::bb 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /tcl/array.bench: -------------------------------------------------------------------------------- 1 | # -*- tcl -*- 2 | # Benchmark array / hash stuff 3 | # 4 | # RCS: @(#) $Id$ 5 | # 6 | 7 | proc genKeys {N {prefix ""}} { 8 | set lst {} 9 | for {set i 0} {$i < $N} {incr i} { 10 | lappend lst $prefix[format "%06d" $i] 11 | } 12 | return $lst 13 | } 14 | 15 | proc makeHash {var Mlst Nlst} { 16 | upvar 1 $var hash 17 | foreach m $Mlst { 18 | foreach n $Nlst { set hash($m,$n) 1 } 19 | } 20 | } 21 | 22 | set N 50 23 | set Nlst [genKeys $N] 24 | bench -desc "ARRAY format genKeys $N" -iter 100 \ 25 | -body {genKeys $N} 26 | 27 | set M 500 28 | set Mlst [genKeys $M] 29 | bench -desc "ARRAY format genKeys $M" -iter 50 \ 30 | -body {genKeys $M} 31 | 32 | catch {unset hash} 33 | bench -desc "ARRAY makeHash [llength $Mlst] [llength $Nlst]" -iter 50 \ 34 | -body {makeHash hash $Mlst $Nlst; catch {unset hash}} 35 | -------------------------------------------------------------------------------- /tcl/trace.bench: -------------------------------------------------------------------------------- 1 | proc trace-bogus {name1 name2 op} { 2 | # just check existence 3 | upvar $name1 var 4 | info exists var 5 | } 6 | 7 | proc trace-var {def} { 8 | global a 9 | # 2 reps of write, read, unset 10 | set a $def 11 | set b $a 12 | unset a 13 | set a $def 14 | set b $a 15 | unset a 16 | } 17 | 18 | bench -desc "TRACE no trace set" -body {trace-var blah} 19 | 20 | trace variable a r trace-bogus 21 | bench -desc "TRACE read" -body {trace-var blah} 22 | trace vdelete a r trace-bogus 23 | 24 | trace variable a w trace-bogus 25 | bench -desc "TRACE write" -body {trace-var blah} 26 | trace vdelete a w trace-bogus 27 | 28 | trace variable a u trace-bogus 29 | bench -desc "TRACE unset" -body {trace-var blah} 30 | trace vdelete a u trace-bogus 31 | 32 | trace variable a rwu trace-bogus 33 | bench -desc "TRACE all set (rwu)" -body {trace-var blah} 34 | trace vdelete a rwu trace-bogus 35 | -------------------------------------------------------------------------------- /tcl/wordcount.in: -------------------------------------------------------------------------------- 1 | Subject: Re: Who was Izchak Miller? 2 | From: "Jane D. Anonymous" 3 | Date: 1996/04/28 4 | Message-Id: <4lv7bc$oh@news.ycc.yale.edu> 5 | References: <317C405E.5DFA@panix.com> <4lk6vl$gde@ns.oar.net> 6 | To: 75176.2330@compuserve.com 7 | Content-Type: text/plain; charset=us-ascii 8 | Organization: Yale University 9 | X-Url: news:4lk6vl$gde@ns.oar.net 10 | Mime-Version: 1.0 11 | Newsgroups: rec.games.roguelike.nethack 12 | X-Mailer: Mozilla 1.1N (Macintosh; I; 68K) 13 | 14 | Hello there, Izchak Miller was my father. When I was younger I spent 15 | many a night, hunched over the keyboard with a cup of tea, playing 16 | nethack with him and my brother. my dad was a philosopher with a strong 17 | weakness for fantasy/sci fi. I remember when he started to get involved 18 | with the Nethack team- my brother's Dungeons and Dragons monster book 19 | found a regular place beside my dad's desk. it's nice to see him living 20 | on in the game he loved so much :-). 21 | Tamar Miller 22 | -------------------------------------------------------------------------------- /tcl/data.bench: -------------------------------------------------------------------------------- 1 | 2 | # Put data in a list 3 | proc data-create-list {size} { 4 | for {set i 0} {$i < $size} {incr i} { 5 | lappend list $i 6 | } 7 | } 8 | 9 | # Put data in an array 10 | proc data-create-array {size} { 11 | for {set i 0} {$i < $size} {incr i} { 12 | set array($i) $i 13 | } 14 | } 15 | 16 | # Access data in a list 17 | proc data-access-list {listVar size} { 18 | upvar 1 $listVar list 19 | for {set i 0} {$i < $size} {incr i} { 20 | set bogus [lindex $list $i] 21 | } 22 | } 23 | 24 | # Access data in an array 25 | proc data-access-array {arrayVar size} { 26 | upvar 1 $arrayVar array 27 | for {set i 0} {$i < $size} {incr i} { 28 | set bogus $array($i) 29 | } 30 | } 31 | 32 | set size 500 33 | set list {} 34 | for {set i 0} {$i < $size} {incr i} { 35 | lappend list $i 36 | } 37 | 38 | for {set i 0} {$i < $size} {incr i} { 39 | set array($i) $i 40 | } 41 | 42 | bench -desc "DATA create in a list" \ 43 | -body {data-create-list $size} 44 | bench -desc "DATA create in an array" \ 45 | -body {data-create-array $size} 46 | 47 | bench -desc "DATA access in a list" \ 48 | -body {data-access-list list $size} 49 | bench -desc "DATA access in an array" \ 50 | -body {data-access-array array $size} 51 | -------------------------------------------------------------------------------- /tcl/catch.bench: -------------------------------------------------------------------------------- 1 | proc throw {code} { 2 | return -code $code hello 3 | } 4 | 5 | # catch with no error condition 6 | proc catch-error {a} { 7 | catch {set a [throw 0]} 8 | } 9 | 10 | # catch with error condition 11 | proc catch-ok {a} { 12 | catch {set a [throw 1]} 13 | } 14 | 15 | # catch with non-error exception 16 | proc catch-except {a} { 17 | catch {set a [throw 10]} 18 | } 19 | 20 | # no catch 21 | proc catch-none {a} { 22 | set a [throw 0] 23 | } 24 | 25 | # catch with error condition, complex body with many nested ranges 26 | set nestedRanges {set a 0; while {$a} {nestedRanges}} 27 | for {set i 0} {$i < 3} {incr i} { 28 | # use regsub for compatability 29 | regsub -all nestedRanges $nestedRanges "\{$nestedRanges\}" nestedRanges 30 | } 31 | for {set i 0} {$i < 4} {incr i} { 32 | append nestedRanges "\n$nestedRanges" 33 | } 34 | set body { 35 | catch {set a [throw 1]} 36 | return 37 | } 38 | 39 | proc catch-ranges {a} [append body $nestedRanges] 40 | 41 | 42 | bench -body {catch-error arg} -desc "CATCH return ok" 43 | bench -body {catch-ok arg} -desc "CATCH return error" 44 | bench -body {catch-except arg} -desc "CATCH return except" 45 | bench -body {catch-none arg} -desc "CATCH no catch used" 46 | bench -body {catch-ranges arg} -desc "CATCH error, complex" 47 | -------------------------------------------------------------------------------- /doc/normbench.1: -------------------------------------------------------------------------------- 1 | '\" -*- nroff -*- 2 | '\" Copyright (c) 2001 by Andreas Kupries 3 | '\" All rights reserved. 4 | '\" 5 | '\" RCS: @(#) $Id$ 6 | '\" 7 | .so man.macros 8 | .TH normbench.tcl 1 1.0 Normbench "Tclbench application" 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | normbench.tcl \- Normalize benchmark results. 13 | .SH SYNOPSIS 14 | \fBnormbench.tcl\fR \fI?-option value ...? ?file?\fR 15 | .BE 16 | .SH DESCRIPTION 17 | .PP 18 | The \fBnormbench.tcl\fR application provides the same functionality as 19 | the \fI-normalize\fR option of \fBrunbench.tcl\fR. This allows the 20 | postprocessing of benchmark results which there not normalized right 21 | away. It processes either the file whose name was specified on the 22 | commandline or \fBstdin\fR. It automatically detects which of the 23 | formats supported by \fBrunbench.tcl\fR the input is in. 24 | .PP 25 | The following options are recognized by the application: 26 | .TP 27 | \fB-help\fR 28 | Causes the application to print a list of the recognized option plus 29 | short explanations of their meaning. 30 | .TP 31 | \fB-normalize\fR 32 | Takes a version number as value and causes the application to 33 | normalize the timing values to the value of the given version. 34 | .RE 35 | .SH KEYWORDS 36 | benchmarks, tclbench, libbench, runbench 37 | -------------------------------------------------------------------------------- /tcl/unset.bench: -------------------------------------------------------------------------------- 1 | # Unsetting an existing variable 2 | proc unset-std {i} { 3 | set i 0 4 | unset i 5 | } 6 | 7 | # Catching invalid unset 8 | proc unset-error {i} { 9 | set i 0 10 | catch {unset j} 11 | } 12 | 13 | # Catching valid unset 14 | proc unset-ok {i} { 15 | set i 0 16 | catch {unset i} 17 | } 18 | 19 | # Testing existence befor unset 20 | proc unset-exists {i} { 21 | set i 0 22 | if {[info exists i]} { 23 | unset i 24 | } 25 | } 26 | 27 | proc unset-nonexists {i} { 28 | set i 0 29 | if {[info exists j]} { 30 | unset j 31 | } 32 | } 33 | 34 | if {[catch {unset -nocomplain}]} { 35 | proc unset-nocomplain-exists {i} [info body unset-ok] 36 | proc unset-nocomplain-!exist {i} [info body unset-error] 37 | } else { 38 | proc unset-nocomplain-exists {i} { 39 | set i 0 40 | unset -nocomplain i 41 | } 42 | proc unset-nocomplain-!exist {i} { 43 | set i 0 44 | unset -nocomplain j 45 | } 46 | } 47 | 48 | set iters 10000 49 | bench -iter $iters -desc "UNSET var exists" \ 50 | -body {unset-std a} 51 | bench -iter $iters -desc "UNSET catch var exists" \ 52 | -body {unset-ok a} 53 | bench -iter $iters -desc "UNSET catch var !exist" \ 54 | -body {unset-error a} 55 | bench -iter $iters -desc "UNSET info check var exists" \ 56 | -body {unset-exists a} 57 | bench -iter $iters -desc "UNSET info check var !exist" \ 58 | -body {unset-nonexists a} 59 | bench -iter $iters -desc "UNSET nocomplain var exists" \ 60 | -body {unset-nocomplain-exists a} 61 | bench -iter $iters -desc "UNSET nocomplain var !exist" \ 62 | -body {unset-nocomplain-!exist a} 63 | -------------------------------------------------------------------------------- /tcl/uplevel.bench: -------------------------------------------------------------------------------- 1 | # 2 | # Benchmarks to measure the performance of [uplevel] scripts under different 3 | # circumstances . 4 | # 5 | # First version: only testing script in a single non-list obj. Could also 6 | # consider single canonical-list obj and multi-obj scripts as interesting cases 7 | # to benchmark. 8 | # 9 | 10 | if {[catch {package require Tcl 8}]} { 11 | return 12 | } 13 | 14 | if {![llength [info command lrepeat]]} { 15 | proc lrepeat {n s} { 16 | set l {} 17 | incr n 18 | while {[incr n -1]} { 19 | lappend l $s 20 | } 21 | return $l 22 | } 23 | } 24 | 25 | proc foreachcount {var list countvar command} { 26 | upvar $var v 27 | upvar $countvar i 28 | set i 0 29 | foreach v $list { 30 | uplevel 1 $command 31 | incr i 32 | } 33 | } 34 | 35 | proc loop1 {} { 36 | # base case 37 | set i 0 38 | foreach x $::a { 39 | set y [expr {$i + $x}] 40 | incr i 41 | } 42 | } 43 | 44 | set basebody { 45 | foreachcount x $::a i { 46 | set y [expr {$i + $x}] 47 | } 48 | } 49 | 50 | # pre-populate the LVT (if any) 51 | set primedbody " 52 | set x {} 53 | set y {} 54 | set i {} 55 | $basebody 56 | " 57 | 58 | # script upleveled to proc body 59 | proc loop2 {} $basebody 60 | 61 | # script upleveled to proc body, pre-populated LVT 62 | proc loop3 {} $primedbody 63 | 64 | set a [lrepeat 1000 1] 65 | set iter 50 66 | 67 | bench -desc "UPLEVEL none" -iter $iter \ 68 | -body loop1 69 | 70 | bench -desc "UPLEVEL to proc" -iter $iter \ 71 | -body loop2 72 | 73 | bench -desc "UPLEVEL primed" -iter $iter \ 74 | -body loop3 75 | 76 | bench -desc "UPLEVEL to nseval" -iter $iter \ 77 | -body [list namespace eval foo $basebody] 78 | -------------------------------------------------------------------------------- /tcl/loops.bench: -------------------------------------------------------------------------------- 1 | # Iterate over lists with for 2 | proc loops-for-list {list} { 3 | set len [llength $list] 4 | for {set i 0} {$i < $len} {incr i} { 5 | set var [lindex $list $i] 6 | } 7 | } 8 | 9 | # Iterate over lists with foreach 10 | proc loops-foreach-list {list} { 11 | foreach elem $list { 12 | set var $elem 13 | } 14 | } 15 | 16 | # Looping with for 17 | proc loops-foo-num {size} { 18 | for {set i 0} {$i < $size} {incr i} { 19 | set bogus abc 20 | } 21 | } 22 | 23 | # Looping with while 24 | proc loops-while-num {size} { 25 | set i 0 26 | while {$i < $size} { 27 | set bogus abc 28 | incr i 29 | } 30 | } 31 | 32 | # Looping with while 33 | proc loops-while-1 {size} { 34 | set i 0 35 | while {1} { 36 | if {[incr i] > $size} { break } 37 | } 38 | } 39 | 40 | # iterate over chars in string using [string index] 41 | proc loops-for-string {s} { 42 | set len [string length $s] 43 | for {set i 0} {$i < $len} {incr i} { 44 | set var [string index $s $i] 45 | } 46 | } 47 | 48 | # iterate over chars in string using [foreach] and [split] 49 | proc loops-foreach-string {s} { 50 | foreach c [split $s {}] { 51 | set var $c 52 | } 53 | } 54 | 55 | set list {} 56 | set string "" 57 | set size 1000 58 | for {set i 0} {$i < $size} {incr i} { 59 | lappend list $i 60 | append string "0" 61 | } 62 | 63 | bench -desc "LOOP for, iterate list" \ 64 | -body {loops-for-list $list} 65 | bench -desc "LOOP foreach, iterate list" \ 66 | -body {loops-foreach-list $list} 67 | bench -desc "LOOP for (to $size)" \ 68 | -body {loops-foo-num $size} 69 | bench -desc "LOOP while (to $size)" \ 70 | -body {loops-while-num $size} 71 | bench -desc "LOOP while 1 (to $size)" \ 72 | -body {loops-while-1 $size} 73 | bench -desc "LOOP for, iterate string" \ 74 | -body {loops-for-string $string} 75 | bench -desc "LOOP foreach, iterate string" \ 76 | -body {loops-foreach-string $string} 77 | -------------------------------------------------------------------------------- /tcl/matrix.bench: -------------------------------------------------------------------------------- 1 | proc makeMatrix {rows cols} { 2 | set count 1 3 | set mx [list] 4 | for { set i 0 } { $i < $rows } { incr i } { 5 | set row [list] 6 | for { set j 0 } { $j < $cols } { incr j } { 7 | lappend row $count 8 | incr count 9 | } 10 | lappend mx $row 11 | } 12 | return $mx 13 | } 14 | 15 | proc matrixTransp0 {m} { 16 | set cols [llength [lindex $m 0]] 17 | 18 | foreach row $m { 19 | for {set ncol 0} {$ncol < $cols} {incr ncol} { 20 | lappend res($ncol) [lindex $row $ncol] 21 | } 22 | } 23 | 24 | foreach row [array names res] { 25 | lappend result $res($row) 26 | } 27 | 28 | set result 29 | } 30 | 31 | proc matrixTransp1 {m} { 32 | set rows [llength $m] 33 | set cols [llength [lindex $m 0]] 34 | 35 | for {set c 0} {$c < $cols} {incr c} { 36 | set nrow {} 37 | for {set r 0} {$r < $rows} {incr r} { 38 | lappend nrow [lindex [lindex $m $r] $c] 39 | } 40 | lappend result $nrow 41 | } 42 | set result 43 | } 44 | 45 | # From: 46 | # http://www.bagley.org/~doug/shootout/ 47 | proc mmult {m1 m2} { 48 | set cols [lindex $m2 0] 49 | foreach row1 $m1 { 50 | set row {} 51 | set i 0 52 | foreach - $cols { 53 | set elem 0 54 | foreach elem1 $row1 row2 $m2 { 55 | set elem [expr {$elem + $elem1 * [lindex $row2 $i]}] 56 | } 57 | lappend row $elem 58 | incr i 59 | } 60 | lappend result $row 61 | } 62 | return $result 63 | } 64 | 65 | set m [makeMatrix 20 50] 66 | set iter 400 67 | bench -desc "MATRIX transposition-0" -iter $iter \ 68 | -body {matrixTransp0 $m} 69 | bench -desc "MATRIX transposition-1" -iter $iter \ 70 | -body {matrixTransp1 $m} 71 | 72 | foreach size {5 10 15} { 73 | set m1 [makeMatrix $size $size] 74 | set m2 [makeMatrix $size $size] 75 | bench -desc "MATRIX mult ${size}x${size}" -iter $iter \ 76 | -body {mmult $m1 $m2} 77 | } 78 | -------------------------------------------------------------------------------- /tcl/split.bench: -------------------------------------------------------------------------------- 1 | # 2 | # RCS: @(#) $Id$ 3 | # 4 | 5 | proc str-split {string} { 6 | split $string {} 7 | } 8 | proc str-split-iter {string} { 9 | set var {} 10 | foreach c [split $string {}] { 11 | set var $c 12 | } 13 | } 14 | 15 | proc split-char {c string} { 16 | set var {} 17 | foreach ch [split $string $c] { 18 | set var $ch 19 | } 20 | } 21 | 22 | # String operations 23 | # It is important to have 2 of each type, to avoid optimizations 24 | # in the core made for comparing the same exact obj. 25 | # 26 | 27 | proc init {} { 28 | global longString longString2 ustring ustring2 29 | for {set i 0} {$i < 100} {incr i} { 30 | append longString "abcdefghijklmnopqrstuvwxyz01234567890123" 31 | } 32 | append longString 0987654321 33 | for {set i 0} {$i < 100} {incr i} { 34 | append longString2 "abcdefghijklmnopqrstuvwxyz01234567890123" 35 | } 36 | append longString2 0987654321 37 | for {set i 0} {$i < 100} {incr i} { 38 | append ustring "abcdefghijk\353\370\371\372pqrs\373uvwxyz0123456789012\374" 39 | } 40 | #set ustring2 "$ustring \369a" 41 | for {set i 0} {$i < 100} {incr i} { 42 | append ustring2 "abcdefghijk\353\370\371\372pqrs\373uvwxyz0123456789012\374" 43 | } 44 | if {[info tclversion] >= 8.0} { 45 | global randString 46 | expr {srand(12345)} 47 | for {set i 0} {$i < 10000} {incr i} { 48 | append randString [format %c [expr {int(rand()*255)}]] 49 | } 50 | } 51 | } 52 | init 53 | 54 | set iter 400 55 | bench -desc "SPLIT, [string length $longString] chars" -iter $iter \ 56 | -body {str-split $longString} 57 | bench -desc "SPLIT, [string length $ustring] uchars" -iter $iter \ 58 | -body {str-split $ustring} 59 | bench -desc "SPLIT iter, [string length $longString] chars" -iter $iter \ 60 | -body {str-split-iter $longString} 61 | bench -desc "SPLIT iter, [string length $ustring] uchars" -iter $iter \ 62 | -body {str-split-iter $ustring} 63 | if {[info exists randString]} { 64 | foreach len {100 1000 10000} { 65 | set str [string range $randString 0 $len] 66 | bench -desc "SPLIT, rand $len c" -iter $iter \ 67 | -body {str-split $str} 68 | bench -desc "SPLIT iter, rand $len c" -iter $iter \ 69 | -body {str-split-iter $str} 70 | } 71 | } 72 | foreach chars "c cz c\373" { 73 | bench -desc "SPLIT on '$chars', [string length $longString] chars" \ 74 | -iter $iter -body {split-char $chars $longString} 75 | bench -desc "SPLIT on '$chars', [string length $ustring] uchars" \ 76 | -iter $iter -body {split-char $chars $ustring} 77 | } 78 | -------------------------------------------------------------------------------- /tcl/methods.bench: -------------------------------------------------------------------------------- 1 | if {[info tclversion] < 8.0} { return } 2 | 3 | namespace eval dad { 4 | proc test {x args} {set x} 5 | test 5 6 | namespace export -clear * 7 | } 8 | namespace eval son {} 9 | 10 | # 1. Plain proc call 11 | proc ::son::test {x args} {set x} 12 | 13 | bench -desc "MTHD direct ns proc call" \ 14 | -body {::son::test 5} 15 | 16 | namespace eval :: {rename ::son::test {}} 17 | 18 | # namespace import 19 | namespace eval ::son { namespace import -force ::dad::* } 20 | 21 | bench -desc "MTHD imported ns proc call" \ 22 | -body {::son::test 5} 23 | 24 | namespace eval :: {rename ::son::test {}} 25 | 26 | # interp alias 27 | interp alias {} ::son::test {} ::dad::test 28 | 29 | bench -desc "MTHD interp alias proc call" \ 30 | -body {::son::test 5} 31 | 32 | interp alias {} ::son::test {} 33 | 34 | # indirect through proc 35 | proc ::son::test {x args} { eval [linsert $args 0 ::dad::test $x] } 36 | 37 | bench -desc "MTHD indirect proc eval" \ 38 | -body {::son::test 5} 39 | 40 | namespace eval :: {rename ::son::test {}} 41 | 42 | # indirect through proc 43 | proc ::son::test {x args} { eval [list ::dad::test $x] $args } 44 | 45 | bench -desc "MTHD indirect proc eval #2" \ 46 | -body {::son::test 5} 47 | 48 | namespace eval :: {rename ::son::test {}} 49 | 50 | # store in array (it's name is the empty string!) 51 | set ::(::son::test) ::dad::test 52 | 53 | bench -desc "MTHD array stored proc call" \ 54 | -body {$::(::son::test) 5} 55 | 56 | # switch 57 | proc ::son {method args} { 58 | switch $method { 59 | a {} 60 | b {} 61 | test {return [eval [linsert $args 0 ::dad::test]]} 62 | } 63 | } 64 | 65 | bench -desc "MTHD switch method call" \ 66 | -body {::son test 5} 67 | 68 | namespace eval :: {rename ::son {}} 69 | 70 | # lookup 71 | set ::b [list ::dad ::none] 72 | proc ::son {method args} { 73 | foreach anc $::b { 74 | if {[llength [info proc ${anc}::$method]]} { 75 | return [eval [linsert $args 0 ${anc}::$method]] 76 | } 77 | } 78 | } 79 | 80 | bench -desc "MTHD ns lookup call" \ 81 | -body {::son test 5} 82 | 83 | namespace eval :: {rename ::son {}} 84 | 85 | # inline 86 | set x 5 87 | 88 | bench -desc "MTHD inline call" \ 89 | -body {set x} 90 | 91 | proc foo {} { return 1 } 92 | 93 | namespace eval ::call { 94 | proc bar {cmd} {$cmd} 95 | } 96 | 97 | proc call {cmd} { 98 | ::call::bar $cmd 99 | $cmd 100 | } 101 | 102 | bench -desc "MTHD call relative" \ 103 | -body {call foo} 104 | bench -desc "MTHD call absolute" \ 105 | -body {call ::foo} 106 | -------------------------------------------------------------------------------- /tcl/heapsort.bench: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/tclsh 2 | # $Id$ 3 | # http://www.bagley.org/~doug/shootout/ 4 | # sped up by Miguel Sofer's function generator 5 | # adapated for tclbench by Jeff Hobbs 6 | 7 | set IM 139968 8 | set IA 3877 9 | set IC 29573 10 | 11 | set last 42 12 | 13 | proc gen_random {max} [subst { 14 | global last 15 | expr {(\$max * \[set last \[expr {(\$last * $IA + $IC) % $IM}\]\]) / $IM} 16 | }] 17 | 18 | proc heapsort {n ra_name} { 19 | upvar 1 $ra_name ra 20 | 21 | set j 0 22 | set i 0 23 | set rra 0.0 24 | set l [expr {($n >> 1) + 1}] 25 | set ir $n 26 | while 1 { 27 | if {$l > 1} { 28 | incr l -1 29 | set rra $ra($l) 30 | } else { 31 | set rra $ra($ir) 32 | set ra($ir) $ra(1) 33 | incr ir -1 34 | if {$ir == 1} { 35 | set ra(1) $rra 36 | return 37 | } 38 | } 39 | set i $l 40 | set j [expr {$l << 1}] 41 | while {$j <= $ir} { 42 | if {($j < $ir) && ($ra($j) < $ra([expr {$j + 1}]))} { 43 | incr j 44 | } 45 | if {$rra < $ra($j)} { 46 | set ra($i) $ra($j) 47 | set i $j 48 | set j [expr {$j + $i}] 49 | } else { 50 | set j [expr {$ir + 1}] 51 | } 52 | } 53 | set ra($i) $rra 54 | } 55 | } 56 | 57 | proc heapsortLset {ra_name} { 58 | upvar 1 $ra_name ra 59 | 60 | set n [expr {[llength $ra] - 1}] 61 | set j 0 62 | set i 0 63 | set rra 0.0 64 | set l [expr {($n >> 1) + 1}] 65 | set ir $n 66 | while 1 { 67 | if {$l > 1} { 68 | incr l -1 69 | set rra [lindex $ra $l] 70 | } else { 71 | set rra [lindex $ra $ir] 72 | lset ra $ir [lindex $ra 1] 73 | incr ir -1 74 | if {$ir == 1} { 75 | return [lset ra 1 $rra] 76 | } 77 | } 78 | set i $l 79 | set j [expr {$l << 1}] 80 | while {$j <= $ir} { 81 | if {($j < $ir) && ([lindex $ra $j] < [lindex $ra [expr {$j + 1}]])} { 82 | incr j 83 | } 84 | if {$rra < [lindex $ra $j]} { 85 | lset ra $i [lindex $ra $j] 86 | set i $j 87 | set j [expr {$j + $i}] 88 | } else { 89 | set j [expr {$ir + 1}] 90 | } 91 | } 92 | lset ra $i $rra 93 | } 94 | } 95 | 96 | foreach size {10 50 100} { 97 | for {set i 1} {$i <= $size} {incr i} { 98 | set ary($i) [gen_random 1.0] 99 | } 100 | bench -desc "HEAPSORT size $size" -iter 500 \ 101 | -body {heapsort $size ary} 102 | 103 | if {[info command lset] != {}} { 104 | # 105 | # mangle the zero'th element, to keep 1-based numbering 106 | # 107 | set data [list VOID] 108 | 109 | for {set i 1} {$i <= $size} {incr i} { 110 | lappend data [gen_random 1.0] 111 | } 112 | bench -desc "HEAPSORT2 size $size" -iter 500 \ 113 | -body {heapsortLset data} 114 | } 115 | } 116 | -------------------------------------------------------------------------------- /doc/libbench.n: -------------------------------------------------------------------------------- 1 | '\" -*- nroff -*- 2 | '\" Copyright (c) 2001 by Andreas Kupries 3 | '\" All rights reserved. 4 | '\" 5 | '\" RCS: @(#) $Id$ 6 | '\" 7 | .so man.macros 8 | .TH libbench n 1.0 Libbench "Runtime support for tclbench scripts" 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | libbench \- Runtime support for tclbench scripts 13 | .SH SYNOPSIS 14 | \fBbench_tmpfile\fR 15 | .sp 16 | \fBbench_rm\fR \fIfile...\fR 17 | .sp 18 | \fBbench\fR \fI-option value ...\fR 19 | .sp 20 | .BE 21 | .SH DESCRIPTION 22 | .PP 23 | The \fBlibbench\fR provides the support commands to use in the 24 | benchmark scripts executed by the \fBtclbench\fR application. They 25 | provide functionality to portably generate names for temporary files, 26 | delete files and to declare benchmarks. 27 | .PP 28 | The public interface is made up from the following commands: 29 | .TP 30 | \fBbench_tmpfile\fR 31 | Generates names for temporary files used by benchmarks. Returns a new 32 | name for each call of the command. 33 | .TP 34 | \fBbench_rm\fR \fIfile...\fR 35 | Silently deletes all the files whose names were specified as arguments 36 | for the command. Errors during the deletion are ignored. In other 37 | words, this command does a best-effort but gives no guarantees that 38 | the files are actually rmeoved. 39 | .TP 40 | \fBbench\fR \fI-option value ...\fR 41 | Declares a benchmark to execute. Expects that the benchmark exits 42 | cleanly. In other words, errors are not caught and thrown to the 43 | top. The exceptions to this is the special errorcode 666 which 44 | declares that the accompanying string is the benchmark value instead 45 | of the time. The main use to signal missing features required by the 46 | benchmark. The following options are recognized by the command. At 47 | least the options \fI-body\fR and \fI-desc\fR are required for the 48 | correct interaction of the benchmark with the management. 49 | .RS 50 | .TP 51 | \fB-pre\fR 52 | The value of this option is a tcl script. This script is executed 53 | before the main timed body and should setup variables, files, 54 | etc. required by the benchmark. This script is not timed. 55 | .TP 56 | \fB-post\fR 57 | The value of this option is a tcl script. This script is executed 58 | after the main timed body and should be used to tear down resources 59 | setup by the \fB-pre\fR script. 60 | .TP 61 | \fB-body\fR 62 | The value of this option is a tcl script. This is the script which is 63 | run as the main body of the benchmark and its execution is timed. 64 | .TP 65 | \fB-desc\fR 66 | The value of this option is a string to be used in the output of the 67 | framework to describe the executed benchmark. Although not enforced it 68 | makes sense to make this value unique over all benchmark scripts 69 | belonging together. 70 | .TP 71 | \fB-iterations\fR 72 | The value of this option is a positive integer number and declares how 73 | often the body should be executed to get accurate timing results. This 74 | is a maximum value which can be overidden by the global management of 75 | a benchmark run. 76 | .RE 77 | .SH KEYWORDS 78 | benchmarks, tclbench, runbench, normbench 79 | -------------------------------------------------------------------------------- /tcl/file.bench: -------------------------------------------------------------------------------- 1 | # file.bench -- 2 | # 3 | 4 | # setup routines 5 | proc contents {file str} { 6 | set fp [open $file w] 7 | puts $fp $str 8 | close $fp 9 | } 10 | 11 | proc setup {dir size} { 12 | for {set i 0} {$i < $size} {incr i} { 13 | file mkdir [file join $dir _benchdir.$i] 14 | contents [file join $dir _benchdir.$i _benchfile.$i] "delete me" 15 | contents [file join $dir _benchfile.$i] "delete me" 16 | } 17 | } 18 | 19 | set file [bench_tmpfile] 20 | set dir $file.DIR 21 | file mkdir $dir 22 | setup $dir 30 23 | 24 | # test procs 25 | 26 | if {$tcl_version >= 8.3} { 27 | proc listfiles {dir ptn} { glob -nocomplain -directory $dir $ptn } 28 | } else { 29 | proc listfiles {dir ptn} { glob -nocomplain $dir/$ptn } 30 | } 31 | 32 | proc checkone {dir cmd} { 33 | foreach f [listfiles $dir *] { file $cmd $f } 34 | } 35 | proc checkstat {dir} { 36 | foreach f [listfiles $dir *] { file stat $f var } 37 | } 38 | 39 | set FCMDS [list \ 40 | atime dirname executable exists extension isdirectory \ 41 | isfile mtime owned readable rootname size tail writable \ 42 | ] 43 | if {[info tclversion] >= 8.0} { 44 | lappend FCMDS attributes 45 | } 46 | proc checkall {dir} { 47 | global FCMDS 48 | foreach f [listfiles $dir *] { 49 | foreach fcmd $FCMDS { file $fcmd $f } 50 | file stat $f var 51 | } 52 | } 53 | proc recurseAndExamine {dir recurse} { 54 | foreach f [listfiles $dir *] { 55 | file stat $f arr 56 | if {$recurse && [file isdirectory $f]} { 57 | recurseAndExamine $f $recurse 58 | } 59 | } 60 | } 61 | proc recurseAndExamine4 {dir recurse} { 62 | set orig [pwd] 63 | cd $dir 64 | foreach f [glob -nocomplain *] { 65 | file stat $f arr 66 | if {$recurse && [file isdirectory $f]} { 67 | recurseAndExamine4 $f $recurse 68 | } 69 | } 70 | cd $orig 71 | } 72 | 73 | set fileBogusAsObj $file.BOGUS 74 | 75 | bench -desc "FILE exists ~" -iter 100 \ 76 | -body {file exists ~} 77 | bench -desc "FILE exists tmpfile (obj)" -iter 100 \ 78 | -body {file exists $file} 79 | bench -desc "FILE exists! tmpfile (str)" -iter 100 \ 80 | -body {file exists $file.BOGIE} 81 | bench -desc "FILE exists! tmpfile (obj)" -iter 100 \ 82 | -body {file exists $fileBogusAsObj} 83 | 84 | set num [llength [listfiles $dir *]] 85 | bench -desc "FILE glob tmpdir ($num entries)" -iter 100 \ 86 | -body {listfiles $dir *} 87 | 88 | foreach fcmd $FCMDS { 89 | bench -desc "FILE glob / $fcmd" -iter 100 \ 90 | -body {checkone $dir $fcmd} 91 | } 92 | 93 | bench -desc "FILE glob / all subcommands" -iter 100 \ 94 | -body {checkall $dir} 95 | 96 | bench -desc "FILE recurse / -dir" -iter 100 \ 97 | -body {recurseAndExamine $dir 1} 98 | 99 | bench -desc "FILE recurse / cd" -iter 100 \ 100 | -body {recurseAndExamine4 $dir 1} 101 | 102 | contents $file "exit" 103 | 104 | bench -desc "FILE exec interp" -iter 30 \ 105 | -body {exec $BENCH(INTERP) $file} 106 | 107 | contents $file "catch {package require bogus-name}; package names" 108 | 109 | bench -desc "FILE exec interp: pkg require" -iter 30 \ 110 | -body {exec $BENCH(INTERP) $file} 111 | 112 | bench_rm $file 113 | if {[catch {file delete -force $dir}] && $tcl_platform(platform) == "unix"} { 114 | catch {exec rm -rf $dir} 115 | } 116 | -------------------------------------------------------------------------------- /tcl/wordcount.bench: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/tclsh 2 | # $Id$ 3 | # http://www.bagley.org/~doug/shootout/ 4 | 5 | # this program is modified from: 6 | # http://cm.bell-labs.com/cm/cs/who/bwk/interps/pap.html 7 | # Timing Trials, or, the Trials of Timing: Experiments with Scripting 8 | # and User-Interface Languages by Brian W. Kernighan and 9 | # Christopher J. Van Wyk. 10 | # Adapted for tclbench by Jeff Hobbs 11 | 12 | if {[info tclversion] < 8.1} { 13 | proc wc1 {fid} { 14 | set nl 0 15 | set nc 0 16 | set nw 0 17 | 18 | while {[gets $fid line] >= 0} { 19 | incr nl 20 | incr nc [string length $line] 21 | incr nc 22 | regsub -all "\[^ \t\n\]+" $line {x} line 23 | incr nw [llength $line] 24 | } 25 | return "$nl $nw $nc" 26 | } 27 | 28 | proc wc2 {fid} { 29 | set nl -1; # easier than chomping last line 30 | set nc 0 31 | set nw 0 32 | 33 | while {![eof $fid]} { 34 | set data [read $fid 4095] 35 | incr nc [string length $data] 36 | # map gets rid of list sensitive characters 37 | regsub -all "\[^ \t\n\]+" $data {x} data 38 | set lines [split $data \n] 39 | incr nl [llength $lines] 40 | foreach line $lines { 41 | incr nw [llength $line] 42 | } 43 | } 44 | return "$nl $nw $nc" 45 | } 46 | 47 | proc wc3 {fid} { 48 | set nl -1; # easier than chomping last line 49 | set nc 0 50 | set nw 0 51 | 52 | while {![eof $fid]} { 53 | set data [read $fid 4095] 54 | incr nc [string length $data] 55 | regsub -all "\[^ \t\n\]+" $data {x} data 56 | incr nl [llength [split $data \n]] 57 | incr nw [llength $data] 58 | } 59 | return "$nl $nw $nc" 60 | } 61 | } else { 62 | proc wc1 {fid} { 63 | set nl 0 64 | set nc 0 65 | set nw 0 66 | 67 | while {[gets $fid line] >= 0} { 68 | incr nl 69 | incr nc [string length $line] 70 | incr nc 71 | regsub -all {\S+} $line {x} line 72 | incr nw [llength $line] 73 | } 74 | return "$nl $nw $nc" 75 | } 76 | 77 | proc wc2 {fid} { 78 | set nl -1; # easier than chomping last line 79 | set nc 0 80 | set nw 0 81 | 82 | set map [list \" x \{ x \} x \\ x] 83 | while {![eof $fid]} { 84 | # map gets rid of list sensitive characters 85 | set data [string map $map [read $fid 4095]] 86 | incr nc [string length $data] 87 | set lines [split $data \n] 88 | incr nl [llength $lines] 89 | foreach line $lines { 90 | incr nw [llength $line] 91 | } 92 | } 93 | return "$nl $nw $nc" 94 | } 95 | 96 | proc wc3 {fid} { 97 | set nl -1 ; # -1 to account for last line 98 | set nc 0 99 | set nw 0 100 | 101 | set map [list \" x \{ x \} x \\ x] 102 | while {![eof $fid]} { 103 | # map gets rid of list sensitive characters 104 | set data [string map $map [read $fid 4095]] 105 | incr nc [string length $data] 106 | incr nl [llength [split $data \n]] 107 | incr nw [llength $data] 108 | } 109 | return "$nl $nw $nc" 110 | } 111 | } 112 | 113 | set fid [open "[file dirname [info script]]/wordcount.in"] 114 | 115 | set iter 400 116 | foreach method {wc1 wc2 wc3} { 117 | if {[info commands bench] == ""} { 118 | seek $fid 0 119 | puts "${method}([$method $fid]):\ 120 | [time {seek $fid 0; $method $fid} $iter]" 121 | } else { 122 | bench -desc "WORDCOUNT $method" -iter $iter \ 123 | -body {seek $fid 0 ; $method $fid} 124 | } 125 | } 126 | -------------------------------------------------------------------------------- /doc/runbench.1: -------------------------------------------------------------------------------- 1 | '\" -*- nroff -*- 2 | '\" Copyright (c) 2001 by Andreas Kupries 3 | '\" All rights reserved. 4 | '\" 5 | '\" RCS: @(#) $Id$ 6 | '\" 7 | .so man.macros 8 | .TH runbench.tcl 1 1.0 Runbench "Tclbench application" 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | runbench.tcl \- Main application for executing benchmarks 13 | .SH SYNOPSIS 14 | \fBrunbench.tcl\fR \fI?-option value ...? ?file ...?\fR 15 | .BE 16 | .SH DESCRIPTION 17 | .PP 18 | The \fBrunbench.tcl\fR application provides the overall management for 19 | the execution of benchmarks. If no specific benchmark files are 20 | provided on the command line itself the application will use all 21 | \fI.bench\fR files in the subdirectories \fBtcl\fR and \fBtk\fR of the 22 | directory containing the application itself. If files are provided all 23 | files matching the glob pattern \fB*tk*\fR are assumed to be 24 | benchmarks for the Tk toolkit. 25 | .PP 26 | The following options are recognized by the application: 27 | .TP 28 | \fB-help\fR 29 | Causes the application to print a list of the recognized option plus 30 | short explanations of their meaning. 31 | .TP 32 | \fB-throwerrors\fR 33 | Forces the application to bubble errors up, possibly causing the benchmark 34 | run to stop. By default errors during tests are suppressed if they occur, 35 | and \fBERR\fR is noted in the output for that test. 36 | .TP 37 | \fB-iterations\fR 38 | The value of this option is a positive integer number and declares how 39 | often the body of benchmarks should be executed to get accurate timing 40 | results. This is a global maximum value which can be overidden by the 41 | individual benchmarks. 42 | .TP 43 | \fB-minversion\fR 44 | Declares the minimum version of tcl interpreters the application is 45 | allowed to use in the benchmarking. 46 | .TP 47 | \fB-maxversion\fR 48 | Declares the maximum version of tcl interpreters the application is 49 | allowed to use in the benchmarking. 50 | .TP 51 | \fB-rmatch\fR 52 | Restricts the benchmarking to benchmarks whose description matches 53 | the regexp pattern specified as the value of this option. If both 54 | \fI-match\fR and \fI-rmatch\fR are specified benchmarks have to 55 | fulfill both conditions to be executed. 56 | .TP 57 | \fB-match\fR 58 | Restricts the benchmarking to benchmarks whose description matches the 59 | glob pattern specified as the value of this option. If both 60 | \fI-match\fR and \fI-rmatch\fR are specified benchmarks have to 61 | fulfill both conditions to be executed. 62 | .TP 63 | \fB-normalize\fR 64 | Takes a version number as value and causes the application to 65 | normalize the timing values to the value of the given version. 66 | .TP 67 | \fB-notcl\fR 68 | Forces the application to skip all tcl related benchmarks. Takes no 69 | additional value. 70 | .TP 71 | \fB-notk\fR 72 | Forces the application to skip all tk related benchmarks. Takes no 73 | additional value. 74 | .TP 75 | \fB-output\fR 76 | Declares the style to use when generating the output for the 77 | benchmarks. Accepts \fBtext\fR, \fBcsv\fR and \fBlist\fR. The first 78 | value is the default. 79 | .TP 80 | \fB-paths\fR 81 | Accepts a list of paths to search for tcl interpreters. If no paths 82 | are specified the paths in the environment variable \fBPATH\fR are 83 | used. 84 | .TP 85 | \fB-verbose\fR 86 | Activates the output of interim status info. Takes no additional 87 | value. 88 | .RE 89 | .SH KEYWORDS 90 | benchmarks, tclbench, libbench, normbench 91 | -------------------------------------------------------------------------------- /tcl/fcopy.bench: -------------------------------------------------------------------------------- 1 | # -*- tcl -*- 2 | # Benchmark "fcopy" command 3 | # 4 | # RCS: @(#) $Id$ 5 | # 6 | 7 | # 1. Create a big file to copy 8 | 9 | set inFile [bench_tmpfile] 10 | set outFile [bench_tmpfile] 11 | 12 | proc makeFile {file} { 13 | # 40 chars 14 | set line "abcdefghijklmnopqrstuvwxyz01234567890123" 15 | set fid [open $file w] 16 | # 40 * 4000 = 160K 17 | for {set i 0} {$i < 4000} {incr i} { 18 | puts $fid $line 19 | } 20 | close $fid 21 | } 22 | makeFile $inFile 23 | set size "[expr {[file size $inFile] / 1024}]K" 24 | 25 | # 2. Define the procedures to benchmark. We have to distinguish pre- 26 | # and post-8.0 versions of the core. 27 | # Post-7.6 : fcopy 28 | # 7.4 - 7.6: unsupported0 29 | # Pre-7.4 : _functionality not available_ 30 | # --------------------------------------------------------- 31 | set iters 100 32 | if {[info command fcopy] != {}} { 33 | 34 | # Standard fcopy, system encoding, both sides have same encoding. 35 | proc fcopy-std {} { 36 | global inFile outFile 37 | set in [open $inFile r] 38 | set out [open $outFile w] 39 | fcopy $in $out 40 | close $in 41 | close $out 42 | return 43 | } 44 | 45 | # Binary copying, both sides have the same encoding 46 | proc fcopy-binary {} { 47 | global inFile outFile 48 | set in [open $inFile r] 49 | set out [open $outFile w] 50 | fconfigure $in -encoding binary 51 | fconfigure $out -encoding binary 52 | fcopy $in $out 53 | close $in 54 | close $out 55 | return 56 | } 57 | 58 | # Copying with different encodings set on in- and output. 59 | # Only 8.4a3+ really respects the encoding in fcopy, which slightly 60 | # skews the validity of this test across earlier versions. 61 | proc fcopy-encoding {} { 62 | global inFile outFile 63 | set in [open $inFile r] 64 | set out [open $outFile w] 65 | fconfigure $out -encoding shiftjis 66 | fcopy $in $out 67 | close $in 68 | close $out 69 | return 70 | } 71 | 72 | # 3. Run the bench 73 | # --------------------------------------------------------- 74 | 75 | # We open some dummy channels to hold all the used encodings in memory 76 | # and to avoid benchmarking how fast they are (un)loaded. 77 | 78 | set tmp1 [bench_tmpfile] 79 | set tmp2 [bench_tmpfile] 80 | set d1 [open $tmp1 w]; # no fconfigure, holds system encoding 81 | set d2 [open $tmp2 w] 82 | 83 | # Interpreter does understand -encoding ... 84 | # Skip these tests if it doesn't. 85 | if {![catch {fconfigure $d2 -encoding shiftjis}]} { 86 | bench -desc "FCOPY binary: $size" -iter $iters -body {fcopy-binary} 87 | bench -desc "FCOPY encoding: $size" -iter $iters -body {fcopy-encoding} 88 | } 89 | 90 | bench -desc "FCOPY std: $size" -iter $iters -body {fcopy-std} 91 | 92 | # 4. Cleanup 93 | 94 | catch {close $d1} 95 | bench_rm $tmp1 $tmp2 96 | 97 | } elseif {[info command unsupported0] != {}} { 98 | 99 | # Standard fcopy, system encoding, both sides have same encoding. 100 | proc fcopy-std {} { 101 | global inFile outFile 102 | set in [open $inFile r] 103 | set out [open $outFile w] 104 | unsupported0 $in $out 105 | close $in 106 | close $out 107 | return 108 | } 109 | 110 | bench -desc "FCOPY std: $size" -iter $iters -body {fcopy-std} 111 | 112 | } else { 113 | # Functionality not available. Ignore 114 | } 115 | 116 | bench_rm $inFile $outFile 117 | -------------------------------------------------------------------------------- /tk/canvas.bench: -------------------------------------------------------------------------------- 1 | proc canvas-create {w} { 2 | canvas $w 3 | destroy $w 4 | } 5 | 6 | proc draw {w {reps 10}} { 7 | $w delete all 8 | set reps [expr {$reps * 10}] 9 | for {set i 0} {$i < $reps} {incr i 10} { 10 | $w create rect 20 $i 23 [expr {$i+3}] -fill red 11 | $w create line 28 $i 35 $i -fill yellow -arrow last \ 12 | -arrowshape {3 6 3} 13 | $w create text 40 $i -text num_$i -fill black -anchor w 14 | } 15 | } 16 | 17 | proc draw-2 {w {reps 10}} { 18 | $w delete all 19 | set reps [expr {$reps * 10}] 20 | for {set i 0} {$i < $reps} {incr i 10} { 21 | $w create rect [expr {20.+1.}] [expr {$i+1.}] [expr {23.+1.}] [expr {$i+3.}] -fill red 22 | $w create line [expr {28.+1.}] $i [expr {35.+1.}] $i -fill yellow -arrow last \ 23 | -arrowshape {3 6 3} 24 | $w create text [expr {40.+1.}] $i -text num_$i -fill black -anchor w 25 | } 26 | } 27 | 28 | proc draw-3 {w {reps 10}} { 29 | $w delete all 30 | set height [winfo reqheight .c] 31 | set width [winfo reqwidth .c] 32 | set coords {} 33 | set noCoords 1024 34 | for { set x 0 } { $x < $noCoords } { incr x } { 35 | lappend coords $x 36 | lappend coords \ 37 | [expr {$height/3*sin(4*3.14*$x/$width)+$height/2}] 38 | } 39 | eval [list $w create line] $coords 40 | for { set x 0 } { $x < $reps } { incr x } { 41 | $w coords [lrange $coords [expr {$x*5}] end]; update idle 42 | } 43 | } 44 | 45 | eval destroy [winfo children .] 46 | 47 | bench -iters 500 -desc "CANVAS create" \ 48 | -body {canvas-create .c} 49 | 50 | canvas .one 51 | 52 | bench -iters 500 -desc "CANVAS create (one exists)" \ 53 | -body {canvas-create .c} 54 | 55 | bench -iters 500 -desc "CANVAS configure -bg" \ 56 | -pre {destroy .c ; canvas .c} \ 57 | -body {.c config -bg black} \ 58 | -post {destroy .c} 59 | 60 | bench -iters 500 -desc "CANVAS cget/incr -width" \ 61 | -pre {destroy .c ; canvas .c} \ 62 | -body {set width [.c cget -width] ; incr width} \ 63 | -post {destroy .c} 64 | 65 | bench -iters 500 -desc "CANVAS configure all" \ 66 | -pre {destroy .c ; canvas .c} \ 67 | -body { 68 | .c configure -background black \ 69 | -borderwidth 4 \ 70 | -closeenough 5.0 \ 71 | -confine yes \ 72 | -cursor arrow \ 73 | -height 100 \ 74 | -highlightbackground yellow \ 75 | -highlightcolor pink \ 76 | -highlightthickness 3 \ 77 | -insertbackground red \ 78 | -insertborderwidth 2 \ 79 | -insertofftime 300 \ 80 | -insertontime 200 \ 81 | -insertwidth 4 \ 82 | -relief raised \ 83 | -scrollregion {0 0 1000 1000} \ 84 | -selectbackground blue \ 85 | -selectborderwidth 2 \ 86 | -selectforeground white \ 87 | -takefocus "of course" \ 88 | -width 200 \ 89 | -xscrollcommand [list .sx set] \ 90 | -xscrollincrement 20 \ 91 | -yscrollcommand [list .sy set] \ 92 | -yscrollincrement 20 \ 93 | } \ 94 | -post {destroy .c} 95 | 96 | bench -iters 400 -desc "CANVAS simple draw 10" \ 97 | -pre {destroy .c; canvas .c} \ 98 | -body {draw .c 10} \ 99 | -post {destroy .c} 100 | 101 | bench -iters 200 -desc "CANVAS simple draw 100" \ 102 | -pre {destroy .c; canvas .c} \ 103 | -body {draw .c 100} \ 104 | -post {destroy .c} 105 | 106 | bench -iters 50 -desc "CANVAS simple draw 1000" \ 107 | -pre {destroy .c; canvas .c} \ 108 | -body {draw .c 1000} \ 109 | -post {destroy .c} 110 | 111 | bench -iters 100 -desc "CANVAS draw-3 100" \ 112 | -pre {destroy .c; canvas .c} \ 113 | -body {draw .c 100} \ 114 | -post {destroy .c} 115 | 116 | eval destroy [winfo children .] 117 | -------------------------------------------------------------------------------- /tcl/conditional.bench: -------------------------------------------------------------------------------- 1 | # Test cases with if/else/elseif 2 | proc if-1.1 {val} { 3 | if {$val == 1} { set i 0 } elseif {$val == 2} { set i 0 } else { set i 0 } 4 | if {$val == 1} { set i 0 } elseif {$val == 2} { set i 0 } else { set i 0 } 5 | if {$val == 1} { set i 0 } elseif {$val == 2} { set i 0 } else { set i 0 } 6 | } 7 | 8 | # Test cases with if/else/elseif 9 | proc if-2.1 {val v2} { 10 | if {$val == $v2} { set i 0 } else { set i 0 } 11 | if {$val == $v2} { set i 0 } else { set i 0 } 12 | if {$val == $v2} { set i 0 } else { set i 0 } 13 | } 14 | 15 | # Test cases with if/else/elseif 16 | proc if-3.1 {val} { 17 | if {$val == "abcde"} { set i 0 } elseif {$val == "fghij"} { set i 0 } else { set i 0 } 18 | if {$val == "abcde"} { set i 0 } elseif {$val == "fghij"} { set i 0 } else { set i 0 } 19 | if {$val == "abcde"} { set i 0 } elseif {$val == "fghij"} { set i 0 } else { set i 0 } 20 | } 21 | 22 | proc if-4.1 {val} { 23 | if {$val == 0} { set i 0 } elseif {$val == 1} { 24 | set i 0 25 | } elseif {$val == 2} { set i 0 } elseif {$val == 3} { 26 | set i 0 27 | } elseif {$val == 4} { set i 0 } elseif {$val == 5} { 28 | set i 0 29 | } elseif {$val == 6} { set i 0 } elseif {$val == 7} { 30 | set i 0 31 | } elseif {$val == 8} { set i 0 } elseif {$val == 9} { 32 | set i 0 33 | } else { 34 | set i 0 35 | } 36 | if {$val == 0} { set i 0 } elseif {$val == 1} { 37 | set i 0 38 | } elseif {$val == 2} { set i 0 } elseif {$val == 3} { 39 | set i 0 40 | } elseif {$val == 4} { set i 0 } elseif {$val == 5} { 41 | set i 0 42 | } elseif {$val == 6} { set i 0 } elseif {$val == 7} { 43 | set i 0 44 | } elseif {$val == 8} { set i 0 } elseif {$val == 9} { 45 | set i 0 46 | } else { 47 | set i 0 48 | } 49 | } 50 | 51 | # a check on the efficiency of if 1 { ... } 52 | proc if-1 {repeat} { 53 | if 1 { incr repeat -1 } 54 | if 0 { incr repeat -1 } 55 | if 1 { incr repeat -1 } 56 | if 0 { incr repeat -1 } 57 | } 58 | 59 | # Test cases with switch/case 60 | proc switch-1.1 {val} { 61 | switch -exact -- $val { 62 | 0 { set i 0 } 1 { set i 0 } 2 { set i 0 } 63 | 3 { set i 0 } 4 { set i 0 } 5 { set i 0 } 64 | 6 { set i 0 } 7 { set i 0 } 8 { set i 0 } 65 | 9 { set i 0 } 66 | default { set i 0 } 67 | } 68 | switch -exact -- $val { 69 | 0 { set i 0 } 1 { set i 0 } 2 { set i 0 } 70 | 3 { set i 0 } 4 { set i 0 } 5 { set i 0 } 71 | 6 { set i 0 } 7 { set i 0 } 8 { set i 0 } 72 | 9 { set i 0 } 73 | default { set i 0 } 74 | } 75 | } 76 | 77 | bench -desc "IF if true numeric" -body {if-1.1 1} 78 | bench -desc "IF elseif true numeric" -body {if-1.1 2} 79 | bench -desc "IF else true numeric" -body {if-1.1 3} 80 | 81 | bench -desc "IF if true num/num" -body {if-2.1 12345 12345} 82 | bench -desc "IF if false num/num" -body {if-2.1 12345 67890} 83 | bench -desc "IF if false al/num" -body {if-2.1 12345 hello} 84 | bench -desc "IF if true al/al" -body {if-2.1 abcde abcde} 85 | bench -desc "IF if false al/al" -body {if-2.1 abcde fghij} 86 | 87 | bench -desc "IF if true al" -body {if-3.1 abcde} 88 | bench -desc "IF elseif true al" -body {if-3.1 fghij} 89 | bench -desc "IF else true al" -body {if-3.1 klmno} 90 | 91 | bench -desc "IF multi 1st true" -body {if-4.1 1} 92 | bench -desc "IF multi 2nd true" -body {if-4.1 2} 93 | bench -desc "IF multi 9th true" -body {if-4.1 9} 94 | bench -desc "IF multi default true" -body {if-4.1 99} 95 | 96 | bench -desc "IF 1/0 check" -body {if-1 0} 97 | 98 | bench -desc "SWITCH 1st true" -body {switch-1.1 1} 99 | bench -desc "SWITCH 2nd true" -body {switch-1.1 2} 100 | bench -desc "SWITCH 9th true" -body {switch-1.1 9} 101 | bench -desc "SWITCH default true" -body {switch-1.1 99} 102 | -------------------------------------------------------------------------------- /tcl/encoding.bench: -------------------------------------------------------------------------------- 1 | if {[catch {package require Tcl 8.1}]} { 2 | # We need the unicode support for these. 3 | return 4 | } 5 | 6 | # Read a file using gets 7 | proc read-gets {enc filename} { 8 | set fp [open $filename r] 9 | fconfigure $fp -encoding $enc 10 | while {[gets $fp line] != -1} {} 11 | close $fp 12 | return $line ; # just last line 13 | } 14 | 15 | # Read a file using read only 16 | proc read-read {enc filename} { 17 | set fp [open $filename r] 18 | fconfigure $fp -encoding $enc 19 | set data [read -nonewline $fp] 20 | close $fp 21 | return $data 22 | } 23 | 24 | # Read a file using read and [file size] 25 | proc read-read-size {enc filename} { 26 | set fp [open $filename r] 27 | fconfigure $fp -encoding $enc 28 | set data [read $fp [file size $filename]] 29 | close $fp 30 | return $data 31 | } 32 | 33 | set ::iso2022data "\u001b\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\u001b(B 34 | \u001b\$B>.@Z.@Z 0 } { 122 | seek $fp $start 123 | } 124 | 125 | seek $fp $end 126 | set form($name) "FILE $start $end" 127 | 128 | } else { 129 | # ordinary field - read lines until next boundary 130 | set first 1 131 | set value "" 132 | set start [tell $fp] 133 | 134 | while { [gets $fp line] >= 0 } { 135 | set line [string trimright $line \r] 136 | if {[string match $boundary* $line]} { 137 | break 138 | } 139 | if {$first} { 140 | set first 0 141 | } else { 142 | append value \n 143 | } 144 | append value $line 145 | set start [tell $fp] 146 | } 147 | seek $fp $start 148 | set form($name) $value 149 | } 150 | } 151 | return [array get form] 152 | } 153 | 154 | set iter 20 155 | bench -iter $iter -desc "PARSE html form upload ([file size $::SMALLFILE])" \ 156 | -body {ns_getform $::SMALLFILE} 157 | bench -iter $iter -desc "PARSE html form upload ([file size $::LARGEFILE])" \ 158 | -body {ns_getform $::LARGEFILE} 159 | 160 | bench_rm $::LARGEFILE $::SMALLFILE 161 | -------------------------------------------------------------------------------- /tcl/read.bench: -------------------------------------------------------------------------------- 1 | # Read a file using gets 2 | proc read-gets {filename {trans {}}} { 3 | set fp [open $filename r] 4 | if {[string compare $trans {}] && ([info tclversion] > 8.0)} { 5 | fconfigure $fp -translation $trans 6 | } 7 | while {[gets $fp line] != -1} { 8 | set x $line 9 | } 10 | close $fp 11 | } 12 | 13 | # Read a file using gets and check line-by-line for a search term 14 | proc read-gets-match {filename term {trans {}}} { 15 | set fp [open $filename r] 16 | if {[string compare $trans {}] && ([info tclversion] > 8.0)} { 17 | fconfigure $fp -translation $trans 18 | } 19 | while {[gets $fp line] != -1} { 20 | if {[string match $term $line]} { 21 | set x $line 22 | } 23 | } 24 | close $fp 25 | } 26 | 27 | # Read a file using read only 28 | proc read-read {filename {trans {}}} { 29 | set fp [open $filename r] 30 | if {[string compare $trans {}] && ([info tclversion] > 8.0)} { 31 | fconfigure $fp -translation $trans 32 | } 33 | set x [read $fp] 34 | close $fp 35 | } 36 | 37 | proc read-cat {file {trans {}}} { 38 | global tcl_platform 39 | set f [open $file r] 40 | if {$tcl_platform(platform) == "windows"} { 41 | set outf [open NUL: w] 42 | } else { 43 | set outf [open /dev/null w] 44 | } 45 | if {[string compare $trans {}] && ([info tclversion] > 8.0)} { 46 | fconfigure $f -translation $trans 47 | fconfigure $outf -translation $trans -buffering full 48 | } 49 | set buf "" 50 | while {[gets $f buf] >= 0} { puts $outf $buf } 51 | close $f 52 | close $outf 53 | } 54 | 55 | # Read a file using read and [file size] 56 | proc read-read-size {filename {trans {}}} { 57 | set fp [open $filename r] 58 | if {[string compare $trans {}] && ([info tclversion] > 8.0)} { 59 | fconfigure $fp -translation $trans 60 | } 61 | set x [read $fp [file size $filename]] 62 | close $fp 63 | } 64 | 65 | # Read a file using read only, and a small buffersize 66 | proc read-read-10 {filename {trans {}}} { 67 | set fp [open $filename r] 68 | fconfigure $fp -buffersize 10 69 | if {[string compare $trans {}] && ([info tclversion] > 8.0)} { 70 | fconfigure $fp -translation $trans 71 | } 72 | set x [read $fp] 73 | close $fp 74 | } 75 | 76 | # Read a file using read only, and a dynamically changing buffersize 77 | proc read-read-dyn {filename {trans {}}} { 78 | set fp [open $filename r] 79 | fconfigure $fp -buffersize 10 80 | if {[string compare $trans {}] && ([info tclversion] > 8.0)} { 81 | fconfigure $fp -translation $trans 82 | } 83 | read $fp 2 84 | fconfigure $fp -buffersize 4096 85 | set x [read $fp] 86 | close $fp 87 | } 88 | 89 | if {[info tclversion] < 8.3} { 90 | # XXX - these send 8.0 into an endless loop, and 8.2 crashes on them. 91 | proc read-read-10 {args} { return -code 666 "8.3+" } 92 | proc read-read-dyn {args} { return -code 666 "8.3+" } 93 | } 94 | 95 | proc makeFiles {largeFile smallFile} { 96 | # 60 chars 97 | set line "012345678901234567890123456789012345678901234567890123456789" 98 | 99 | set largeFid [open $largeFile w] 100 | # 60 * 10000 = 595K 101 | for {set i 0} {$i < 10000} {incr i} { 102 | puts $largeFid $line 103 | } 104 | close $largeFid 105 | 106 | set smallFid [open $smallFile w] 107 | # 60 * 50 = <3K 108 | for {set i 0} {$i < 50} {incr i} { 109 | puts $smallFid $line 110 | } 111 | close $smallFid 112 | } 113 | 114 | set largeFile [bench_tmpfile].lrg 115 | set smallFile [bench_tmpfile].sml 116 | makeFiles $largeFile $smallFile 117 | set large "[expr {[file size $largeFile]/1024}]K" 118 | set small "[file size $smallFile]b" 119 | 120 | foreach {fsize fname iters} [list $large $largeFile 35 $small $smallFile 70] { 121 | foreach {trans desc} {binary { bin} {} {}} { 122 | set desc "READ$desc $fsize," 123 | bench -iter $iters -desc "$desc cat" \ 124 | -body [list read-cat $fname $trans] 125 | bench -iter $iters -desc "$desc gets" \ 126 | -body [list read-gets $fname $trans] 127 | bench -iter $iters -desc "$desc read" \ 128 | -body [list read-read $fname $trans] 129 | bench -iter $iters -desc "$desc read & size" \ 130 | -body [list read-read-size $fname $trans] 131 | bench -iter $iters -desc "$desc read small buf" \ 132 | -body [list read-read-10 $fname $trans] 133 | bench -iter $iters -desc "$desc read dyn buf" \ 134 | -body [list read-read-dyn $fname $trans] 135 | bench -iter $iters -desc "$desc glob-grep match" \ 136 | -body [list read-gets-match $fname "*0123456789*" $trans] 137 | bench -iter $iters -desc "$desc glob-grep nomatch" \ 138 | -body [list read-gets-match $fname "*nomatchterm*" $trans] 139 | } 140 | } 141 | 142 | bench_rm $largeFile $smallFile 143 | -------------------------------------------------------------------------------- /tcl/map.bench: -------------------------------------------------------------------------------- 1 | # 2 | # RCS: @(#) $Id$ 3 | # 4 | 5 | if { [catch {string map {a b} "abc"}] } { 6 | proc map-str {str nocase args} { return -code 666 "nomap" } 7 | } else { 8 | proc map-str {str nocase mapChars} { 9 | if {[string equal "-nocase" $nocase]} { 10 | return [string map -nocase $mapChars $str] 11 | } else { 12 | return [string map $mapChars $str] 13 | } 14 | } 15 | } 16 | 17 | if {[info tclversion] < 7.5} { 18 | proc map-regsub {str nocase mapChars} { 19 | while {$mapChars != ""} { 20 | set exp [lindex $mapChars 0] 21 | set subspec [lindex $mapChars 1] 22 | set mapChars [lrange $mapChars 2 end] 23 | regsub -all $nocase $exp $str $subspec str 24 | } 25 | set str 26 | } 27 | } else { 28 | proc map-regsub {str nocase mapChars} { 29 | foreach {exp subspec} $mapChars { 30 | regsub -all $nocase $exp $str $subspec str 31 | } 32 | set str 33 | } 34 | } 35 | 36 | proc map-regsub-2 {exp str subspec} { 37 | regsub -all -- $exp $str $subspec str 38 | set str 39 | } 40 | 41 | ## This code is taken from the http library 42 | ## 43 | set alphanumeric a-zA-Z0-9 44 | proc init {} { 45 | global formMap alphanumeric 46 | for {set i 0} {$i <= 256} {incr i} { 47 | set c [format %c $i] 48 | if {![string match \[$alphanumeric\] $c]} { 49 | set formMap($c) %[format %.2x $i] 50 | } 51 | } 52 | # These are handled specially 53 | array set formMap { " " + \n %0d%0a } 54 | } 55 | init 56 | proc mapReply {string} { 57 | global formMap alphanumeric 58 | 59 | regsub -all \[^$alphanumeric\] $string {$formMap(&)} string 60 | regsub -all {[][{})\\]\)} $string {\\&} string 61 | return [subst -nocommand $string] 62 | } 63 | 64 | set longString "" 65 | for {set i 0} {$i < 200} {incr i} { 66 | append longString "abcdefghijklmnopqrstuvwxyz01234567890123" 67 | } 68 | for {set i 0} {$i < 200} {incr i} { 69 | append ustring "abcdefghijklmnopqrstuvwxyz0123456789012\374" 70 | } 71 | append longString 0987654321 72 | 73 | set iters 300 74 | bench -iter $iters -desc "MAP string 1 val" \ 75 | -body {map-str $longString -- {a at}} 76 | bench -iter $iters -desc "MAP string 2 val" \ 77 | -body {map-str $longString -- {a at 0123 0}} 78 | bench -iter $iters -desc "MAP string 3 val" \ 79 | -body {map-str $longString -- {a at 0123 0 456 4}} 80 | bench -iter $iters -desc "MAP string 4 val" \ 81 | -body {map-str $longString -- {a at 0123 0 456 4 jkl k}} 82 | bench -iter $iters -desc "MAP string 1 val -nocase" \ 83 | -body {map-str $longString -nocase {A at}} 84 | bench -iter $iters -desc "MAP string 2 val -nocase" \ 85 | -body {map-str $longString -nocase {A at 0123 0}} 86 | bench -iter $iters -desc "MAP string 3 val -nocase" \ 87 | -body {map-str $longString -nocase {A at 0123 0 456 4}} 88 | bench -iter $iters -desc "MAP string 4 val -nocase" \ 89 | -body {map-str $longString -nocase {A at 0123 0 456 4 jkl k}} 90 | 91 | bench -iter $iters -desc "MAP regsub 1 val" \ 92 | -body {map-regsub $longString -- {a at}} 93 | bench -iter $iters -desc "MAP regsub 2 val" \ 94 | -body {map-regsub $longString -- {a at 0123 0}} 95 | bench -iter $iters -desc "MAP regsub 3 val" \ 96 | -body {map-regsub $longString -- {a at 0123 0 456 4}} 97 | bench -iter $iters -desc "MAP regsub 4 val" \ 98 | -body {map-regsub $longString -- {a at 0123 0 456 4 jkl k}} 99 | bench -iter $iters -desc "MAP regsub 1 val -nocase" \ 100 | -body {map-regsub $longString -nocase {A at}} 101 | bench -iter $iters -desc "MAP regsub 2 val -nocase" \ 102 | -body {map-regsub $longString -nocase {A at 0123 0}} 103 | bench -iter $iters -desc "MAP regsub 3 val -nocase" \ 104 | -body {map-regsub $longString -nocase {A at 0123 0 456 4}} 105 | bench -iter $iters -desc "MAP regsub 4 val -nocase" \ 106 | -body {map-regsub $longString -nocase {A at 0123 0 456 4 jkl k}} 107 | 108 | bench -iter $iters -desc "MAP string, no match" \ 109 | -body {map-str $longString -- {=! != qwerty uiop}} \ 110 | -result $longString 111 | bench -iter $iters -desc "MAP string -nocase, no match" \ 112 | -body {map-str $longString -nocase {=! != QWERTY uiop}} \ 113 | -result $longString 114 | 115 | bench -iter $iters -desc "MAP regsub, no match" \ 116 | -body {map-regsub $longString -- {=! != qwerty uiop}} \ 117 | -result $longString 118 | bench -iter $iters -desc "MAP regsub -nocase, no match" \ 119 | -body {map-regsub $longString -nocase {=! != QWERTY uiop}} \ 120 | -result $longString 121 | 122 | bench -iter $iters -desc "MAP string short" \ 123 | -body {map-str "a b c d e f g h " -- {{ } +}} 124 | bench -iter $iters -desc "MAP regsub short" \ 125 | -body {map-regsub "a b c d e f g h " -- {{ } +}} 126 | 127 | bench -iter $iters -desc "MAP |-case regsub" \ 128 | -body {map-regsub-2 "foo|bar|baz" "food in bars is bazzy" "OY"} 129 | 130 | bench -iter $iters -desc "MAP |-case strmap" \ 131 | -body {map-str "food in bars is bazzy" -- {foo OY bar OY baz OY}} 132 | 133 | bench -iter $iters -desc "MAP (\[chars\])-case regsub" \ 134 | -body {map-regsub-2 {([0-9])} "1 hav3 gr8t s0ftw33rz!" {\\&}} 135 | 136 | set fid [open [info script]] 137 | set data [read $fid] 138 | close $fid 139 | 140 | bench -iter 50 -desc "MAP http mapReply" \ 141 | -body {mapReply $data} 142 | -------------------------------------------------------------------------------- /tcl/expr.bench: -------------------------------------------------------------------------------- 1 | proc expr-unbraced {a} { 2 | set b 23 3 | set c 4 4 | set d 6 5 | set e 7 6 | expr $a*$b+log($c)-pow($d,$e) 7 | expr $a*$b+log($c)-pow($d,$e) 8 | } 9 | proc expr-braced {a} { 10 | set b 23 11 | set c 4 12 | set d 6 13 | set e 7 14 | expr {$a*$b+log($c)-pow($d,$e)} 15 | expr {$a*$b+log($c)-pow($d,$e)} 16 | } 17 | proc expr-unbraced-long {a op} { 18 | expr $a $op $a $op $a $op $a $op $a $op $a $op $a $op $a $op $a $op $a \ 19 | $op $a $op $a $op $a $op $a $op $a $op $a $op $a $op $a $op $a \ 20 | $op $a $op $a * 2 $op $a $op $a $op $a $op $a $op $a $op $a $op $a \ 21 | $op $a $op $a * 2 $op $a $op $a $op $a $op $a $op $a $op $a $op $a \ 22 | $op $a $op $a * 2 $op $a $op $a $op $a $op $a $op $a $op $a $op $a \ 23 | $op $a $op $a * 2 $op $a $op $a $op $a $op $a $op $a $op $a $op $a \ 24 | $op $a $op $a * 2 $op $a $op $a $op $a $op $a $op $a $op $a $op $a \ 25 | $op $a $op $a $op $a $op $a $op $a $op $a $op $a $op $a $op 1 26 | } 27 | 28 | proc expr-3.1 {a} { 29 | expr {$a} 30 | } 31 | proc expr-3.2 {a} { 32 | expr {$a + $a + $a + $a + $a + $a + $a + $a + $a + $a} 33 | } 34 | proc expr-3.3 {a} { 35 | expr {$a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a + $a} 36 | } 37 | 38 | proc expr-incr-incr {value} { 39 | incr value 40 | } 41 | proc expr-incr-expr {value} { 42 | expr {$value + 1} 43 | } 44 | proc expr-streq {a b} { 45 | expr {$a == $b}; expr {$a == $b}; expr {$a == $b}; expr {$a == $b} 46 | } 47 | proc expr-strneq {a b} { 48 | expr {$a != $b}; expr {$a != $b}; expr {$a != $b}; expr {$a != $b} 49 | } 50 | proc expr-int {val} { 51 | expr {int($val)} 52 | expr {int($val)} 53 | } 54 | proc expr-dbl {val} { 55 | expr {double($val)} 56 | expr {double($val)} 57 | } 58 | proc expr-rand-fun {rng} { 59 | expr {int([rand]*$rng)} 60 | expr {int([rand]*$rng)} 61 | } 62 | proc rand {} { return 0.5 } 63 | proc expr-rand {rng} { 64 | expr {int(rand()*$rng)} 65 | expr {int(rand()*$rng)} 66 | } 67 | proc expr-builtin {} { 68 | expr {sin(0.50)} 69 | expr {sin(0.50)} 70 | } 71 | proc expr-builtin-dyn {fun val} { 72 | expr ${fun}($val) 73 | expr ${fun}($val) 74 | } 75 | proc expr-UpdateStringOfDouble {} { 76 | # 8.5 slowdown caused by UpdateStringOfDouble: http://tip.tcl.tk/132 77 | # 8.6 performance patched 2010-11-28, 8.5 2010-11-30 78 | set moo [expr {double(1.234)}] 79 | set cow "moo $moo" 80 | } 81 | proc expr-USoD2 {} { 82 | # 8.5 slowdown caused by UpdateStringOfDouble: http://tip.tcl.tk/132 83 | # 8.6 performance patched 2010-11-28, 8.5 2010-11-30 84 | set moo [expr {double(1e27)}] 85 | set cow "moo $moo" 86 | } 87 | proc expr-USoD3 {} { 88 | # 8.5 slowdown caused by UpdateStringOfDouble: http://tip.tcl.tk/132 89 | # 8.6 performance patched 2010-11-28, 8.5 2010-11-30 90 | set moo [expr {double(0.000123)}] 91 | set cow "moo $moo" 92 | } 93 | 94 | 95 | if { [catch {string repeat "abc" 10}] } { 96 | proc str-repeat {str num} { 97 | set val {} 98 | for {set i 0} {$i < $num} {incr i} { append val $str } 99 | return $val 100 | } 101 | } else { 102 | proc str-repeat {str num} { string repeat $str $num } 103 | } 104 | set base [str-repeat a 100] 105 | set str1 "$base abc" 106 | set str2 "$base cde" 107 | set str3 "$base f" 108 | 109 | bench -desc "EXPR \$a == \$b str (== len)" -body {expr-streq $str1 $str2} 110 | bench -desc "EXPR \$a != \$b str (== len)" -body {expr-strneq $str1 $str2} 111 | bench -desc "EXPR \$a == \$b str (!= len)" -body {expr-streq $str1 $str3} 112 | bench -desc "EXPR \$a != \$b str (!= len)" -body {expr-strneq $str1 $str3} 113 | bench -desc "EXPR \$a == \$b int" -body {expr-streq 100 200} 114 | bench -desc "EXPR \$a != \$b int" -body {expr-strneq 100 200} 115 | bench -desc "EXPR \$a == \$b dbl" -body {expr-streq 100.0 200.0} 116 | bench -desc "EXPR \$a != \$b dbl" -body {expr-strneq 100.0 200.0} 117 | 118 | bench -desc "EXPR unbraced" -body {expr-unbraced 12} 119 | bench -desc "EXPR unbraced long" -body {expr-unbraced-long 13 +} 120 | bench -desc "EXPR braced" -body {expr-braced 12} 121 | bench -desc "EXPR inline" -body { 122 | set a 12 123 | set b 23 124 | set c 4 125 | set d 6 126 | set e 7 127 | expr {$a*$b+log($c)-pow($d,$e)} 128 | } 129 | bench -body {expr-3.1 1} -desc "EXPR one operand" 130 | bench -body {expr-3.2 1} -desc "EXPR ten operands" 131 | bench -body {expr-3.3 1} -desc "EXPR fifty operands" 132 | bench -body {expr-incr-incr 1} -desc "EXPR incr with incr" 133 | bench -body {expr-incr-expr 1} -desc "EXPR incr with expr" 134 | 135 | bench -body {expr-int 100.0} -desc "EXPR cast int" 136 | bench -body {expr-dbl 100} -desc "EXPR cast double" 137 | if {$tcl_version >= 8.0} { 138 | bench -body {expr-rand 100} -desc "EXPR rand range" 139 | } 140 | bench -body {expr-rand-fun 100} -desc "EXPR rand range func" 141 | bench -body {expr-builtin} -desc "EXPR builtin sin" 142 | bench -body {expr-builtin-dyn cos 0.5} -desc "EXPR builtin dyn" 143 | 144 | foreach val {0 12 17} { 145 | if {![catch {set tcl_precision $val}]} { 146 | bench -body { expr-UpdateStringOfDouble } \ 147 | -desc "EXPR UpdStrOfDbl+1.23 prec$tcl_precision" 148 | bench -body { expr-USoD2 } \ 149 | -desc "EXPR UpdStrOfDbl+1e27 prec$tcl_precision" 150 | bench -body { expr-USoD3 } \ 151 | -desc "EXPR UpdStrOfDbl+1e-4 prec$tcl_precision" 152 | unset tcl_precision 153 | } 154 | } 155 | -------------------------------------------------------------------------------- /tcl/eval.bench: -------------------------------------------------------------------------------- 1 | proc e-cmd {val} { 2 | set cmd [list set val $val] 3 | eval $cmd 4 | eval $cmd 5 | eval $cmd 6 | } 7 | 8 | proc e-cmd-expand {val} { 9 | set cmd [list set val $val] 10 | {*}$cmd 11 | {*}$cmd 12 | {*}$cmd 13 | } 14 | if {[info tclversion] < 8.5} { 15 | proc e-cmd-expand {string} { return -code 666 "8.5+" } 16 | } 17 | 18 | proc e-list val { 19 | eval [list set val $val] 20 | } 21 | 22 | proc e-str val { 23 | eval set val [list $val] 24 | } 25 | 26 | proc eval-std {l1} { 27 | eval list $l1 28 | } 29 | 30 | proc eval-list {l1} { 31 | eval [list list] $l1 32 | } 33 | 34 | proc uplevel-std {l1} { 35 | uplevel 1 list $l1 36 | } 37 | 38 | proc uplevel-list {l1} { 39 | uplevel 1 [list list] $l1 40 | } 41 | 42 | proc makeLists {{size 1000}} { 43 | global Sobj Lobj LSobj 44 | set Sobj "" 45 | set Lobj [list] 46 | set LSobj [list] 47 | for {set i 0} {$i < $size} {incr i} { 48 | append Sobj "$i " 49 | lappend Lobj $i 50 | lappend LSobj $i 51 | } 52 | string length $LSobj 53 | } 54 | 55 | proc makeListOfLists {{size 1000}} { 56 | set LLobj [list] 57 | for {set i 0} {$i<$size} {incr i} { 58 | lappend LLobj [list $i $i] 59 | } 60 | return $LLobj 61 | } 62 | 63 | set iter 1000 64 | bench -iter $iter -desc "EVAL cmd eval in list obj var" \ 65 | -body {e-cmd val} 66 | bench -iter $iter -desc "EVAL cmd eval in list obj {*}" \ 67 | -body {e-cmd-expand val} 68 | bench -iter $iter -desc "EVAL cmd eval as list" \ 69 | -body {e-list val} 70 | bench -iter $iter -desc "EVAL cmd eval as string" \ 71 | -body {e-str val} 72 | 73 | set iter 300 74 | makeLists 75 | bench -iter $iter -desc "EVAL cmd and mixed lists" \ 76 | -body {eval-std $LSobj} 77 | bench -iter $iter -desc "EVAL list cmd and mixed lists" \ 78 | -body {eval-list $LSobj} 79 | bench -iter $iter -desc "EVAL list cmd and pure lists" \ 80 | -body {eval-list $Lobj} 81 | 82 | return 83 | 84 | set ll [makeListOfLists] 85 | time {eval [list concat] $ll} 1000 86 | 87 | proc lassign {valueList args} { 88 | if {[llength $valueList] == 0} { 89 | set valueList [list {}] 90 | } 91 | uplevel 1 [list foreach $args $valueList {break}] 92 | return [lrange $valueList [llength $args] end] 93 | } 94 | proc makeList {{size 10000}} { 95 | for {set i 0} {$i<$size} {incr i} {lappend l $i} 96 | } 97 | catch {makeList 100} list 98 | time {lassign $list a b c d e f g h i j k l m n o p q} 1000 99 | 100 | proc do {body while cond} { 101 | if {[string compare while $while]} { 102 | return -code error "usage: do body while condition" 103 | } 104 | while {1} { 105 | uplevel 1 $body 106 | if {![uplevel 1 [list expr $cond]]} { break } 107 | } 108 | } 109 | 110 | proc foo {i} { 111 | do { set a $i } while { [incr i] < 1000 } 112 | } 113 | 114 | time {set i 0; do { set a $i } while { [incr i] < 1000 }} 100 115 | time {foo 0} 100 116 | 117 | % time {eval $cmd} 50000 118 | 12 microseconds per iteration 119 | % time {eval set a 0} 10000 120 | 40 microseconds per iteration 121 | % time {eval set a 0} 50000 122 | 79 microseconds per iteration 123 | % time {eval set a 0} 40000 124 | 78 microseconds per iteration 125 | % time {eval set a 0} 40000 126 | 73 microseconds per iteration 127 | % time {eval [list set a 0]} 40000 128 | 84 microseconds per iteration 129 | % set cmd {set a 0} 130 | set a 0 131 | % time {eval $cmd} 40000 132 | 13 microseconds per iteration 133 | % time {eval [list set a 0]} 40000 134 | 91 microseconds per iteration 135 | % time {eval $cmd} 40000 136 | 12 microseconds per iteration 137 | % time {eval $cmd} 40000 138 | 12 microseconds per iteration 139 | % time {eval {set a 0}} 40000 140 | 9 microseconds per iteration 141 | % time {eval {set a 0}} 40000 142 | 9 microseconds per iteration 143 | % time [list eval {set a 0}] 40000 144 | 9 microseconds per iteration 145 | % time [list eval [list set a 0]] 40000 146 | 9 microseconds per iteration 147 | % time {eval {set a 0}} 40000 148 | 9 microseconds per iteration 149 | % time {eval [list set a 0]} 40000 150 | 48 microseconds per iteration 151 | % time {eval [list set a 0]} 40000 152 | 48 microseconds per iteration 153 | % proc e {cmd} { eval $cmd } 154 | % proc e args { eval $args } 155 | % time {e set a 0} 10000 156 | 157 | % for {set i 0} {$i<10000} {incr i} {lappend l $i}; llength $l 158 | 10000 159 | ### The first case shows the power of the Tcl_EvalObjEx recognizing 160 | ### the list by itself. Yet's, that's a 40x speed increase. 161 | % time {eval [linsert $l 0 list]} 1000 162 | 3477 microseconds per iteration 163 | ### This case shows the advantage of making Tcl_ConcatObj list aware. 164 | ### 'eval' will pass multiple args through it before passing them on 165 | ### to Tcl_EvalObjEx. 166 | % time {eval [list list] $l} 1000 167 | 3490 microseconds per iteration 168 | ### The next case shows the advantage of Tcl_EvalObjEx for 'uplevel'. 169 | ### Note that this only works in the case where uplevel is used like: 170 | ### uplevel 171 | ### because the first arg will be checked as a string anyway for 172 | ### getting the optional level (this could possibly be further opt'ed) 173 | ### and if you pass more args, it uses TCL_EVAL_DIRECT, which is a 174 | ### special case that doesn't gen byte code and makes it a string anyway 175 | % proc foo {l} { uplevel 1 [linsert $l 0 list] } 176 | % time {foo $l} 1000 177 | 3338 microseconds per iteration 178 | ### Here's a simple case where the eval breaks down again. This will 179 | ### go through Tcl_ConcatObj, but the first item is a string, so we 180 | ### get a string obj back 181 | % time {eval list $l} 100 182 | 122301 microseconds per iteration 183 | ### So here's the case we used above. But why doesn't it work this 184 | ### time? Because now $l has a string rep (due to last case), and 185 | ### this opt is not valid in such cases (because we can't tell from 186 | ### an object whether it started off as a string or a list). 187 | % time {eval [list list] $l} 100 188 | 116890 microseconds per iteration 189 | ### But convert it back to a list and you see the speed demons at 190 | ### work again. 191 | % catch {lappend l b} 192 | 0 193 | % time {eval [list list] $l} 100 194 | 3513 microseconds per iteration 195 | -------------------------------------------------------------------------------- /tcl/regexp.bench: -------------------------------------------------------------------------------- 1 | # 2 | # RCS: @(#) $Id$ 3 | # 4 | 5 | # Literal regular expresion 6 | proc regexp-1.1 {string} { 7 | regexp "^abc(.*)jkl(.*)" $string 8 | } 9 | 10 | # Variable based regexp 11 | proc regexp-str-exp {string exp} { 12 | regexp $exp $string 13 | } 14 | 15 | # Static regexp 16 | proc regexp-str-static {string} { 17 | regexp "bcd" $string 18 | } 19 | 20 | # Static left anchor regexp 21 | proc regexp-str-static-lanchor {string} { 22 | regexp "^foo" $string 23 | } 24 | 25 | # Static right anchor regexp 26 | proc regexp-str-static-ranchor {string} { 27 | regexp {bar$} $string 28 | } 29 | 30 | # Static anchored regexp 31 | proc regexp-str-static-anchor {string} { 32 | regexp {^foobar$} $string 33 | } 34 | 35 | # Static anchored regexp 36 | proc regexp-str-static-anchor-dot {string} { 37 | regexp {^fo.bar$} $string 38 | } 39 | 40 | # Variable based regexp with catching 41 | proc regexp-catch {string exp} { 42 | if {[regexp $exp $string match one two three]} { 43 | list $match $one $two $three 44 | } 45 | } 46 | 47 | if { [catch {regexp -all "abc" "abc"}] } { 48 | proc regexp-count {string exp} { 49 | set len [string len $string] 50 | set ind 0 51 | set count 0 52 | while { $ind < $len } { 53 | if { [regexp -indices $exp \ 54 | [string range $string $ind end] res] } { 55 | set start [lindex $res 0] 56 | set end [lindex $res 1] 57 | if { $end < $start } { 58 | set end $start 59 | } 60 | set ind [expr {$end + 1 + $ind}] 61 | incr count 62 | } 63 | } 64 | set count 65 | } 66 | proc regexp-extract {string exp} { 67 | set len [string len $string] 68 | set ind 0 69 | set result {} 70 | while { $ind < $len } { 71 | if { [regexp -indices $exp \ 72 | [string range $string $ind end] res] } { 73 | set start [lindex $res 0] 74 | set end [lindex $res 1] 75 | if { $end < $start } { 76 | set end $start 77 | } 78 | lappend result [string range $string \ 79 | [expr {$start + $ind}] [expr {$end + $ind}]] 80 | set ind [expr {$end + 1 + $ind}] 81 | } 82 | } 83 | set result 84 | } 85 | } else { 86 | proc regexp-count {string exp} { 87 | regexp -all $exp $string 88 | } 89 | proc regexp-extract {string exp} { 90 | regexp -all -inline $exp $string 91 | } 92 | } 93 | 94 | if { [catch {string repeat "abc" 10}] } { 95 | proc str-repeat {str num} { 96 | set val {} 97 | for {set i 0} {$i < $num} {incr i} { 98 | append val $str 99 | } 100 | set val 101 | } 102 | } else { 103 | proc str-repeat {str num} { 104 | string repeat $str $num 105 | } 106 | } 107 | 108 | set string "abcdefghijklmnopqrstuvwxyz" 109 | set exp "^abc(.*)jkl(.*)" 110 | bench -desc "RE literal regexp" -body {regexp-1.1 $string} 111 | bench -desc "RE var-based regexp" -body {regexp-str-exp $string $exp} 112 | bench -desc "RE count all matches" \ 113 | -body {regexp-count "abcabcabcabcabcabc" "abc"} 114 | bench -desc "RE extract all matches" \ 115 | -body {regexp-extract "abcabcabcabcabcabc" "abc"} 116 | 117 | # See bug 1452969 118 | set inifile "choices=[str-repeat mx 1000]" 119 | bench -desc "RE ini file" -iters 30 \ 120 | -body {regexp-catch $inifile {^(.*)=(.*)$}} 121 | if {[info tclversion] > 8.0} { 122 | bench -desc "RE ini file ng" -iters 100 \ 123 | -body {regexp-catch $inifile {^(.*?)=(.*)$}} 124 | } 125 | 126 | set cCommentUnopt {/\*([^*]|\*+[^/*])*\*+/} 127 | set cCommentOpt {/\*[^*]*\*+([^/*][^*]*\*+)*/} 128 | set 1char "(c)" 129 | set nchar "(b+)" 130 | 131 | set tests [list \ 132 | "1-char short" $1char "abcdef" \ 133 | "1-char long-start" $1char "abc[str-repeat a 1000]" \ 134 | "1-char long-middle" $1char "[str-repeat a 500]c[str-repeat a 500]" \ 135 | "1-char long-end" $1char "[str-repeat a 1000]cba" \ 136 | "n-char short" $nchar "abbbbbcdef" \ 137 | "n-char long-start" $nchar "a[str-repeat b 20][str-repeat a 1000]" \ 138 | "n-char long-middle" $nchar "[str-repeat a 500][str-repeat b 20][str-repeat a 500]" \ 139 | "n-char long-end" $nchar "[str-repeat a 1000]c[str-repeat b 20]a" \ 140 | "basic" {^([^ ]*)[ ]*([^ ]*)} "" \ 141 | "c-comment simple" $cCommentOpt "/* foo * x * y * z * a * b * c */" \ 142 | "c-comment nomatch" $cCommentOpt "there aren't any comments here" \ 143 | "c-comment long" $cCommentOpt "/* [str-repeat a 1000] */" \ 144 | "c-comment long pmatch" $cCommentOpt "/* [str-repeat a 2000] [str-repeat * 100]" \ 145 | "c-comment long nomatch" $cCommentOpt "[str-repeat a 2000]" \ 146 | "c-comment many *s" $cCommentOpt "/* [str-repeat a 2000] [str-repeat * 100]/" \ 147 | ] 148 | 149 | foreach {type re str} $tests { 150 | bench -desc "RE $type" \ 151 | -body {regexp-str-exp $str $re} 152 | } 153 | foreach {type re str} $tests { 154 | bench -desc "RE $type catching" \ 155 | -body {regexp-catch $str $re} 156 | } 157 | 158 | set numstr "[str-repeat a 50]123.50[str-repeat b 20]" 159 | set tests [list \ 160 | "***= directive match" "***=a" "[str-repeat foo 100]"\ 161 | ". match" "." "[str-repeat foo 100]"\ 162 | "^\$ nomatch" {^$} "[str-repeat foo 100]"\ 163 | "***= directive nomatch" "***=bar" "[str-repeat foo 100]"\ 164 | "backtrack case" "a.*b.*c" "a[str-repeat b 200]" \ 165 | {[0-9] match} {[0-9]+\.[0-9]+} $numstr \ 166 | {\d match} {\d+\.\d+} $numstr \ 167 | ] 168 | foreach {type re str} $tests { 169 | if {([info tclversion] < 8.1) && ([string first ***= $re] == 0)} { 170 | # limited REs pre-8.1 171 | continue 172 | } 173 | bench -desc "RE var $type" \ 174 | -body {regexp-str-exp $str $re} 175 | } 176 | 177 | bench -desc "RE static short match" \ 178 | -body {regexp-str-static "abcdef"} 179 | bench -desc "RE static short nomatch" \ 180 | -body {regexp-str-static "ghijkl"} 181 | set str "[str-repeat a 500][str-repeat b 20]c[str-repeat d 500]" 182 | bench -desc "RE static long match" \ 183 | -body {regexp-str-static $str} 184 | set str "[str-repeat a 500][str-repeat b 20]cc[str-repeat d 500]" 185 | bench -desc "RE static long nomatch" \ 186 | -body {regexp-str-static $str} 187 | 188 | bench -desc "RE static anchored match" \ 189 | -body {regexp-str-static-anchor "foobar"} -result 1 190 | bench -desc "RE static anchored nomatch" \ 191 | -body {regexp-str-static-anchor "goodbye"} -result 0 192 | bench -desc "RE static anchored match dot" \ 193 | -body {regexp-str-static-anchor-dot "foobar"} -result 1 194 | bench -desc "RE static anchored nomatch dot" \ 195 | -body {regexp-str-static-anchor-dot "goodbye"} -result 0 196 | bench -desc "RE static l-anchored match" \ 197 | -body {regexp-str-static-lanchor "foobar"} -result 1 198 | bench -desc "RE static l-anchored nomatch" \ 199 | -body {regexp-str-static-lanchor "goodbye"} -result 0 200 | bench -desc "RE static r-anchored match" \ 201 | -body {regexp-str-static-ranchor "foobar"} -result 1 202 | bench -desc "RE static r-anchored nomatch" \ 203 | -body {regexp-str-static-ranchor "goodbye"} -result 0 204 | -------------------------------------------------------------------------------- /tcl/vars.bench: -------------------------------------------------------------------------------- 1 | 2 | proc var-incr-local {n} { 3 | set VAR(foo) 0 4 | for {set i 0} {$i < $n} {incr i} { 5 | incr VAR(foo) 6 | } 7 | } 8 | proc var-incr-global {n} { 9 | global VAR 10 | set VAR(foo) 0 11 | for {set i 0} {$i < $n} {incr i} { 12 | incr VAR(foo) 13 | } 14 | } 15 | proc var-incr-upvar {n} { 16 | upvar \#0 VAR v 17 | set v(foo) 0 18 | for {set i 0} {$i < $n} {incr i} { 19 | incr v(foo) 20 | } 21 | } 22 | 23 | # Local set variable access 24 | proc var-local-set {a} { 25 | set z 1 26 | set b $z 27 | set c $z 28 | set d $z 29 | } 30 | 31 | # Local input variable access 32 | proc var-local-input {a} { 33 | set z 1 34 | set b $a 35 | set c $a 36 | set d $a 37 | } 38 | 39 | # Local input variable access 40 | proc var-mset {l} { 41 | set a [lindex $l 0] 42 | set b [lindex $l 1] 43 | set c [lindex $l 2] 44 | set d [lindex $l 3] 45 | set e [lindex $l 4] 46 | set f [lindex $l 5] 47 | set g [lindex $l 6] 48 | set h [lindex $l 7] 49 | } 50 | 51 | proc var-foreach {l} { 52 | foreach {a b c d e f g h} $l { break } 53 | } 54 | 55 | # Global variable access 56 | # This takes a bogus input var to avoid proc compilation slowdown 57 | # (8.[12]) from skewing point of this test 58 | proc var-global {bogus} { 59 | global a 60 | set z 1 61 | set b $a 62 | set c $a 63 | set d $a 64 | } 65 | 66 | if {[info tclversion] >= 8.0} { 67 | namespace eval ::foo::var::ref { variable x } 68 | proc ::foo::var::ref {val} { 69 | variable x 0 70 | while {$x < $val} { incr x } 71 | } 72 | proc ::foo::var::gref {val} { 73 | set ::foo::var::x 0 74 | while {$::foo::var::x < $val} { incr ::foo::var::x } 75 | } 76 | proc ::foo::var::lref {val} { 77 | set x 0 78 | while {$x < $val} { incr x } 79 | } 80 | } else { 81 | proc ::foo::var::ref {val} { 82 | return -code 666 "8.0+" 83 | } 84 | proc ::foo::var::gref {val} { 85 | return -code 666 "8.0+" 86 | } 87 | proc ::foo::var::lref {val} { 88 | return -code 666 "8.0+" 89 | } 90 | } 91 | 92 | # Upvar variable access 93 | proc var-upvar {varname} { 94 | upvar 1 $varname a 95 | set z 1 96 | set b $a 97 | set c $a 98 | set d $a 99 | } 100 | 101 | # Setting a value in an array vs. setting a scalar 102 | # 103 | proc var-scalar {a} { 104 | set bar $a 105 | } 106 | proc var-array {a} { 107 | global foo 108 | set foo(1) $a 109 | } 110 | 111 | proc var-set-many {a} { 112 | global foo 113 | set foo(0) $a; set foo(1) $a; set foo(2) $a; set foo(3) $a; 114 | set foo(4) $a; set foo(5) $a; set foo(6) $a; set foo(7) $a; 115 | set foo(8) $a; set foo(9) $a; set foo(10) $a; set foo(11) $a; 116 | set foo(12) $a; set foo(13) $a; set foo(14) $a; set foo(15) $a; 117 | set foo(16) $a; set foo(17) $a; set foo(18) $a; set foo(19) $a; 118 | set foo(20) $a; set foo(21) $a; set foo(22) $a; set foo(23) $a; 119 | set foo(24) $a; set foo(25) $a; set foo(26) $a; set foo(27) $a; 120 | set foo(28) $a; set foo(29) $a; set foo(30) $a; set foo(31) $a; 121 | set foo(32) $a; set foo(33) $a; set foo(34) $a; set foo(35) $a; 122 | set foo(36) $a; set foo(37) $a; set foo(38) $a; set foo(39) $a; 123 | set foo(40) $a; set foo(41) $a; set foo(42) $a; set foo(43) $a; 124 | set foo(44) $a; set foo(45) $a; set foo(46) $a; set foo(47) $a; 125 | set foo(48) $a; set foo(49) $a; set foo(50) $a; set foo(51) $a; 126 | set foo(52) $a; set foo(53) $a; set foo(54) $a; set foo(55) $a; 127 | set foo(56) $a; set foo(57) $a; set foo(58) $a; set foo(59) $a; 128 | set foo(60) $a; set foo(61) $a; set foo(62) $a; set foo(63) $a; 129 | set foo(64) $a; set foo(65) $a; set foo(66) $a; set foo(67) $a; 130 | set foo(68) $a; set foo(69) $a; set foo(70) $a; set foo(71) $a; 131 | set foo(72) $a; set foo(73) $a; set foo(74) $a; set foo(75) $a; 132 | set foo(76) $a; set foo(77) $a; set foo(78) $a; set foo(79) $a; 133 | set foo(80) $a; set foo(81) $a; set foo(82) $a; set foo(83) $a; 134 | set foo(84) $a; set foo(85) $a; set foo(86) $a; set foo(87) $a; 135 | set foo(88) $a; set foo(89) $a; set foo(90) $a; set foo(91) $a; 136 | set foo(92) $a; set foo(93) $a; set foo(94) $a; set foo(95) $a; 137 | set foo(96) $a; set foo(97) $a; set foo(98) $a; set foo(99) $a; 138 | } 139 | 140 | proc var-array-set {a} { 141 | global foo 142 | array set foo [list 0 $a 1 $a 2 $a 3 $a 4 $a 5 $a 6 $a 7 $a 8 $a 9 $a \ 143 | 10 $a 11 $a 12 $a 13 $a 14 $a 15 $a 16 $a 17 $a 18 $a 19 $a \ 144 | 20 $a 21 $a 22 $a 23 $a 24 $a 25 $a 26 $a 27 $a 28 $a 29 $a \ 145 | 30 $a 31 $a 32 $a 33 $a 34 $a 35 $a 36 $a 37 $a 38 $a 39 $a \ 146 | 40 $a 41 $a 42 $a 43 $a 44 $a 45 $a 46 $a 47 $a 48 $a 49 $a \ 147 | 50 $a 51 $a 52 $a 53 $a 54 $a 55 $a 56 $a 57 $a 58 $a 59 $a \ 148 | 60 $a 61 $a 62 $a 63 $a 64 $a 65 $a 66 $a 67 $a 68 $a 69 $a \ 149 | 70 $a 71 $a 72 $a 73 $a 74 $a 75 $a 76 $a 77 $a 78 $a 79 $a \ 150 | 80 $a 81 $a 82 $a 83 $a 84 $a 85 $a 86 $a 87 $a 88 $a 89 $a \ 151 | 90 $a 91 $a 92 $a 93 $a 94 $a 95 $a 96 $a 97 $a 98 $a 99 $a] 152 | } 153 | 154 | bench -iter 10000 -desc "VAR access locally set" \ 155 | -body {var-local-set abc} 156 | bench -iter 10000 -desc "VAR access local proc arg" \ 157 | -body {var-local-input abc} 158 | set a 1 159 | bench -iter 10000 -desc "VAR access global" \ 160 | -body {var-global abc} 161 | unset a 162 | set a 1 163 | bench -iter 10000 -desc "VAR access upvar" \ 164 | -body {var-upvar a} 165 | 166 | set i 1000 167 | catch {unset VAR} 168 | bench -desc "VAR incr local var ${i}x" \ 169 | -body {var-incr-local $i} 170 | bench -desc "VAR incr global var ${i}x" \ 171 | -body {var-incr-global $i} 172 | bench -desc "VAR incr upvar var ${i}x" \ 173 | -body {var-incr-upvar $i} 174 | catch {unset VAR} 175 | 176 | # Create and populate a small array, so that we can avoid the cost of 177 | # creating the array itself in the benchmarks below 178 | set foo(0) 0 179 | 180 | bench -desc "VAR set scalar" \ 181 | -body {var-scalar 1} 182 | bench -desc "VAR set array element" \ 183 | -body {var-array 1} 184 | 185 | bench -desc "VAR 100 'set's in array" \ 186 | -body {var-set-many 1} 187 | bench -desc "VAR 'array set' of 100 elems" \ 188 | -body {var-array-set 1} 189 | 190 | bench -desc "VAR ref variable" \ 191 | -body {::foo::var::ref 50} 192 | bench -desc "VAR ref absolute" \ 193 | -body {::foo::var::gref 50} 194 | bench -desc "VAR ref local" \ 195 | -body {::foo::var::lref 50} 196 | 197 | bench -desc "VAR mset" \ 198 | -body [list var-mset [list a b c d e f g h]] 199 | bench -desc "VAR mset (foreach)" \ 200 | -body [list var-foreach [list a b c d e f g h]] 201 | -------------------------------------------------------------------------------- /tcl/klist.bench: -------------------------------------------------------------------------------- 1 | # 2 | # RCS: @(#) $Id$ 3 | # 4 | # From http://mini.net/cgi-bin/wikit/941 5 | # Procedure to generate a list of n numbers: 6 | proc iota { n } { 7 | for { set i 0 } { $i < $n } { incr i } { 8 | lappend retval $i 9 | } 10 | return $retval 11 | } 12 | 13 | if {[catch {expr {rand()}}]} { 14 | set IM 139968; set IA 3877; set IC 29573 15 | set last 42 16 | proc random {max} [subst { 17 | global last 18 | expr {(\$max*\[set last \[expr {(\$last * $IA + $IC) % $IM}\]\])/$IM} 19 | }] 20 | 21 | # shuffle0 requires both rand() and lsort -index 22 | proc shuffle0 { list } { return -code 666 8.0+ } 23 | } else { 24 | proc random {n} { expr {int(rand()*$n)} } 25 | 26 | # shuffle0 is the obvious method of generating random keys, then sorting 27 | # the list according to those keys. 28 | proc shuffle0 { list } { 29 | set newlist 0 30 | foreach element $list { 31 | lappend newlist [list [expr {rand()}] $element] 32 | } 33 | foreach pair [lsort -real -index 0 $newlist] { 34 | foreach { random item } $pair {} 35 | lappend retval $item 36 | } 37 | return $retval 38 | } 39 | } 40 | 41 | # Several of the procedures rely on Donal Fellows's K combinator: 42 | proc K { x y } { set x } 43 | 44 | # shuffle1 is Techentin's implementation of Bentley's method. 45 | proc shuffle1-s { list } { 46 | set n [llength $list] 47 | for { set i 0 } { $i < $n } { incr i } { 48 | set j [random $n] 49 | set temp [lindex $list $j] 50 | set list [lreplace $list $j $j [lindex $list $i]] 51 | set list [lreplace $list $i $i $temp] 52 | } 53 | return $list 54 | } 55 | 56 | # shuffle1a is Techentin's code, with a clever hack (due to Donal Fellows) for 57 | # managing the lifetime of the Tcl_Obj that represents the list so that it 58 | # doesn't get copied needlessly. 59 | proc shuffle1a { list } { 60 | set n [llength $list] 61 | for { set i 0 } { $i < $n } { incr i } { 62 | set j [random $n] 63 | set temp1 [lindex $list $j] 64 | set temp2 [lindex $list $i] 65 | set list [lreplace [K $list [set list {}]] $j $j $temp2] 66 | set list [lreplace [K $list [set list {}]] $i $i $temp1] 67 | } 68 | return $list 69 | } 70 | 71 | # shuffle2 implements Bentley's method, unpacking the list to an array first. 72 | proc shuffle2 { list } { 73 | set n 0 74 | foreach element $list { 75 | set data($n) $element 76 | incr n 77 | } 78 | for { set i 0 } { $i < $n } { incr i } { 79 | set j [random $n] 80 | set temp $data($j) 81 | set data($j) $data($i) 82 | set data($i) $temp 83 | } 84 | for { set i 0 } { $i < $n } { incr i } { 85 | lappend retval $data($i) 86 | } 87 | return $retval 88 | } 89 | 90 | # shuffle3 is Bob Techentin's implementation of Stephen D. Cohen's proposed 91 | # method. 92 | proc shuffle3 { list } { 93 | set n [llength $list] 94 | while {$n>0} { 95 | set j [random $n] 96 | lappend slist [lindex $list $j] 97 | set list [lreplace [K $list [set list {}]] $j $j] 98 | incr n -1 99 | } 100 | return $slist 101 | } 102 | 103 | # shuffle4 is Steve Cohen's improved implementation: 104 | proc shuffle4 { list } { 105 | set n [llength $list] 106 | while {$n>0} { 107 | set j [random $n] 108 | lappend slist [lindex $list $j] 109 | incr n -1 110 | set temp [lindex $list $n] 111 | set list [lreplace [K $list [set list {}]] $j $j $temp] 112 | } 113 | return $slist 114 | } 115 | 116 | # shuffle5 and shuffle5a are from Christoph Bauer. 117 | # They differ only in the use of the K combinator. 118 | proc shuffle5-s { list } { 119 | set n 1 120 | set slist {} 121 | foreach item $list { 122 | set index [random $n] 123 | set slist [linsert $slist $index $item] 124 | incr n 125 | } 126 | return $slist 127 | } 128 | 129 | proc shuffle5a { list } { 130 | set n 1 131 | set slist {} 132 | foreach item $list { 133 | set index [random $n] 134 | set slist [linsert [K $slist [set slist {}]] $index $item] 135 | incr n 136 | } 137 | return $slist 138 | } 139 | 140 | # shuffle6 uses the new [lset] command 141 | if {[info command lset] != {}} { 142 | proc shuffle6 { list } { 143 | set n [llength $list] 144 | for { set i 1 } { $i < $n } { incr i } { 145 | set j [expr { int( rand() * $n ) }] 146 | set temp [lindex $list $i] 147 | lset list $i [lindex $list $j] 148 | lset list $j $temp 149 | } 150 | return $list 151 | } 152 | } 153 | 154 | # The test harness times the various methods and prints the results. 155 | 156 | if {[info tclversion] < 8.0} { 157 | # 7.6 has some real timing short-comings for these tests 158 | set LENGTHS [list 1 10 100 1000] 159 | set ITERS [list 100 50 25 10] 160 | } else { 161 | set LENGTHS [list 1 10 100 1000 10000] 162 | set ITERS [list 1000 500 250 100 10] 163 | } 164 | set METHODS [list shuffle0 shuffle1-s shuffle1a shuffle2 shuffle3 \ 165 | shuffle4 shuffle5-s shuffle5a] 166 | 167 | if {[info command lset] != {}} { 168 | lappend METHODS shuffle6 169 | } 170 | 171 | proc doShuffle {} { 172 | global LENGTHS ITERS METHODS 173 | # init the lists 174 | foreach n $LENGTHS { 175 | set LISTS($n) [iota $n] 176 | } 177 | 178 | # do the benchmarking 179 | foreach method $METHODS { 180 | foreach n $LENGTHS iter $ITERS { 181 | if {[string match "*-s" $method] && ($n > 1000)} { 182 | continue 183 | } 184 | bench -desc "KLIST $method llength $n" \ 185 | -body [list $method $LISTS($n)] -iter $iter 186 | } 187 | } 188 | } 189 | 190 | proc doShuffle0 {} { 191 | global LENGTHS ITERS METHODS 192 | # init the lists 193 | foreach n $LENGTHS { 194 | set LISTS($n) [iota $n] 195 | } 196 | fconfigure stdout -buffering none 197 | puts " Tcl[info patchlevel] Times in usec for shuffle methods" 198 | puts " Method List length" 199 | puts " [join $LENGTHS \t]" 200 | puts " --------------------------------------------------" 201 | # do the benchmarking 202 | foreach method $METHODS { 203 | if {$::argc && ![string match $method [lindex $::argv 0]]} { 204 | continue 205 | } 206 | puts -nonewline [format " %-10s" $method] 207 | foreach n $LENGTHS iter $ITERS { 208 | if {[string match "*-s" $method] && ($n > 1000)} { 209 | puts -nonewline " ------" 210 | } else { 211 | set t [time {$method $LISTS($n)} $iter] 212 | puts -nonewline [format "%8d" [lindex $t 0]] 213 | } 214 | } 215 | puts "" 216 | } 217 | } 218 | 219 | if {[info commands bench] == ""} { 220 | doShuffle0 221 | } else { 222 | doShuffle 223 | } 224 | 225 | # The results are summarized in the following table: 226 | 227 | # Tcl8.4a2 Times in usec for shuffle methods 228 | # Method List length 229 | # 1 10 100 1000 5000 230 | # ------------------------------------------------- 231 | # shuffle0 145 435 3387 35831 198332 232 | # shuffle1 61 326 4067 400734 ------ 233 | # shuffle1a 75 378 3338 33391 167022 234 | # shuffle2 105 434 3645 36554 192944 235 | # shuffle3 85 400 3490 37690 260518 236 | # shuffle4 88 447 3899 38356 190989 237 | -------------------------------------------------------------------------------- /tcl/ascii85.bench: -------------------------------------------------------------------------------- 1 | # ascii85.tcl -- 2 | # 3 | # Encode/Decode ascii85 for a string 4 | # 5 | # Copyright (c) Emiliano Gavilan 6 | # See the file "license.terms" for information on usage and redistribution 7 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 8 | 9 | if {[catch {package require Tcl 8.4}]} { 10 | # uses eq and 8.4 regsub features 11 | return 12 | } 13 | 14 | namespace eval ascii85 { 15 | namespace export encode encodefile decode 16 | # default values for encode options 17 | variable options 18 | array set options [list -wrapchar \n -maxlen 76] 19 | } 20 | 21 | # ::ascii85::encode -- 22 | # 23 | # Ascii85 encode a given string. 24 | # 25 | # Arguments: 26 | # args ?-maxlen maxlen? ?-wrapchar wrapchar? string 27 | # 28 | # If maxlen is 0, the output is not wrapped. 29 | # 30 | # Results: 31 | # A Ascii85 encoded version of $string, wrapped at $maxlen characters 32 | # by $wrapchar. 33 | 34 | proc ascii85::encode {args} { 35 | variable options 36 | 37 | set alen [llength $args] 38 | if {$alen != 1 && $alen != 3 && $alen != 5} { 39 | return -code error "wrong # args:\ 40 | should be \"[lindex [info level 0] 0]\ 41 | ?-maxlen maxlen?\ 42 | ?-wrapchar wrapchar? string\"" 43 | } 44 | 45 | set data [lindex $args end] 46 | array set opts [array get options] 47 | array set opts [lrange $args 0 end-1] 48 | foreach key [array names opts] { 49 | if {[lsearch -exact [array names options] $key] == -1} { 50 | return -code error "unknown option \"$key\":\ 51 | must be -maxlen or -wrapchar" 52 | } 53 | } 54 | 55 | if {![string is integer -strict $opts(-maxlen)] 56 | || $opts(-maxlen) < 0 } { 57 | return -code error "expected positive integer but got\ 58 | \"$opts(-maxlen)\"" 59 | } 60 | 61 | # perform this check early 62 | if {[string length $data] == 0} { 63 | return "" 64 | } 65 | 66 | # shorten the names 67 | set ml $opts(-maxlen) 68 | set wc $opts(-wrapchar) 69 | 70 | # if maxlen is zero, don't wrap the output 71 | if {$ml == 0} {set wc ""} 72 | 73 | set encoded {} 74 | 75 | binary scan $data c* X 76 | set len [llength $X] 77 | set rest [expr {$len % 4}] 78 | set lastidx [expr {$len - $rest - 1}] 79 | 80 | foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] { 81 | append current [encode4bytes [expr { 82 | ( (($b1 & 0xff) << 24) 83 | | (($b2 & 0xff) << 16) 84 | | (($b3 & 0xff) << 8) 85 | | ($b4 & 0xff) 86 | ) & 0xffffffff }]] 87 | if {[string length $current] >= $ml} { 88 | append encoded [string range $current 0 [expr {$ml - 1}]] $wc 89 | set current [string range $current $ml end] 90 | } 91 | } 92 | 93 | if { $rest } { 94 | set val 0 95 | foreach byte [lrange $X [incr lastidx] end] shift {24 16 8 0} { 96 | set val [expr { 97 | ($byte eq "") ? 98 | $val : 99 | ($val | (($byte & 0xff) << $shift)) & 0xffffffff 100 | }] 101 | } 102 | append current [string range [binary format ccccc \ 103 | [expr { ( $val / 52200625) + 33 }] \ 104 | [expr { (($val % 52200625) / 614125) + 33 }] \ 105 | [expr { (($val % 614125) / 7225) + 33 }] \ 106 | [expr { (($val % 7225) / 85) + 33 }] \ 107 | [expr { ( $val % 85) + 33 }] 108 | ] 0 $rest] 109 | } 110 | append encoded [regsub -all -- ".{$ml}" $current "&$wc"] 111 | 112 | return $encoded 113 | } 114 | 115 | proc ascii85::encode4bytes {val} { 116 | if {$val == 0} {return z} 117 | return [binary format ccccc \ 118 | [expr { ( $val / 52200625) + 33 }] \ 119 | [expr { (($val % 52200625) / 614125) + 33 }] \ 120 | [expr { (($val % 614125) / 7225) + 33 }] \ 121 | [expr { (($val % 7225) / 85) + 33 }] \ 122 | [expr { ( $val % 85) + 33 }]] 123 | } 124 | 125 | # ::ascii85::encodefile -- 126 | # 127 | # Ascii85 encode the contents of a file using default values 128 | # for maxlen and wrapchar parameters. 129 | # 130 | # Arguments: 131 | # fname The name of the file to encode. 132 | # 133 | # Results: 134 | # A Ascii85 encoded version of the contents of the file. 135 | 136 | proc ascii85::encodefile {fname} { 137 | set fd [open $fname] 138 | fconfigure $fd -encoding binary -translation binary 139 | return [encode [read $fd]][close $fd] 140 | } 141 | 142 | # ::ascii85::decode -- 143 | # 144 | # Ascii85 decode a given string. 145 | # 146 | # Arguments: 147 | # string The string to decode. 148 | # Leading spaces and tabs are removed, along with trailing newlines 149 | # 150 | # Results: 151 | # The decoded value. 152 | 153 | proc ascii85::decode {data} { 154 | # get rid of leading spaces/tabs and trailing newlines 155 | set data [string map [list \n {} \t {} { } {}] $data] 156 | 157 | set decoded {} 158 | set idx0 0 159 | set idx1 4 160 | set len [string length $data] 161 | 162 | # perform this ckeck early 163 | if {! $len} { 164 | return "" 165 | } 166 | 167 | # can't process this as a list like encoding does, since we have 168 | # to check for the "z" char; in that case advance only one position 169 | while {[string length [set 5b [string range $data $idx0 $idx1]]] == 5} { 170 | if {[string index $5b 0] eq "z"} { 171 | # the first char is a "z"; append four null bytes 172 | append decoded \x00\x00\x00\x00 173 | incr idx0 1 174 | incr idx1 1 175 | continue 176 | } 177 | # check that all bytes lie between ascii 33 ("!") 178 | # and ascii 117 ("u") 179 | checkrange $5b 180 | 181 | # the string is legal: decode it 182 | append decoded [decode5bytes $5b] 183 | incr idx0 5 184 | incr idx1 5 185 | } 186 | 187 | if {[string length $5b] == 0} { 188 | return $decoded 189 | } 190 | 191 | # ok, there are less than 5 chars in the string. 192 | # chomp leading "z"s first 193 | while {[string index $5b 0] eq "z"} { 194 | append decoded \x00\x00\x00\x00 195 | set 5b [string range $5b 1 end] 196 | } 197 | 198 | # if there is only one char left, is an error 199 | if {[string length $5b] == 1} { 200 | return -code error \ 201 | "error decoding data: trailing char" 202 | } 203 | 204 | # check the range of the last chars 205 | checkrange $5b 206 | 207 | # pad with "u"s, decode and add ([string length $5b] - 1) bytes 208 | append decoded \ 209 | [string range \ 210 | [decode5bytes [pad $5b 5 u]] \ 211 | 0 \ 212 | [expr {[string length $5b] - 2}] 213 | ] 214 | 215 | return $decoded 216 | } 217 | 218 | proc ascii85::decode5bytes {data} { 219 | binary scan $data ccccc b1 b2 b3 b4 b5 220 | return [binary format I [expr { 221 | ($b1 - 33) * wide(52200625) + 222 | ($b2 - 33) * 614125 + 223 | ($b3 - 33) * 7225 + 224 | ($b4 - 33) * 85 + 225 | ($b5 - 33) }]] 226 | } 227 | 228 | proc ascii85::checkrange {chars} { 229 | foreach char [split $chars {} ] { 230 | if {$char > "u" || $char < "!" } { 231 | return -code error \ 232 | "error decoding data: wrong chars range \"$chars\"" 233 | } 234 | } 235 | } 236 | 237 | proc ascii85::pad {chars len padchar} { 238 | while {[string length $chars] < $len} { 239 | append chars $padchar 240 | } 241 | return $chars 242 | } 243 | 244 | #package provide ascii85 1.0 245 | 246 | # this test string appears on wikipedia 247 | set str "Man is distinguished, not only by his reason, but by this\ 248 | singular passion from other animals, which is a lust of the mind, that\ 249 | by a perseverance of delight in the continued and indefatigable generation\ 250 | of knowledge, exceeds the short vehemence of any carnal pleasure." 251 | 252 | if {[info commands bench] == ""} { 253 | puts "Tcl [info patchlevel]" 254 | set enc [ascii85::encode $str] 255 | puts "Encoded:\n$enc" 256 | set dec [ascii85::decode $enc] 257 | puts "Decoded:\n$dec" 258 | } else { 259 | foreach len {10 100} iter {100 40} { 260 | set str [string repeat $str $len] 261 | bench -desc "ascii85 strlen [string length $str]" -iter $iter \ 262 | -body {::ascii85::encode $str} 263 | } 264 | } 265 | -------------------------------------------------------------------------------- /tcl/list.bench: -------------------------------------------------------------------------------- 1 | proc list-1.1 {l1} { 2 | string length $l1 3 | string length $l1 4 | llength $l1 5 | llength $l1 6 | } 7 | 8 | proc list-1.2 {lst} { 9 | llength $lst 10 | llength $lst 11 | } 12 | 13 | proc list-1.3 {s} { 14 | string length $s 15 | } 16 | 17 | proc list-2.1 {s t} { 18 | lsearch -exact $s $t 19 | } 20 | 21 | # The -sorted and -integer flags do not exist in versions of Tcl <= 8.3.1, 22 | # so if we [catch {lsearch -sorted}], we stub out the -sorted, et al, procs 23 | # with compatible (but less efficient) functions 24 | 25 | if { [catch {lsearch -sorted [list a b c] b}] } { 26 | proc list-2.2 {s t} { 27 | lsearch -exact $s $t 28 | } 29 | proc list-2.3 {s t} { 30 | lsearch -exact $s $t 31 | } 32 | proc list-2.4 {s t} { 33 | lsearch -exact $s $t 34 | } 35 | } else { 36 | proc list-2.2 {s t} { 37 | lsearch -sorted $s $t 38 | } 39 | proc list-2.3 {s t} { 40 | lsearch -exact -integer $s $t 41 | } 42 | proc list-2.4 {s t} { 43 | lsearch -sorted -integer $s $t 44 | } 45 | } 46 | 47 | proc list-2.5 {s} { 48 | lsort $s 49 | } 50 | 51 | proc list-2.5.1 {s} { 52 | lsort -integer $s 53 | } 54 | 55 | proc list-2.6 {s i} { 56 | # remove 57 | lreplace $s $i $i 58 | } 59 | 60 | proc list-2.7 {s i r} { 61 | # replace 62 | lreplace $s $i $i $r 63 | } 64 | 65 | proc list-replace-multiple {s i r} { 66 | # replace 67 | lreplace $s $i $i $r $r $r $r $r $r $r $r $r $r 68 | } 69 | 70 | proc list-replace-range {s start end} { 71 | lreplace $s $start $end 72 | } 73 | 74 | proc list-2.8 {s i} { 75 | # retrieve 76 | lindex $s $i 77 | } 78 | 79 | proc list-2.9 {s i w} { 80 | # insert 81 | linsert $s $i $w 82 | } 83 | 84 | proc list-2.10 {s i j} { 85 | lrange $s $i $j 86 | } 87 | 88 | proc list-2.11 {w} { 89 | lappend var $w 90 | lappend var $w 91 | } 92 | 93 | proc list-2.12 {l j} { 94 | join $l $j 95 | } 96 | 97 | proc lsearch-regexp {l ptn} { 98 | lsearch -regexp $l $ptn 99 | } 100 | 101 | proc list-iter {l} { 102 | for {set i 0} {$i < [llength $l]} {incr i} { 103 | set var [lindex $l $i] 104 | } 105 | } 106 | 107 | proc list-list {a b c} { 108 | foreach v [list $a $b $c a b c $a $b $c \ 109 | a b c] { 110 | set v foobar 111 | } 112 | } 113 | 114 | proc list-rev-lappend {l} { 115 | set res {} 116 | set i [llength $l] 117 | while {$i > 0} { lappend res [lindex $l [incr i -1]] } 118 | return $res 119 | } 120 | proc list-rev-core {l} { 121 | return [lreverse $l] 122 | } 123 | if {[info tclversion] < 8.5} { 124 | proc list-rev-core {l} { return -code 666 "8.5+" } 125 | } 126 | 127 | if {[info tclversion] < 8.4} { 128 | proc biglist { size } {} 129 | proc lset-1 args { return -code 666 "=8.4" } 130 | proc lset-2 args { return -code 666 "=8.4" } 131 | proc lset-3 args { return -code 666 "=8.4" } 132 | proc lset-4 args { return -code 666 "=8.4" } 133 | } else { 134 | proc biglist { size } { 135 | set list "" 136 | for {set i 0} {$i < $size} {incr i} { lappend list [expr {$i}] } 137 | return $list 138 | } 139 | 140 | proc lset-1 { list } { 141 | foreach "a b c d e" $list { lset list $a $b } 142 | return $list 143 | } 144 | proc lset-2 { list } { 145 | foreach [list a b c d e] $list { lset list $a $b } 146 | return $list 147 | } 148 | proc lset-3 { l } { 149 | foreach "a b c d e" $l { lset l $a $b } 150 | return $l 151 | } 152 | proc lset-4 { l } { 153 | foreach [list a b c d e] $l { lset l $a $b } 154 | return $l 155 | } 156 | } 157 | 158 | proc SET {l1 l2} { set l1 "$l1 $l2" } 159 | proc APPEND {l1 l2} { append l1 " $l2" } 160 | proc CONCAT {l1 l2} { set l1 [concat $l1 $l2] } 161 | proc EVAL/LAPPEND {l1 l2} { eval [list lappend l1] $l2 } 162 | proc FOREACH/LAPPEND {l1 l2} { foreach i $l2 {lappend l1 $i} ; set l1 } 163 | 164 | proc makeList {len item} { 165 | for {set i 0} {$i < $len} {incr i} { 166 | lappend res $item 167 | } 168 | return $res 169 | } 170 | 171 | set types [list FOREACH/LAPPEND EVAL/LAPPEND CONCAT APPEND SET] 172 | foreach type $types { 173 | foreach len {10 100 1000 10000} { 174 | set l1 [makeList $len a] 175 | set l2 [makeList $len b] 176 | bench -desc "LIST concat $type 2x$len" -iter 200 \ 177 | -body {llength [$type $l1 $l2]} 178 | unset l1 l2 179 | } 180 | } 181 | 182 | proc makeLists {{size 500}} { 183 | global Sobj Lobj LSobj 184 | set Sobj "" 185 | set Lobj [list] 186 | set LSobj [list] 187 | for {set i 0} {$i < $size} {incr i} { 188 | append Sobj "$i " 189 | lappend Lobj $i 190 | lappend LSobj $i 191 | } 192 | string length $LSobj 193 | } 194 | makeLists 1000 195 | 196 | bench -desc "STR/LIST length, obj shimmer" \ 197 | -body {list-1.1 $LSobj} 198 | bench -desc "LIST length, pure list" \ 199 | -body {list-1.2 $Lobj} 200 | bench -desc "STR length of a LIST" \ 201 | -body {list-1.3 $LSobj} 202 | 203 | # List searches (-exact versus -sorted) 204 | # 205 | 206 | bench -desc "LIST exact search, first item" \ 207 | -body {list-2.1 $Lobj 1} 208 | bench -desc "LIST exact search, middle item" \ 209 | -body {list-2.1 $Lobj 100} 210 | bench -desc "LIST exact search, last item" \ 211 | -body {list-2.1 $Lobj 199} 212 | bench -desc "LIST exact search, non-item" \ 213 | -body {list-2.1 $Lobj 500} 214 | bench -desc "LIST sorted search, first item" \ 215 | -body {list-2.2 $Lobj 1} 216 | bench -desc "LIST sorted search, middle item" \ 217 | -body {list-2.2 $Lobj 100} 218 | bench -desc "LIST sorted search, last item" \ 219 | -body {list-2.2 $Lobj 199} 220 | bench -desc "LIST sorted search, non-item" \ 221 | -body {list-2.2 $Lobj 500} 222 | 223 | # List searches (-integer) 224 | 225 | bench -desc "LIST exact search, untyped item" \ 226 | -body {list-2.1 $Lobj 199} 227 | bench -desc "LIST exact search, typed item" \ 228 | -body {list-2.3 $Lobj 199} 229 | bench -desc "LIST sorted search, typed item" \ 230 | -body {list-2.4 $Lobj 199} 231 | 232 | bench -desc "LIST regexp search, first item" \ 233 | -body {lsearch-regexp $Lobj 1} 234 | bench -desc "LIST regexp search, non-item" \ 235 | -body {lsearch-regexp $Lobj 500} 236 | bench -desc "LIST regexp search, last item" \ 237 | -body {lsearch-regexp $Lobj 199} 238 | 239 | # Other list operations 240 | 241 | bench -desc "LIST sort" \ 242 | -body {list-2.5 $Lobj} 243 | bench -desc "LIST typed sort" \ 244 | -body {list-2.5.1 $Lobj} 245 | bench -desc "LIST remove first element" \ 246 | -body {list-2.6 $Lobj 0} 247 | bench -desc "LIST remove middle element" \ 248 | -body {list-2.6 $Lobj 100} 249 | bench -desc "LIST remove last element" \ 250 | -body {list-2.6 $Lobj 199} 251 | bench -desc "LIST replace first element" \ 252 | -body {list-2.7 $Lobj 0 10} 253 | bench -desc "LIST replace middle element" \ 254 | -body {list-2.7 $Lobj 500 10} 255 | bench -desc "LIST replace last element" \ 256 | -body {list-2.7 $Lobj 999 10} 257 | bench -desc "LIST replace first el with multiple" \ 258 | -body {list-replace-multiple $Lobj 0 10} 259 | bench -desc "LIST replace middle el with multiple" \ 260 | -body {list-replace-multiple $Lobj 500 10} 261 | bench -desc "LIST replace last el with multiple" \ 262 | -body {list-replace-multiple $Lobj 999 10} 263 | bench -desc "LIST replace range" \ 264 | -body {list-replace-range $Lobj 0 800} 265 | bench -desc "LIST remove in mixed list" \ 266 | -body {list-2.6 $LSobj 100} 267 | bench -desc "LIST replace in mixed list" \ 268 | -body {list-2.7 $LSobj 100 10} 269 | bench -desc "LIST index first element" \ 270 | -body {list-2.8 $Lobj 0} 271 | bench -desc "LIST index middle element" \ 272 | -body {list-2.8 $Lobj 100} 273 | bench -desc "LIST index last element" \ 274 | -body {list-2.8 $Lobj 199} 275 | bench -desc "LIST insert an item at start" \ 276 | -body {list-2.9 $Lobj 0 10} 277 | bench -desc "LIST insert an item at middle" \ 278 | -body {list-2.9 $Lobj 100 10} 279 | bench -desc "LIST insert an item at \"end\"" \ 280 | -body {list-2.9 $Lobj end 10} 281 | bench -desc "LIST small, early range" \ 282 | -body {list-2.10 $Lobj 0 10} 283 | bench -desc "LIST small, late range" \ 284 | -body {list-2.10 $Lobj 180 190} 285 | bench -desc "LIST large, early range" \ 286 | -body {list-2.10 $Lobj 0 150} 287 | bench -desc "LIST large, late range" \ 288 | -body {list-2.10 $Lobj 50 199} 289 | bench -desc "LIST append to list" \ 290 | -body {list-2.11 10} 291 | bench -desc "LIST join list" \ 292 | -body {list-2.12 $Lobj ","} 293 | 294 | bench -desc "LIST iterate list" \ 295 | -body {list-iter $Lobj} 296 | 297 | bench -desc "LIST reverse lappend" \ 298 | -body {list-rev-lappend $Lobj} 299 | bench -desc "LIST reverse core" \ 300 | -body {list-rev-core $Lobj} 301 | 302 | bench -desc "LIST list" \ 303 | -body {list-list one two three} 304 | 305 | set lobj [biglist 1000] 306 | 307 | bench -desc "LIST lset foreach \"\"s list" \ 308 | -body {lset-1 $lobj} 309 | bench -desc "LIST lset foreach [list] list" \ 310 | -body {lset-2 $lobj} 311 | bench -desc "LIST lset foreach \"\"s l" \ 312 | -body {lset-3 $lobj} 313 | bench -desc "LIST lset foreach [list] l" \ 314 | -body {lset-4 $lobj} 315 | -------------------------------------------------------------------------------- /normbench.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | 3 | # normbench.tcl ?options? 4 | # 5 | set RCS {RCS: @(#) $Id$} 6 | # 7 | # Copyright (c) 2000-2007 Jeffrey Hobbs. 8 | 9 | # 10 | # Run the main script from an 8.2+ interp 11 | # 12 | if {[catch {package require Tcl 8.2}]} { 13 | set me [file tail [info script]] 14 | puts stderr "$me requires 8.2+ to run, although it can benchmark\ 15 | any Tcl v7+ interpreter" 16 | exit 1 17 | } 18 | 19 | regexp {,v (\d+\.\d+)} $RCS -> VERSION 20 | set MYDIR [file dirname [info script]] 21 | set ME [file tail [info script]] 22 | 23 | proc usage {} { 24 | puts stderr "Usage (v$::VERSION): $::ME ?options?\ 25 | \n\t-help # print out this message\ 26 | \n\t-delta # delta range for wiki highlight (default: 0.05)\ 27 | \n\t-normalize # normalize numbers to given version\ 28 | \n\t-output # style of output (default: match input format)\ 29 | \n\t?file? # runbench output file to normalize (or stdin)" 30 | exit 1 31 | } 32 | 33 | # 34 | # Process args 35 | # 36 | array set opts { 37 | norm {} 38 | fid stdin 39 | output {} 40 | delta {0.05} 41 | } 42 | if {[llength $argv]} { 43 | while {[llength $argv]} { 44 | set key [lindex $argv 0] 45 | switch -glob -- $key { 46 | -help* { usage } 47 | -norm* { 48 | set opts(norm) [lindex $argv 1] 49 | set argv [lreplace $argv 0 1] 50 | } 51 | -delta { 52 | set opts(delta) [lindex $argv 1] 53 | set argv [lreplace $argv 0 1] 54 | } 55 | -out* { 56 | # Output style 57 | set opts(output) [lindex $argv 1] 58 | if {![regexp {^(text|list|csv|wiki)$} $opts(output)]} { usage } 59 | set argv [lreplace $argv 0 1] 60 | } 61 | default { 62 | if {![file exists $key]} { 63 | usage 64 | } else { 65 | set opts(fid) [open $key r] 66 | set argv [lreplace $argv 0 0] 67 | # The file should be the last arg 68 | if {[llength $argv]} { usage } 69 | } 70 | } 71 | } 72 | } 73 | } 74 | 75 | proc csv2list {str {sepChar ,}} { 76 | regsub -all {(\A\"|\"\Z)} $str \0 str 77 | set str [string map [list $sepChar\"\"\" $sepChar\0\" \ 78 | \"\"\"$sepChar \"\0$sepChar \ 79 | \"\" \" \" \0 ] $str] 80 | set end 0 81 | while {[regexp -indices -start $end {(\0)[^\0]*(\0)} $str \ 82 | -> start end]} { 83 | set start [lindex $start 0] 84 | set end [lindex $end 0] 85 | set range [string range $str $start $end] 86 | set first [string first $sepChar $range] 87 | if {$first >= 0} { 88 | set str [string replace $str $start $end \ 89 | [string map [list $sepChar \1] $range]] 90 | } 91 | incr end 92 | } 93 | set str [string map [list $sepChar \0 \1 $sepChar \0 {} ] $str] 94 | return [split $str \0] 95 | } 96 | 97 | proc list2csv {list {sepChar ,}} { 98 | set out "" 99 | foreach l $list { 100 | set sep {} 101 | foreach val $l { 102 | if {[string match "*\[\"$sepChar\]*" $val]} { 103 | append out $sep\"[string map [list \" \"\"] $val]\" 104 | } else { 105 | append out $sep$val 106 | } 107 | set sep $sepChar 108 | } 109 | append out \n 110 | } 111 | return $out 112 | } 113 | 114 | proc list2text {l} { 115 | global DESCLEN 116 | set num [lindex $l 0] 117 | set desc [lindex $l 1] 118 | set times [lrange $l 2 end] 119 | if {![info exists DESCLEN]} { 120 | # make desclen max available for 80 char display 121 | set DESCLEN [expr {74 - 9*[llength $times]}] 122 | if {$DESCLEN < 40} { set DESCLEN 40 } 123 | } 124 | set text [format "%.3d %-*s" $num $DESCLEN $desc] 125 | foreach t $times { 126 | if {[string is double -strict $t]} { 127 | append text [format " %8.2f" $t] 128 | } else { 129 | append text [format " %8s" $t] 130 | } 131 | } 132 | return $text 133 | } 134 | 135 | proc text2list {str} { 136 | global DESCLEN 137 | if {![info exists DESCLEN]} { 138 | # first creation - determine desclen on distance to first datapoint 139 | # At this point we have to guess ... 140 | set DESCLEN [expr {[string first 1: $str]-1}] 141 | } 142 | set times [string range $str $DESCLEN end] 143 | regexp {\d+} $str num ; # use RE to catch 0-prefaced nums 144 | set desc [string trim [string range $str [string length $num] $DESCLEN]] 145 | return [concat [list $num $desc] $times] 146 | } 147 | 148 | proc min {times} { 149 | set min [expr {1<<16}] 150 | foreach t $times { 151 | if {[string is double -strict $t]} { if {$t < $min} { set min $t } } 152 | } 153 | return $min 154 | } 155 | 156 | proc max {times} { 157 | set max 0 158 | foreach t $times { 159 | if {[string is double -strict $t]} { if {$t > $max} { set max $t } } 160 | } 161 | return $max 162 | } 163 | 164 | proc wikisafe {str} { 165 | return [string map [list | <> "\[" "\[\[" "\]" "\]\]" ] $str] 166 | } 167 | 168 | proc wiki2list {str} { 169 | # remove first and last 2 chars and split on | symbol 170 | set out [list] 171 | foreach elem [split [string range $str 2 end-2] "|"] { 172 | set elem [string trim $elem '] ; # remove wiki highlighting 173 | lappend out [string map [list "\[\[" "\[" "\]\]" "\]"] $elem] 174 | } 175 | return $out 176 | } 177 | 178 | proc list2wiki {l} { 179 | if {[lsearch -regexp $l {(VER|BENCH)}] != -1} { 180 | return "%|[join [wikisafe $l] |]|%\n" ; # header 181 | } else { 182 | return "&|[join [wikisafe $l] |]|&\n" 183 | } 184 | } 185 | 186 | 187 | proc findVersion {norm versions} { 188 | if {$norm == "" || $norm == "none"} { return 0 } 189 | set i [lsearch -exact $versions $norm] 190 | if {$i >= 0} { return $i } 191 | set i [lsearch -glob $versions *$norm*] 192 | if {$i >= 0} { return $i } 193 | puts stderr "Unable to normalize \"$norm\": must be one of [join $versions {, }]" 194 | usage 195 | } 196 | 197 | proc normalize-text {norm line} { 198 | global start col 199 | scan $line %d num 200 | if {$num == 0} { 201 | set start [expr {[string first 1: $line]-1}] 202 | set col [findVersion $norm [string range $line $start end]] 203 | return $line 204 | } 205 | set times [string range $line $start end] 206 | set ntime [lindex $times $col] 207 | if {![string is double -strict $ntime] || $ntime == 0} { 208 | # This didn't return valid data. Try walking backwards to find 209 | # a newer version that we can normalize this row on, since newer 210 | # versions are to the left. 211 | for {set i $col} {$i >= 0} {incr i -1} { 212 | set ntime [lindex $times $i] 213 | if {[string is double -strict $ntime] && $ntime} { break } 214 | } 215 | # Hmph. No usable data. 216 | if {$i == -1} { return $line } 217 | } 218 | set out [string range $line 0 [expr {$start-1}]] 219 | foreach t $times { 220 | if {$norm != "none" && [string is double -strict $t]} { 221 | append out [format " %7.2f" \ 222 | [expr {double($t) / double($ntime)}]] 223 | } else { 224 | append out [format " %7s" $t] 225 | } 226 | } 227 | return $out 228 | } 229 | 230 | proc normalize-list {norm line} { 231 | global col opts 232 | if {[lindex $line 0] == 0} { 233 | set col [findVersion $norm [lrange $line 2 end]] 234 | return $line 235 | } 236 | set times [lrange $line 2 end] 237 | set ntime [lindex $times $col] 238 | if {![string is double -strict $ntime]} { 239 | return $line 240 | } else { 241 | set out [lrange $line 0 1] 242 | if {$opts(output) == "wiki"} { 243 | set min [min $times] 244 | set max [max $times] 245 | } 246 | foreach t $times { 247 | if {[string is double -strict $t]} { 248 | if {$norm == "none"} { 249 | set elem $t 250 | } else { 251 | set elem [format "%.2f" [expr {double($t)/$ntime}]] 252 | } 253 | if {$opts(output) == "wiki"} { 254 | # do magic highlighting within DELTA% of min or max 255 | if {$t < ($min*(1.0+$opts(delta)))} { 256 | set elem "''$elem''" ; # italic 257 | } elseif {$t > ($max*(1.0-$opts(delta)))} { 258 | set elem "'''$elem'''" ; # bold 259 | } 260 | } 261 | lappend out $elem 262 | } else { 263 | lappend out $t 264 | } 265 | } 266 | return $out 267 | } 268 | } 269 | 270 | proc normalize {norm indata outformat} { 271 | set lines [split $indata \n] 272 | foreach line $lines { 273 | if {!([string match {[0-9]*} $line] || [string match {?|[0-9]*} $line]) 274 | || [string match {*milliseconds} $line]} { 275 | if {$outformat == "wiki"} { 276 | puts stdout " [string trimleft $line]" 277 | } else { 278 | puts stdout $line 279 | } 280 | continue 281 | } 282 | regexp {^(?:[%&]\|)?(\d+)} $line -> num ; # gets first number in line 283 | if {$num == 0} { 284 | # guess format based on first line of version input 285 | if {[string match "0,VER*" $line]} { 286 | set informat csv 287 | } elseif {[string match "0 VER*" $line]} { 288 | set informat list 289 | } elseif {[string match "?|0*|VER*" $line]} { 290 | set informat wiki 291 | } elseif {[string match "0*VER*" $line]} { 292 | set informat text 293 | } else { 294 | puts stderr "Unrecognized runbench format input file '$line'" 295 | exit 296 | } 297 | if {$outformat == ""} { 298 | set outformat $informat 299 | } 300 | } 301 | # Allow separate input/output format, so convert input to list form 302 | if {($informat == $outformat) && $informat == "text"} { 303 | puts stdout [normalize-text $norm $line] 304 | } else { 305 | switch -exact -- $informat { 306 | text { set line [text2list $line] } 307 | csv { set line [csv2list $line] } 308 | wiki { set line [wiki2list $line] } 309 | } 310 | set line [normalize-list $norm $line] 311 | switch -exact -- $outformat { 312 | text { puts stdout [list2text $line] } 313 | list { puts stdout $line } 314 | csv { puts -nonewline stdout [list2csv [list $line]] } 315 | wiki { puts -nonewline stdout [list2wiki $line] } 316 | } 317 | } 318 | } 319 | } 320 | 321 | fconfigure stdout -encoding iso8859-1 ; # avoid utf-8 output 322 | normalize $opts(norm) [read -nonewline $opts(fid)] $opts(output) 323 | -------------------------------------------------------------------------------- /libbench.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # libbench.tcl ?...? 3 | # 4 | # This file has to have code that works in any version of Tcl that 5 | # the user would want to benchmark. 6 | # 7 | # RCS: @(#) $Id$ 8 | # 9 | # Copyright (c) 2000-2001 Jeffrey Hobbs. 10 | 11 | # We will put our data into these named globals 12 | global BENCH bench 13 | 14 | # 15 | # We claim all procedures starting with bench* 16 | # 17 | 18 | # bench_tmpfile -- 19 | # 20 | # Return a temp file name that can be modified at will 21 | # 22 | # Arguments: 23 | # None 24 | # 25 | # Results: 26 | # Returns file name 27 | # 28 | proc bench_tmpfile {} { 29 | global tcl_platform env BENCH 30 | if {![info exists BENCH(uniqid)]} { set BENCH(uniqid) 0 } 31 | set base "tclbench[pid][incr BENCH(uniqid)].dat" 32 | if {[info exists tcl_platform(platform)]} { 33 | if {$tcl_platform(platform) == "unix"} { 34 | return "/tmp/$base" 35 | } elseif {$tcl_platform(platform) == "windows"} { 36 | return [file join $env(TEMP) $base] 37 | } else { 38 | return $base 39 | } 40 | } else { 41 | # The Good Ol' Days (?) when only Unix support existed 42 | return "/tmp/$base" 43 | } 44 | } 45 | 46 | # bench_rm -- 47 | # 48 | # Remove a file silently (no complaining) 49 | # 50 | # Arguments: 51 | # args Files to delete 52 | # 53 | # Results: 54 | # Returns nothing 55 | # 56 | proc bench_rm {args} { 57 | foreach file $args { 58 | if {[info tclversion] > 7.4} { 59 | catch {file delete $file} 60 | } else { 61 | catch {exec /bin/rm $file} 62 | } 63 | } 64 | } 65 | 66 | # bench -- 67 | # 68 | # Main bench procedure. 69 | # The bench test is expected to exit cleanly. If an error occurs, 70 | # it will be thrown all the way up. A bench proc may return the 71 | # special code 666, which says take the string as the bench value. 72 | # This is usually used for N/A feature situations. 73 | # 74 | # Arguments: 75 | # 76 | # -pre script to run before main timed body 77 | # -body script to run as main timed body 78 | # -post script to run after main timed body 79 | # -desc message text 80 | # -iterations <#> 81 | # 82 | # Results: 83 | # 84 | # Returns nothing 85 | # 86 | # Side effects: 87 | # 88 | # Sets up data in bench global array 89 | # 90 | proc bench {args} { 91 | global BENCH bench errorInfo errorCode 92 | 93 | # -pre script 94 | # -body script 95 | # -desc msg 96 | # -post script 97 | # -iterations <#> 98 | array set opts { 99 | -pre {} 100 | -body {} 101 | -desc {} 102 | -post {} 103 | } 104 | set opts(-iter) $BENCH(ITERS) 105 | set opts(-autoscale) $BENCH(AUTOSCALE) 106 | while {[llength $args]} { 107 | set key [lindex $args 0] 108 | set val [lindex $args 1] 109 | switch -glob -- $key { 110 | -auto* { set opts(-autoscale) $val } 111 | -res* { set opts(-res) $val } 112 | -pr* { set opts(-pre) $val } 113 | -po* { set opts(-post) $val } 114 | -bo* { set opts(-body) $val } 115 | -de* { set opts(-desc) $val } 116 | -it* { 117 | # Only change the iterations when it is smaller than 118 | # the requested default 119 | if {$opts(-iter) > $val} { set opts(-iter) $val } 120 | } 121 | default { 122 | error "unknown option $key" 123 | } 124 | } 125 | set args [lreplace $args 0 1] 126 | } 127 | if {($BENCH(MATCH) != "") && ![string match $BENCH(MATCH) $opts(-desc)]} { 128 | return 129 | } 130 | if {($BENCH(RMATCH) != "") && ![regexp $BENCH(RMATCH) $opts(-desc)]} { 131 | return 132 | } 133 | if {$opts(-pre) != ""} { 134 | uplevel \#0 $opts(-pre) 135 | } 136 | if {$opts(-body) != ""} { 137 | # always run it once to remove compile phase confusion 138 | set code [catch {uplevel \#0 $opts(-body)} res] 139 | if {!$code && [info exists opts(-res)] \ 140 | && [string compare $opts(-res) $res]} { 141 | if {$BENCH(ERRORS)} { 142 | return -code error "Result was:\n$res\nResult\ 143 | should have been:\n$opts(-res)" 144 | } else { 145 | set res "BAD_RES" 146 | } 147 | set bench($opts(-desc)) $res 148 | puts $BENCH(OUTFID) [list Sourcing "$opts(-desc): $res"] 149 | } else { 150 | set iter $opts(-iter) 151 | if {!$code && $opts(-autoscale)} { 152 | # Ensure total test runtime is 0.1s < $runtime < 4s. 153 | # time reports in microsecs. 154 | # Do 2nd call to remove catch variance 155 | set runtime [lindex [uplevel \#0 [list time $opts(-body) 1]] 0] 156 | if {$runtime} { 157 | # Guard against 0 runtimes which can happen on fast 158 | # machines with older (pre-nanosecond) time cmd 159 | if {$runtime*$iter < 100000} { 160 | set iter [expr {int(100000.0/$runtime)}] 161 | } elseif {($runtime*$iter/1000.) > 5000} { 162 | set iter [expr {int(4000000.0/$runtime)}] 163 | if {$iter < 8} { set iter 8 } 164 | } 165 | } 166 | } 167 | set code [catch {uplevel \#0 [list time $opts(-body) $iter]} res] 168 | if {!$BENCH(THREADS)} { 169 | if {$code == 0} { 170 | # Get just the microseconds value from the time result 171 | set res [lindex $res 0] 172 | } elseif {$code != 666} { 173 | # A 666 result code means pass it through to the bench 174 | # suite. Otherwise throw errors all the way out, unless 175 | # we specified not to throw errors (option -errors 0 to 176 | # libbench). 177 | if {$BENCH(ERRORS)} { 178 | return -code $code -errorinfo $errorInfo \ 179 | -errorcode $errorCode 180 | } else { 181 | set res "ERR" 182 | } 183 | } 184 | set bench($opts(-desc)) $res 185 | puts $BENCH(OUTFID) [list Sourcing "$opts(-desc): $res"] 186 | } else { 187 | # Threaded runs report back asynchronously 188 | thread::send $BENCH(us) \ 189 | [list thread_report $opts(-desc) $code $res] 190 | } 191 | } 192 | } 193 | if {($opts(-post) != "") && [catch {uplevel \#0 $opts(-post)} err] \ 194 | && $BENCH(ERRORS)} { 195 | return -code error "post code threw error:\n$err" 196 | } 197 | return 198 | } 199 | 200 | proc usage {} { 201 | set me [file tail [info script]] 202 | puts stderr "Usage: $me ?options?\ 203 | \n\t-help # print out this message\ 204 | \n\t-rmatch # only run tests matching this pattern\ 205 | \n\t-match # only run tests matching this pattern\ 206 | \n\t-interp # name of interp (tries to get it right)\ 207 | \n\tfileList # files to benchmark" 208 | exit 1 209 | } 210 | 211 | # 212 | # Process args 213 | # 214 | if {[catch {set BENCH(INTERP) [info nameofexec]}]} { 215 | set BENCH(INTERP) $argv0 216 | } 217 | foreach {var val} { 218 | ERRORS 1 219 | MATCH {} 220 | RMATCH {} 221 | OUTFILE stdout 222 | FILES {} 223 | ITERS 5000 224 | AUTOSCALE 1 225 | THREADS 0 226 | EXIT "[info exists tk_version]" 227 | } { 228 | if {![info exists BENCH($var)]} { 229 | set BENCH($var) [subst $val] 230 | } 231 | } 232 | set BENCH(EXIT) 1 233 | 234 | if {[llength $argv]} { 235 | while {[llength $argv]} { 236 | set key [lindex $argv 0] 237 | set val [lindex $argv 1] 238 | switch -glob -- $key { 239 | -help* { usage } 240 | -err* { set BENCH(ERRORS) $val } 241 | -int* { set BENCH(INTERP) $val } 242 | -rmat* { set BENCH(RMATCH) $val } 243 | -mat* { set BENCH(MATCH) $val } 244 | -auto* { set BENCH(AUTOSCALE) $val } 245 | -iter* { set BENCH(ITERS) $val } 246 | -thr* { set BENCH(THREADS) $val } 247 | default { 248 | foreach arg $argv { 249 | if {![file exists $arg]} { usage } 250 | lappend BENCH(FILES) $arg 251 | } 252 | break 253 | } 254 | } 255 | set argv [lreplace $argv 0 1] 256 | } 257 | } 258 | 259 | if {$BENCH(THREADS)} { 260 | # We have to be able to load threads if we want to use threads, and 261 | # we don't want to create more threads than we have files. 262 | if {[catch {package require Thread}]} { 263 | set BENCH(THREADS) 0 264 | } elseif {[llength $BENCH(FILES)] < $BENCH(THREADS)} { 265 | set BENCH(THREADS) [llength $BENCH(FILES)] 266 | } 267 | } 268 | 269 | rename exit exit.true 270 | proc exit args { 271 | error "called \"exit $args\" in benchmark test" 272 | } 273 | 274 | if {[string compare $BENCH(OUTFILE) stdout]} { 275 | set BENCH(OUTFID) [open $BENCH(OUTFILE) w] 276 | } else { 277 | set BENCH(OUTFID) stdout 278 | } 279 | 280 | # 281 | # Everything that gets output must be in pairwise format, because 282 | # the data will be collected in via an 'array set'. 283 | # 284 | 285 | if {$BENCH(THREADS)} { 286 | # Each file must run in it's own thread because of all the extra 287 | # header stuff they have. 288 | #set DEBUG 1 289 | proc thread_one {{id 0}} { 290 | global BENCH 291 | set file [lindex $BENCH(FILES) 0] 292 | set BENCH(FILES) [lrange $BENCH(FILES) 1 end] 293 | if {[file exists $file]} { 294 | incr BENCH(inuse) 295 | puts $BENCH(OUTFID) [list Sourcing $file] 296 | if {$id} { 297 | set them $id 298 | } else { 299 | set them [thread::create] 300 | thread::send -async $them { load {} Thread } 301 | thread::send -async $them \ 302 | [list array set BENCH [array get BENCH]] 303 | thread::send -async $them \ 304 | [list proc bench_tmpfile {} [info body bench_tmpfile]] 305 | thread::send -async $them \ 306 | [list proc bench_rm {args} [info body bench_rm]] 307 | thread::send -async $them \ 308 | [list proc bench {args} [info body bench]] 309 | } 310 | if {[info exists ::DEBUG]} { 311 | puts stderr "SEND [clock seconds] thread $them $file INUSE\ 312 | $BENCH(inuse) of $BENCH(THREADS)" 313 | } 314 | thread::send -async $them [list source $file] 315 | thread::send -async $them \ 316 | [list thread::send $BENCH(us) [list thread_ready $them]] 317 | #thread::send -async $them { thread::unwind } 318 | } 319 | } 320 | 321 | proc thread_em {} { 322 | global BENCH 323 | while {[llength $BENCH(FILES)]} { 324 | if {[info exists ::DEBUG]} { 325 | puts stderr "THREAD ONE [lindex $BENCH(FILES) 0]" 326 | } 327 | thread_one 328 | if {$BENCH(inuse) >= $BENCH(THREADS)} { 329 | break 330 | } 331 | } 332 | } 333 | 334 | proc thread_ready {id} { 335 | global BENCH 336 | 337 | incr BENCH(inuse) -1 338 | if {[llength $BENCH(FILES)]} { 339 | if {[info exists ::DEBUG]} { 340 | puts stderr "SEND ONE [clock seconds] thread $id" 341 | } 342 | thread_one $id 343 | } else { 344 | if {[info exists ::DEBUG]} { 345 | puts stderr "UNWIND thread $id" 346 | } 347 | thread::send -async $id { thread::unwind } 348 | } 349 | } 350 | 351 | proc thread_report {desc code res} { 352 | global BENCH bench errorInfo errorCode 353 | 354 | if {$code == 0} { 355 | # Get just the microseconds value from the time result 356 | set res [lindex $res 0] 357 | } elseif {$code != 666} { 358 | # A 666 result code means pass it through to the bench suite. 359 | # Otherwise throw errors all the way out, unless we specified 360 | # not to throw errors (option -errors 0 to libbench). 361 | if {$BENCH(ERRORS)} { 362 | return -code $code -errorinfo $errorInfo \ 363 | -errorcode $errorCode 364 | } else { 365 | set res "ERR" 366 | } 367 | } 368 | set bench($desc) $res 369 | } 370 | 371 | proc thread_finish {{delay 4000}} { 372 | global BENCH bench 373 | set val [expr {[llength [thread::names]] > 1}] 374 | #set val [expr {$BENCH(inuse)}] 375 | if {$val} { 376 | after $delay [info level 0] 377 | } else { 378 | foreach desc [array names bench] { 379 | puts $BENCH(OUTFID) [list $desc $bench($desc)] 380 | } 381 | if {$BENCH(EXIT)} { 382 | exit.true ; # needed for Tk tests 383 | } 384 | } 385 | } 386 | 387 | set BENCH(us) [thread::id] 388 | set BENCH(inuse) 0 ; # num threads in use 389 | puts $BENCH(OUTFID) [list __THREADED [package provide Thread]] 390 | 391 | thread_em 392 | thread_finish 393 | vwait forever 394 | } else { 395 | foreach BENCH(file) $BENCH(FILES) { 396 | if {[file exists $BENCH(file)]} { 397 | puts $BENCH(OUTFID) [list Sourcing $BENCH(file)] 398 | source $BENCH(file) 399 | } 400 | } 401 | 402 | foreach desc [array names bench] { 403 | puts $BENCH(OUTFID) [list $desc $bench($desc)] 404 | } 405 | if {[llength [info commands evalstats]]} { 406 | puts stdout [list ZZZ_STATS [evalstats]] 407 | } 408 | 409 | if {$BENCH(EXIT)} { 410 | exit.true ; # needed for Tk tests 411 | } 412 | } 413 | -------------------------------------------------------------------------------- /tcl/base64.bench: -------------------------------------------------------------------------------- 1 | # base64.tcl -- 2 | # 3 | # Encode/Decode base64 for a string 4 | # Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems 5 | # The decoder was done for exmh by Chris Garrigues 6 | # 7 | # stripped versions of the originals to work in 8.0. 8 | # 9 | # Copyright (c) 1998-2000 by Ajuba Solutions. 10 | # See the file "license.terms" for information on usage and redistribution 11 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 | # 13 | # RCS: @(#) $Id$ 14 | 15 | if {[catch {package require Tcl 8.0}]} { 16 | return 17 | } 18 | 19 | namespace eval base64 { 20 | proc init {} { 21 | variable base64 22 | variable base64_en 23 | variable base64en {} 24 | set i 0 25 | foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \ 26 | a b c d e f g h i j k l m n o p q r s t u v w x y z \ 27 | 0 1 2 3 4 5 6 7 8 9 + /} { 28 | set base64($char) $i 29 | set base64_en($i) $char 30 | lappend base64en $char 31 | incr i 32 | } 33 | } 34 | init 35 | 36 | namespace export *code* 37 | } 38 | 39 | proc base64::encode {string} { 40 | variable base64_en 41 | 42 | set wrapchar "\n" 43 | set maxlen 60 44 | 45 | set result {} 46 | set state 0 47 | set length 0 48 | foreach {c} [split $string {}] { 49 | # Do the line length check before appending so that we don't get an 50 | # extra newline if the output is a multiple of $maxlen chars long. 51 | if {$maxlen && $length >= $maxlen} { 52 | append result $wrapchar 53 | set length 0 54 | } 55 | scan $c %c x 56 | incr state 57 | if {$state == 1} { 58 | append result $base64_en([expr {($x >>2) & 0x3F}]) 59 | } elseif {$state == 2} { 60 | append result \ 61 | $base64_en([expr {(($old << 4) & 0x30)|(($x >> 4) & 0xF)}]) 62 | } elseif {$state == 3} { 63 | append result \ 64 | $base64_en([expr {(($old << 2) & 0x3C)|(($x >> 6) & 0x3)}]) 65 | append result $base64_en([expr {($x & 0x3F)}]) 66 | incr length 67 | set state 0 68 | } 69 | set old $x 70 | incr length 71 | } 72 | set x 0 73 | # state 0 is OK 74 | if {$state == 1} { 75 | append result $base64_en([expr {(($old << 4) & 0x30)}])== 76 | } elseif {$state == 2} { 77 | append result $base64_en([expr {(($old << 2) & 0x3C)}])= 78 | } 79 | return $result 80 | } 81 | 82 | proc base64::encode2 {string} { 83 | variable base64en 84 | 85 | set wrapchar "\n" 86 | set maxlen 60 87 | 88 | set result {} 89 | set state 0 90 | set length 0 91 | foreach {c} [split $string {}] { 92 | # Do the line length check before appending so that we don't get an 93 | # extra newline if the output is a multiple of $maxlen chars long. 94 | if {$maxlen && $length >= $maxlen} { 95 | append result $wrapchar 96 | set length 0 97 | } 98 | scan $c %c x 99 | incr state 100 | if {$state == 1} { 101 | append result [lindex $base64en [expr {($x >>2) & 0x3F}]] 102 | } elseif {$state == 2} { 103 | append result [lindex $base64en \ 104 | [expr {(($old << 4) & 0x30)|(($x >> 4) & 0xF)}]] 105 | } elseif {$state == 3} { 106 | append result [lindex $base64en \ 107 | [expr {(($old << 2) & 0x3C)|(($x >> 6) & 0x3)}]] 108 | append result [lindex $base64en [expr {($x & 0x3F)}]] 109 | incr length 110 | set state 0 111 | } 112 | set old $x 113 | incr length 114 | } 115 | set x 0 116 | # state 0 is OK 117 | if {$state == 1} { 118 | append result [lindex $base64en [expr {(($old << 4) & 0x30)}]]== 119 | } elseif {$state == 2} { 120 | append result [lindex $base64en [expr {(($old << 2) & 0x3C)}]]= 121 | } 122 | return $result 123 | } 124 | 125 | proc base64::decode {string} { 126 | variable base64 127 | 128 | set output {} 129 | set group 0 130 | set j 18 131 | foreach char [split $string {}] { 132 | if {[string compare $char "="]} { 133 | # RFC 2045 says that line breaks and other characters not part 134 | # of the Base64 alphabet must be ignored, and that the decoder 135 | # can optionally emit a warning or reject the message. We opt 136 | # not to do so, but to just ignore the character. 137 | 138 | if { ![info exists base64($char)] } { 139 | continue 140 | } 141 | set bits $base64($char) 142 | set group [expr {$group | ($bits << $j)}] 143 | if {[incr j -6] < 0} { 144 | scan [format %06x $group] %2x%2x%2x a b c 145 | append output [format %c%c%c $a $b $c] 146 | set group 0 147 | set j 18 148 | } 149 | } else { 150 | # = indicates end of data. Output whatever chars are left. 151 | # The encoding algorithm dictates that we can only have 1 or 2 152 | # padding characters. If j is 6, we have 12 bits of input 153 | # (enough for 1 8-bit output). If j is 0, we have 18 bits of 154 | # input (enough for 2 8-bit outputs). 155 | # It is crucial to scan three hex digits even though we 156 | # discard c - older code used %04x and scanned 2 hex digits 157 | # but really ended up generating 5 or 6 (not 4!) digits and 158 | # resulted in alignment errors. 159 | 160 | scan [format %06x $group] %2x%2x%2x a b c 161 | if {$j == 6} { 162 | append output [format %c $a] 163 | } elseif {$j == 0} { 164 | append output [format %c%c $a $b] 165 | } 166 | break 167 | } 168 | } 169 | return $output 170 | } 171 | 172 | proc base64::decode2 {string} { 173 | variable base64 174 | 175 | set output {} 176 | set group 0 177 | set j 18 178 | foreach char [split $string {}] { 179 | if {![string compare $char "="]} { 180 | # = indicates end of data. Output whatever chars are left. 181 | # The encoding algorithm dictates that we can only have 1 or 2 182 | # padding characters. If j is 6, we have 12 bits of input 183 | # (enough for 1 8-bit output). If j is 0, we have 18 bits of 184 | # input (enough for 2 8-bit outputs). 185 | # It is crucial to scan three hex digits even though we 186 | # discard c - older code used %04x and scanned 2 hex digits 187 | # but really ended up generating 5 or 6 (not 4!) digits and 188 | # resulted in alignment errors. 189 | 190 | scan [format %06x $group] %2x%2x%2x a b c 191 | if {$j == 6} { 192 | append output [format %c $a] 193 | } elseif {$j == 0} { 194 | append output [format %c%c $a $b] 195 | } 196 | break 197 | } elseif {[info exists base64($char)]} { 198 | # RFC 2045 says that line breaks and other characters not part 199 | # of the Base64 alphabet must be ignored, and that the decoder 200 | # can optionally emit a warning or reject the message. We opt 201 | # not to do so, but to just ignore the character. 202 | 203 | set group [expr {$group | ($base64($char) << $j)}] 204 | if {[incr j -6] < 0} { 205 | scan [format %06x $group] %2x%2x%2x a b c 206 | append output [format %c%c%c $a $b $c] 207 | set group 0 208 | set j 18 209 | } 210 | } 211 | } 212 | return $output 213 | } 214 | 215 | # 216 | # This is the code from 217 | # tcllib/modules/base64/base64.tcl version 2.2.1 218 | # 219 | 220 | namespace eval base64_3 { 221 | variable base64 {} 222 | variable base64_en {} 223 | 224 | # We create the auxiliary array base64_tmp, it will be unset later. 225 | 226 | set i 0 227 | foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \ 228 | a b c d e f g h i j k l m n o p q r s t u v w x y z \ 229 | 0 1 2 3 4 5 6 7 8 9 + /} { 230 | set base64_tmp($char) $i 231 | lappend base64_en $char 232 | incr i 233 | } 234 | 235 | # 236 | # Create base64 as list: to code for instance C<->3, specify 237 | # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded 238 | # ascii chars get a {}. we later use the fact that lindex on a 239 | # non-existing index returns {}, and that [expr {} < 0] is true 240 | # 241 | 242 | # the last ascii char is 'z' 243 | scan z %c len 244 | for {set i 0} {$i <= $len} {incr i} { 245 | set char [format %c $i] 246 | set val {} 247 | if {[info exists base64_tmp($char)]} { 248 | set val $base64_tmp($char) 249 | } else { 250 | set val {} 251 | } 252 | lappend base64 $val 253 | } 254 | 255 | # code the character "=" as -1; used to signal end of message 256 | scan = %c i 257 | set base64 [lreplace $base64 $i $i -1] 258 | 259 | # remove unneeded variables 260 | unset base64_tmp i char len val 261 | 262 | namespace export encode decode 263 | } 264 | 265 | # base64::encode -- 266 | # 267 | # Base64 encode a given string. 268 | # 269 | # Arguments: 270 | # args ?-maxlen maxlen? ?-wrapchar wrapchar? string 271 | # 272 | # If maxlen is 0, the output is not wrapped. 273 | # 274 | # Results: 275 | # A Base64 encoded version of $string, wrapped at $maxlen characters 276 | # by $wrapchar. 277 | 278 | proc base64_3::encode {args} { 279 | set base64_en $::base64_3::base64_en 280 | 281 | # Set the default wrapchar and maximum line length to match the output 282 | # of GNU uuencode 4.2. Various RFC's allow for different wrapping 283 | # characters and wraplengths, so these may be overridden by command line 284 | # options. 285 | set wrapchar "\n" 286 | set maxlen 60 287 | 288 | if { [llength $args] == 0 } { 289 | error "wrong # args: should be \"[lindex [info level 0] 0]\ 290 | ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" 291 | } 292 | 293 | set optionStrings [list "-maxlen" "-wrapchar"] 294 | for {set i 0} {$i < [llength $args] - 1} {incr i} { 295 | set arg [lindex $args $i] 296 | set index [lsearch -glob $optionStrings "${arg}*"] 297 | if { $index == -1 } { 298 | error "unknown option \"$arg\": must be -maxlen or -wrapchar" 299 | } 300 | incr i 301 | if { $i >= [llength $args] - 1 } { 302 | error "value for \"$arg\" missing" 303 | } 304 | set val [lindex $args $i] 305 | 306 | # The name of the variable to assign the value to is extracted 307 | # from the list of known options, all of which have an 308 | # associated variable of the same name as the option without 309 | # a leading "-". The [string range] command is used to strip 310 | # of the leading "-" from the name of the option. 311 | # 312 | # FRINK: nocheck 313 | set [string range [lindex $optionStrings $index] 1 end] $val 314 | } 315 | 316 | # [string is] requires Tcl8.2; this works with 8.0 too 317 | if {[catch {expr {$maxlen % 2}}]} { 318 | error "expected integer but got \"$maxlen\"" 319 | } 320 | 321 | set string [lindex $args end] 322 | 323 | set result {} 324 | set state 0 325 | set length 0 326 | 327 | 328 | # Process the input bytes 3-by-3 329 | 330 | binary scan $string c* X 331 | foreach {x y z} $X { 332 | # Do the line length check before appending so that we don't get an 333 | # extra newline if the output is a multiple of $maxlen chars long. 334 | if {$maxlen && $length >= $maxlen} { 335 | append result $wrapchar 336 | set length 0 337 | } 338 | 339 | append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] 340 | if {$y != {}} { 341 | append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] 342 | if {$z != {}} { 343 | append result \ 344 | [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] 345 | append result [lindex $base64_en [expr {($z & 0x3F)}]] 346 | } else { 347 | set state 2 348 | break 349 | } 350 | } else { 351 | set state 1 352 | break 353 | } 354 | incr length 4 355 | } 356 | if {$state == 1} { 357 | append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== 358 | } elseif {$state == 2} { 359 | append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]= 360 | } 361 | return $result 362 | } 363 | 364 | # base64::decode -- 365 | # 366 | # Base64 decode a given string. 367 | # 368 | # Arguments: 369 | # string The string to decode. Characters not in the base64 370 | # alphabet are ignored (e.g., newlines) 371 | # 372 | # Results: 373 | # The decoded value. 374 | 375 | proc base64_3::decode {string} { 376 | if {[string length $string] == 0} {return ""} 377 | 378 | set base64 $::base64_3::base64 379 | 380 | binary scan $string c* X 381 | foreach x $X { 382 | set bits [lindex $base64 $x] 383 | if {$bits >= 0} { 384 | if {[llength [lappend nums $bits]] == 4} { 385 | foreach {v w z y} $nums break 386 | set a [expr {($v << 2) | ($w >> 4)}] 387 | set b [expr {(($w & 0xF) << 4) | ($z >> 2)}] 388 | set c [expr {(($z & 0x3) << 6) | $y}] 389 | append output [binary format ccc $a $b $c] 390 | set nums {} 391 | } 392 | } elseif {$bits == -1} { 393 | # = indicates end of data. Output whatever chars are left. 394 | # The encoding algorithm dictates that we can only have 1 or 2 395 | # padding characters. If x=={}, we have 12 bits of input 396 | # (enough for 1 8-bit output). If x!={}, we have 18 bits of 397 | # input (enough for 2 8-bit outputs). 398 | 399 | foreach {v w z} $nums break 400 | set a [expr {($v << 2) | (($w & 0x30) >> 4)}] 401 | 402 | if {$z == {}} { 403 | append output [binary format c $a ] 404 | } else { 405 | set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] 406 | append output [binary format cc $a $b] 407 | } 408 | break 409 | } else { 410 | # RFC 2045 says that line breaks and other characters not part 411 | # of the Base64 alphabet must be ignored, and that the decoder 412 | # can optionally emit a warning or reject the message. We opt 413 | # not to do so, but to just ignore the character. 414 | continue 415 | } 416 | } 417 | return $output 418 | } 419 | 420 | if { [catch {string repeat "abc" 10}] } { 421 | proc str-repeat {str num} { 422 | set val {} 423 | for {set i 0} {$i < $num} {incr i} { 424 | append val $str 425 | } 426 | set val 427 | } 428 | } else { 429 | proc str-repeat {str num} { 430 | string repeat $str $num 431 | } 432 | } 433 | 434 | foreach len {10 100 1000 10000} \ 435 | iter {100 40 20 10} { 436 | # works for 8.2+ only 437 | set str [str-repeat "aZA(8)% -a" [expr {$len/10}]] 438 | set encstr [base64::encode $str] 439 | bench -desc "BASE64 encode $len" -iter $iter \ 440 | -body {base64::encode $str} 441 | bench -desc "BASE64 encode2 $len" -iter $iter \ 442 | -body {base64::encode2 $str} -result $encstr 443 | bench -desc "BASE64 encode3 $len" -iter $iter \ 444 | -body {base64_3::encode $str} -result $encstr 445 | bench -desc "BASE64 decode $len" -iter $iter \ 446 | -body {base64::decode $encstr} -result $str 447 | bench -desc "BASE64 decode2 $len" -iter $iter \ 448 | -body {base64::decode2 $encstr} -result $str 449 | bench -desc "BASE64 decode3 $len" -iter $iter \ 450 | -body {base64_3::decode $encstr} -result $str 451 | } 452 | -------------------------------------------------------------------------------- /tcl/sha1.bench: -------------------------------------------------------------------------------- 1 | # sha1.tcl - 2 | # 3 | # Copyright (C) 2001 Don Libes 4 | # Copyright (C) 2003 Pat Thoyts 5 | # 6 | # SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm" 7 | # 8 | # This is an implementation of SHA1 based upon the example code given in 9 | # FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas 10 | # and methods from the earlier tcllib sha1 version by Don Libes. 11 | # 12 | # Adapted from tcllib for benchmark use only, no C accelerators. 13 | # See tcllib sha1 module for latest version and more details. 14 | # 15 | # $Id$ 16 | 17 | if {[catch {package require Tcl 8.2}]} { # tcl minimum version 18 | return 19 | } 20 | 21 | namespace eval ::sha1 { 22 | variable version 2.0.2 23 | 24 | namespace export sha1 SHA1Init SHA1Update SHA1Final 25 | 26 | variable uid 27 | if {![info exists uid]} { 28 | set uid 0 29 | } 30 | } 31 | 32 | # ------------------------------------------------------------------------- 33 | 34 | # SHA1Init -- 35 | # 36 | # Create and initialize an SHA1 state variable. This will be 37 | # cleaned up when we call SHA1Final 38 | # 39 | proc ::sha1::SHA1Init {} { 40 | variable uid 41 | set token [namespace current]::[incr uid] 42 | upvar #0 $token state 43 | 44 | # FIPS 180-1: 7 - Initialize the hash state 45 | array set state \ 46 | [list \ 47 | A [expr {int(0x67452301)}] \ 48 | B [expr {int(0xEFCDAB89)}] \ 49 | C [expr {int(0x98BADCFE)}] \ 50 | D [expr {int(0x10325476)}] \ 51 | E [expr {int(0xC3D2E1F0)}] \ 52 | n 0 i "" ] 53 | return $token 54 | } 55 | 56 | # SHA1Update -- 57 | # 58 | # This is called to add more data into the hash. You may call this 59 | # as many times as you require. Note that passing in "ABC" is equivalent 60 | # to passing these letters in as separate calls -- hence this proc 61 | # permits hashing of chunked data 62 | # 63 | # If we have a C-based implementation available, then we will use 64 | # it here in preference to the pure-Tcl implementation. 65 | # 66 | proc ::sha1::SHA1Update {token data} { 67 | upvar #0 $token state 68 | 69 | # Update the state values 70 | incr state(n) [string length $data] 71 | append state(i) $data 72 | 73 | # Calculate the hash for any complete blocks 74 | set len [string length $state(i)] 75 | for {set n 0} {($n + 64) <= $len} {} { 76 | SHA1Transform $token [string range $state(i) $n [incr n 64]] 77 | } 78 | 79 | # Adjust the state for the blocks completed. 80 | set state(i) [string range $state(i) $n end] 81 | return 82 | } 83 | 84 | # SHA1Final -- 85 | # 86 | # This procedure is used to close the current hash and returns the 87 | # hash data. Once this procedure has been called the hash context 88 | # is freed and cannot be used again. 89 | # 90 | # Note that the output is 160 bits represented as binary data. 91 | # 92 | proc ::sha1::SHA1Final {token} { 93 | upvar #0 $token state 94 | 95 | # Padding 96 | # 97 | set len [string length $state(i)] 98 | set pad [expr {56 - ($len % 64)}] 99 | if {$len % 64 > 56} { 100 | incr pad 64 101 | } 102 | if {$pad == 0} { 103 | incr pad 64 104 | } 105 | append state(i) [binary format a$pad \x80] 106 | 107 | # Append length in bits as big-endian wide int. 108 | set dlen [expr {8 * $state(n)}] 109 | append state(i) [binary format II 0 $dlen] 110 | 111 | # Calculate the hash for the remaining block. 112 | set len [string length $state(i)] 113 | for {set n 0} {($n + 64) <= $len} {} { 114 | SHA1Transform $token [string range $state(i) $n [incr n 64]] 115 | } 116 | 117 | # Output 118 | set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)] 119 | unset state 120 | return $r 121 | } 122 | 123 | # ------------------------------------------------------------------------- 124 | # Description: 125 | # This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but 126 | # includes an extra round and a set of constant modifiers throughout. 127 | # 128 | set ::sha1::SHA1Transform_body { 129 | upvar #0 $token state 130 | 131 | # FIPS 180-1: 7a: Process Message in 16-Word Blocks 132 | binary scan $msg I* blocks 133 | set blockLen [llength $blocks] 134 | for {set i 0} {$i < $blockLen} {incr i 16} { 135 | set W [lrange $blocks $i [expr {$i+15}]] 136 | 137 | # FIPS 180-1: 7b: Expand the input into 80 words 138 | # For t = 16 to 79 139 | # let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1 140 | set t3 12 141 | set t8 7 142 | set t14 1 143 | set t16 -1 144 | for {set t 16} {$t < 80} {incr t} { 145 | set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \ 146 | [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}] 147 | lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}] 148 | } 149 | 150 | # FIPS 180-1: 7c: Copy hash state. 151 | set A $state(A) 152 | set B $state(B) 153 | set C $state(C) 154 | set D $state(D) 155 | set E $state(E) 156 | 157 | # FIPS 180-1: 7d: Do permutation rounds 158 | # For t = 0 to 79 do 159 | # TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt; 160 | # E = D; D = C; C = S30(B); B = A; A = TEMP; 161 | 162 | # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19) 163 | for {set t 0} {$t < 20} {incr t} { 164 | set TEMP [F1 $A $B $C $D $E [lindex $W $t]] 165 | set E $D 166 | set D $C 167 | set C [rotl32 $B 30] 168 | set B $A 169 | set A $TEMP 170 | } 171 | 172 | # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39) 173 | for {} {$t < 40} {incr t} { 174 | set TEMP [F2 $A $B $C $D $E [lindex $W $t]] 175 | set E $D 176 | set D $C 177 | set C [rotl32 $B 30] 178 | set B $A 179 | set A $TEMP 180 | } 181 | 182 | # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59) 183 | for {} {$t < 60} {incr t} { 184 | set TEMP [F3 $A $B $C $D $E [lindex $W $t]] 185 | set E $D 186 | set D $C 187 | set C [rotl32 $B 30] 188 | set B $A 189 | set A $TEMP 190 | } 191 | 192 | # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79) 193 | for {} {$t < 80} {incr t} { 194 | set TEMP [F4 $A $B $C $D $E [lindex $W $t]] 195 | set E $D 196 | set D $C 197 | set C [rotl32 $B 30] 198 | set B $A 199 | set A $TEMP 200 | } 201 | 202 | # Then perform the following additions. (That is, increment each 203 | # of the four registers by the value it had before this block 204 | # was started.) 205 | incr state(A) $A 206 | incr state(B) $B 207 | incr state(C) $C 208 | incr state(D) $D 209 | incr state(E) $E 210 | } 211 | 212 | return 213 | } 214 | 215 | proc ::sha1::F1 {A B C D E W} { 216 | expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ 217 | + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff} 218 | } 219 | 220 | proc ::sha1::F2 {A B C D E W} { 221 | expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ 222 | + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff} 223 | } 224 | 225 | proc ::sha1::F3 {A B C D E W} { 226 | expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ 227 | + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff} 228 | } 229 | 230 | proc ::sha1::F4 {A B C D E W} { 231 | expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ 232 | + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff} 233 | } 234 | 235 | proc ::sha1::rotl32 {v n} { 236 | return [expr {((($v << $n) 237 | | (($v >> (32 - $n)) 238 | & (0x7FFFFFFF >> (31 - $n))))) & 0xFFFFFFFF}] 239 | } 240 | 241 | 242 | # ------------------------------------------------------------------------- 243 | # 244 | # In order to get this code to go as fast as possible while leaving 245 | # the main code readable we can substitute the above function bodies 246 | # into the transform procedure. This inlines the code for us an avoids 247 | # a procedure call overhead within the loops. 248 | # 249 | # We can do some minor tweaking to improve speed on Tcl < 8.5 where we 250 | # know our arithmetic is limited to 64 bits. On > 8.5 we may have 251 | # unconstrained integer arithmetic and must avoid letting it run away. 252 | # 253 | 254 | regsub -all -line \ 255 | {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ 256 | $::sha1::SHA1Transform_body \ 257 | {[expr {(((rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) \& 0xffffffff) + $E \& 0xffffffff) + \1 + 0x5a827999) \& 0xffffffff}]} \ 258 | ::sha1::SHA1Transform_body_tmp 259 | 260 | regsub -all -line \ 261 | {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ 262 | $::sha1::SHA1Transform_body_tmp \ 263 | {[expr {(((rotl32($A,5) + ($B ^ $C ^ $D) \& 0xffffffff) + $E \& 0xffffffff) + \1 + 0x6ed9eba1) \& 0xffffffff}]} \ 264 | ::sha1::SHA1Transform_body_tmp 265 | 266 | regsub -all -line \ 267 | {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ 268 | $::sha1::SHA1Transform_body_tmp \ 269 | {[expr {(((rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) \& 0xffffffff) + $E \& 0xffffffff) + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \ 270 | ::sha1::SHA1Transform_body_tmp 271 | 272 | regsub -all -line \ 273 | {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ 274 | $::sha1::SHA1Transform_body_tmp \ 275 | {[expr {(((rotl32($A,5) + ($B ^ $C ^ $D) \& 0xffffffff) + $E \& 0xffffffff) + \1 + 0xca62c1d6) \& 0xffffffff}]} \ 276 | ::sha1::SHA1Transform_body_tmp 277 | 278 | regsub -all -line \ 279 | {rotl32\(\$A,5\)} \ 280 | $::sha1::SHA1Transform_body_tmp \ 281 | {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \ 282 | ::sha1::SHA1Transform_body_tmp 283 | 284 | regsub -all -line \ 285 | {\[rotl32 \$B 30\]} \ 286 | $::sha1::SHA1Transform_body_tmp \ 287 | {[expr {(($B << 30) \& 0xffffffff) | (($B >> 2) \& 0x3fffffff)}]} \ 288 | ::sha1::SHA1Transform_body_tmp 289 | 290 | proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp 291 | 292 | # ------------------------------------------------------------------------- 293 | 294 | proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} 295 | proc ::sha1::bytes {v} { 296 | #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] 297 | format %c%c%c%c \ 298 | [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \ 299 | [expr {(0xFF0000 & $v) >> 16}] \ 300 | [expr {(0xFF00 & $v) >> 8}] \ 301 | [expr {0xFF & $v}] 302 | } 303 | 304 | # ------------------------------------------------------------------------- 305 | 306 | proc ::sha1::Hex {data} { 307 | binary scan $data H* result 308 | return $result 309 | } 310 | 311 | # ------------------------------------------------------------------------- 312 | 313 | # Description: 314 | # Pop the nth element off a list. Used in options processing. 315 | # 316 | proc ::sha1::Pop {varname {nth 0}} { 317 | upvar 1 $varname args 318 | set r [lindex $args $nth] 319 | set args [lreplace $args $nth $nth] 320 | return $r 321 | } 322 | 323 | # ------------------------------------------------------------------------- 324 | 325 | # fileevent handler for chunked file hashing. 326 | # 327 | proc ::sha1::Chunk {token channel {chunksize 4096}} { 328 | upvar #0 $token state 329 | 330 | if {[eof $channel]} { 331 | fileevent $channel readable {} 332 | set state(reading) 0 333 | } 334 | 335 | SHA1Update $token [read $channel $chunksize] 336 | } 337 | 338 | # ------------------------------------------------------------------------- 339 | 340 | proc ::sha1::sha1 {args} { 341 | array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} 342 | if {[llength $args] == 1} { 343 | set opts(-hex) 1 344 | } else { 345 | while {[string match -* [set option [lindex $args 0]]]} { 346 | switch -glob -- $option { 347 | -hex { set opts(-hex) 1 } 348 | -bin { set opts(-hex) 0 } 349 | -file* { set opts(-filename) [Pop args 1] } 350 | -channel { set opts(-channel) [Pop args 1] } 351 | -chunksize { set opts(-chunksize) [Pop args 1] } 352 | default { 353 | if {[llength $args] == 1} { break } 354 | if {[string compare $option "--"] == 0} { Pop args; break } 355 | set err [join [lsort [concat -bin [array names opts]]] ", "] 356 | return -code error "bad option $option:\ 357 | must be one of $err" 358 | } 359 | } 360 | Pop args 361 | } 362 | } 363 | 364 | if {$opts(-filename) != {}} { 365 | set opts(-channel) [open $opts(-filename) r] 366 | fconfigure $opts(-channel) -translation binary 367 | } 368 | 369 | if {$opts(-channel) == {}} { 370 | 371 | if {[llength $args] != 1} { 372 | return -code error "wrong # args:\ 373 | should be \"sha1 ?-hex? -filename file | string\"" 374 | } 375 | set tok [SHA1Init] 376 | SHA1Update $tok [lindex $args 0] 377 | set r [SHA1Final $tok] 378 | 379 | } else { 380 | 381 | set tok [SHA1Init] 382 | # FRINK: nocheck 383 | set [subst $tok](reading) 1 384 | fileevent $opts(-channel) readable \ 385 | [list [namespace origin Chunk] \ 386 | $tok $opts(-channel) $opts(-chunksize)] 387 | # FRINK: nocheck 388 | vwait [subst $tok](reading) 389 | set r [SHA1Final $tok] 390 | 391 | # If we opened the channel - we should close it too. 392 | if {$opts(-filename) != {}} { 393 | close $opts(-channel) 394 | } 395 | } 396 | 397 | if {$opts(-hex)} { 398 | set r [Hex $r] 399 | } 400 | return $r 401 | } 402 | 403 | # Start of tcl bench code... 404 | 405 | if { [catch {string repeat "abc" 10}] } { 406 | proc str-repeat {str num} { 407 | set val {} 408 | for {set i 0} {$i < $num} {incr i} { 409 | append val $str 410 | } 411 | set val 412 | } 413 | } else { 414 | proc str-repeat {str num} { 415 | string repeat $str $num 416 | } 417 | } 418 | 419 | foreach len {10 100 1000 10000} iter {100 40 20 10} { 420 | set str [str-repeat a $len] 421 | bench -desc "SHA1 msg len $len" -iter $iter -body {::sha1::sha1 $str} 422 | } 423 | 424 | # ------------------------------------------------------------------------- 425 | # Local Variables: 426 | # mode: tcl 427 | # indent-tabs-mode: nil 428 | # End: 429 | 430 | 431 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2011-01-19 Jeff Hobbs 2 | 3 | * tcl/format.bench (new): bench for 'format' 4 | 5 | * runbench.tcl (parseOpts): fix scoping and -paths arg handling 6 | 7 | 2010-12-02 Jeff Hobbs 8 | 9 | * runbench.tcl (parseOpts): fix var scoping 10 | Make -repeat really be repeat runs and adjust auto-scale to work 11 | with repeats. 12 | 13 | 2010-12-01 Jeff Hobbs 14 | 15 | * tcl/sha1.bench: use only SHA1 algorithm that works across 16 | versions. The variant didn't add any extra value. Also strip out 17 | the unused code that wasn't relevant to the benchmark. 18 | 19 | 2010-11-30 Jeff Hobbs 20 | 21 | * runbench.tcl: add -repeat and -collate options that allow for 22 | multiple runs to be accumulated and collate to be min, max or avg 23 | value of runs. 24 | 25 | * tcl/expr.bench (UpdStrOfDbl): improve UpdStrOfDbl benchmarks 26 | 27 | * runbench.tcl (collectData): warn if autoscale is on that the 28 | total elapsed time gets skewed 29 | 30 | * libbench.tcl: spit out evalstats info if available 31 | 32 | 2010-11-09 Jeff Hobbs 33 | 34 | * tcl/expr.bench (expr-UpdateStringOfDouble): add TIP#132 35 | UpdateStringOfDouble slowdown benchmark 36 | 37 | 2010-10-01 Jeff Hobbs 38 | 39 | * tcl/binary.bench: add improved random binary string bench 40 | 41 | * runbench.tcl: clean up arg handling, add -single $bool option to 42 | run all tests in same interp instance (default no == separate). 43 | 44 | 2010-09-27 Jeff Hobbs 45 | 46 | * normbench.tcl: support -normalize "none" to mean just change 47 | formats but not normalize 48 | 49 | * libbench.tcl (bench): guard again "0" claimed runtime speed 50 | (bench_tmpfile): add pid to tmpfile 51 | 52 | * tcl/binary.bench: bench to generate random binary 53 | 54 | * tcl/ascii85.bench (new): ascii85 benchmarks, works for 8.4+ 55 | 56 | * tcl/uplevel.bench: works for 8.0+ only 57 | 58 | * tcl/expr.bench: more simple expr benchmarks 59 | 60 | * tcl/eval.bench (e-cmd-expand): add {*} benchmark 61 | 62 | * runbench.tcl, libbench.tcl: add -autoscale option that ensures 63 | min and max runtime length independent of iters requested. 64 | 65 | * tcl/read.bench (read-cat): make sure to close /dev/null 66 | 67 | 2010-09-24 Jeff Hobbs 68 | 69 | * tcl/string.bench: add binary string compare benchmarks 70 | 71 | 2010-09-22 Jeff Hobbs 72 | 73 | * runbench.tcl: require 8.3 74 | 75 | 2008-06-12 Miguel Sofer 76 | 77 | * tcl/uplevel.bench: oops, bench required 8.5 ... fixed. 78 | 79 | 2008-06-12 Miguel Sofer 80 | 81 | * tcl/uplevel.bench: new benchmarks to show uplevel compilation 82 | speedups 83 | 84 | 2007-12-10 Jeff Hobbs 85 | 86 | * tcl/read.bench: use -buffering full on cat output 87 | up iters on the benchmarks for slightly better consistency 88 | 89 | * tcl/regexp.bench: add ini file benchmark to highlight RE slowdown 90 | Add backtrack case and digit matching benchmarks. 91 | 92 | * tcl/string.bench: more glob recursion case benchmarks 93 | 94 | 2007-11-16 Jeff Hobbs 95 | 96 | * normbench.tcl: Add -output wiki and variable in/out format 97 | * runbench.tcl: Add -output wiki format 98 | 99 | * tcl/expr.bench (expr-unbraced-long): add benchmark 100 | * tcl/list.bench: add list reverse benchmarks 101 | * tcl/string.bench: add string reverse core benchmark 102 | * tcl/regexp.bench: limit pre-8.1 REs 103 | 104 | 2007-11-11 Jeff Hobbs 105 | 106 | * tcl/regexp.bench: add more RE tests for core ReToGlob perf 107 | 108 | 2007-11-07 Jeff Hobbs 109 | 110 | * tcl/read.bench: add grep-glob and cat benchmarks. 111 | Allow changing buffer benchmarks for 8.3+. 112 | Allow binary translation for 8.0. 113 | 114 | 2006-11-13 Jeff Hobbs 115 | 116 | * tcl/encoding.bench: add result validation checks 117 | 118 | * runbench.tcl (outputData-text-item): centralize item output format 119 | 120 | * tcl/sha1.bench, tcl/md5.bench: return if < Tcl 8.2 121 | 122 | 2006-11-10 Jeff Hobbs 123 | 124 | * runbench.tcl (outputData-text): allow more space in output, 125 | check for double vals in non-normalized output path. 126 | 127 | * tcl/gccont.bench (GCCont_cpb::cGCC): correct init to work on 8.5 128 | changes for incr auto-init (keeps compat with other versions). 129 | 130 | * tcl/fcopy.bench: use bench_tmpfile where appropriate 131 | 132 | * tcl/vars.bench (var-incr-*): add var type incr benchmarks 133 | 134 | 2006-10-16 Pat Thoyts 135 | 136 | * tcl/sha1.bench: Avoid using method B with tcl 8.5. Method B 137 | relies on the implicit truncation to 32 bit 138 | ints that exists in 8.4. In 8.5 it promotes 139 | to bignums and takes forever. 140 | * tcl/binary.bench: Updated to include TIP 275 unsigned flags 141 | where available. 142 | 143 | 2005-10-08 Pat Thoyts 144 | 145 | * tcl/sha1.bench: Updated the sha1 and md5 implementations with 146 | * tcl/md5.bench: current tcllib code. 147 | 148 | 2004-12-29 Jeff Hobbs 149 | 150 | * tcl/parse.bench: ensure file size is consistent between interp 151 | runs with formatted BOUND string. 152 | 153 | 2004-12-27 Jeff Hobbs 154 | 155 | * doc/runbench.1: fix doc for -throwerrors [Bug 1091766] 156 | 157 | * runbench.tcl (getInterps): use exec << instead of echo [Bug 1091764] 158 | 159 | 2004-12-24 Miguel Sofer 160 | 161 | * tcl/namespace.bench: new benchmark, measures the cost of calling 162 | the same global command alternating different namespaces. 163 | 164 | 2004-12-20 Jeff Hobbs 165 | 166 | * tcl/array.bench (new): array hash benchmarks 167 | 168 | * tcl/file.bench: fix checkall to operate for tclsh <=8.0 169 | 170 | * tcl/string.bench: fix string match -nocase for tclsh <=8.2 171 | 172 | * runbench.tcl (convertVersion): add -globtclsh -globwish file 173 | path glob opts (tclsh* and wish* by default). 174 | Normalize soft-links. 175 | 176 | * normbench.tcl (normalize-text): harden time norm check 177 | 178 | 2003-08-06 Jeff Hobbs 179 | 180 | * normbench.tcl (normalize): correct normalization of new-style 181 | stats where TclX data is present in output. 182 | 183 | 2003-02-11 Jeff Hobbs 184 | 185 | * tcl/list.bench: lsearch -regexp benchmarks 186 | 187 | * tcl/file.bench: updated with more benchmarks 188 | 189 | 2003-02-08 Jeff Hobbs 190 | 191 | * tcl/startup.bench: replaced by file benchmarks 192 | * tcl/file.bench: file benchmarks 193 | 194 | 2002-11-13 Jeff Hobbs 195 | 196 | * tcl/regexp.bench: added anchored re tests 197 | 198 | * tcl/klist.bench: allow method filter from command lineinvocation. 199 | 200 | * tcl/list.bench: add lset benchmarks 201 | 202 | * tcl/md5.bench: correct to work with pre-8.2 interps 203 | 204 | * tcl/string.bench: add string growth, remove split benchmarks 205 | * tcl/split.bench: more split benchmarks 206 | 207 | * runbench.tcl: allow tclsh*/wish* (no version required) 208 | 209 | 2002-07-24 Miguel Sofer 210 | 211 | * tcl/base64.bench: added the current code from tcllib. 212 | 213 | 2002-06-20 Miguel Sofer 214 | 215 | * tcl/read.bench: modified to actually "use" the data being read 216 | by setting a local variable. 217 | 218 | 2002-06-20 Miguel Sofer 219 | 220 | * tcl/md5.bench: added the faster implementation from tcllib 221 | 222 | 2002-06-12 Jeff Hobbs 223 | 224 | * tcl/catch.bench: corrected use of string map in toplevel code 225 | 226 | * tcl/expr.bench: corrected use of string repeat in toplevel code 227 | 228 | * tcl/sha1.bench: correct wideint problem for 8.4 in sha1DF 229 | 230 | * tcl/string.bench: corrected string equality checks to use 231 | different variables (objects) 232 | 233 | * tcl/gccont.bench: new benchmark that does some bioinformatics 234 | manipulation on dna sequences 235 | 236 | 2002-06-12 Miguel Sofer 237 | 238 | * tcl/klist.bench: 239 | * tcl/heapsort.bench: added algorithms using [lset] 240 | 241 | 2002-06-11 Miguel Sofer 242 | 243 | * tcl/regexp.bench: made the bench access the match variables, to 244 | benchmark also the read access to them. 245 | * tcl/vars.bench: added a "VAR ref local" benchmark, to be able to 246 | compare the access times of linked variables to those of local 247 | variables. 248 | 249 | 2002-05-29 Jeff Hobbs 250 | 251 | * tcl/parse.bench: more complex string parsing benchmark (8.0+) 252 | 253 | * tcl/encoding.bench: start of some encoding benchmarks (8.1+) 254 | 255 | * tcl/expr.bench: added ==/!= expr benchmarks 256 | 257 | * tcl/string.bench: corrected the equality benchmarks to not use 258 | the same object unless specified. 259 | 260 | 2002-04-25 Jeff Hobbs 261 | 262 | * runbench.tcl: 263 | * libbench.tcl: added ability to set # threads to use if Thread 264 | package can be loaded. 265 | improved -result error checking 266 | 267 | * tcl/base64.bench: verify result of encode/decode 268 | 269 | * tcl/proc.bench: added empty proc benchmarks 270 | 271 | * tcl/list.bench: added LIST concat benchmarks (hartweg) 272 | 273 | 2002-03-27 Miguel Sofer 274 | 275 | * tcl/catch.bench: modified the catch benchmarks to allow 276 | comparison with catching non-error exceptions; added new 277 | "CATCH except" benchmark. 278 | 279 | 2002-03-15 Miguel Sofer 280 | 281 | * tcl/catch.bench: added benchmark for catch in a body with many 282 | nested exception ranges. 283 | 284 | 2002-02-22 Jeff Hobbs 285 | 286 | * tcl/loops.bench: added while 1 benchmark 287 | 288 | * tcl/conditional.bench: added if 1/0 benchmark 289 | 290 | 2002-02-07 Jeff Hobbs 291 | 292 | * runbench.tcl: noted thread option. 293 | 294 | * libbench.tcl: added ability to check result of test 295 | 296 | * tcl/base64.bench: stripped arg stuff out of code to make it work 297 | in 8.0 as well. 298 | 299 | * tcl/list.bench: corrected list-2.11 to append to simple var. 300 | 301 | * tcl/map.bench: added http mapReply & simple regsubs benchmarks 302 | 303 | * tcl/read.bench: commented out new changing buffersize benchmarks 304 | as they do weird things to various interp versions. 305 | 306 | * tcl/regexp.bench: added static regexp benchmarks 307 | 308 | * tcl/string.bench: added string first utf benchmarks 309 | 310 | * tcl/vars.bench: corrected namespace usage for pre-8 interps. 311 | 312 | 2001-09-25 Jeff Hobbs 313 | 314 | * tcl/string.bench: added exact string match benchmark and fixed 315 | other string match benchmarks 316 | 317 | * tcl/list.bench: added simple list benchmark 318 | 319 | * tcl/vars.bench: added mset benchmarks 320 | 321 | * libbench.tcl: 322 | * runbench.tcl: added support for -threads option to try and load 323 | a thread package and run separate benchmark files simultaneously. 324 | 325 | 2001-08-29 Jeff Hobbs 326 | 327 | * tcl/methods.bench: 328 | * tcl/vars.bench: added some more benchmarks 329 | 330 | 2001-07-18 Andreas Kupries 331 | 332 | * tcl/read.bench: new "read" benchmarks detailing the effect of 333 | the buffersize on IO performance. Created to check out the 334 | performance patch associated with SF item #427196. 335 | 336 | 2001-06-19 Jeff Hobbs 337 | 338 | * tcl/binary.bench: new "binary" benchmarks 339 | 340 | * tcl/string.bench: more random split benchmarks 341 | 342 | 2001-06-03 Jeff Hobbs 343 | 344 | * libbench.tcl: 345 | * runbench.tcl: reduced default iterations to 1000 (still quite 346 | sufficient to remove random noise). 347 | 348 | 2001-05-31 Jeff Hobbs 349 | 350 | * tcl/conditional.bench: added switch/if comparison bench. 351 | 352 | * tcl/base64.bench: new benchmark with base64 code (from tcllib). 353 | 354 | * tcl/md5.bench: new benchmark with Libes' md5 (from tcllib). 355 | 356 | * tcl/sha1.bench: new benchmark with a couple of pure tcl sha1 357 | routines (Libes and Fellows). 358 | 359 | 2001-05-29 Andreas Kupries 360 | 361 | * doc/libbench.n: 362 | * doc/runbench.1: 363 | * doc/normbench.1: Added documentation of benchmark library and 364 | applications. 365 | 366 | * doc: Added documentation directory. 367 | 368 | 2001-05-22 Jeff Hobbs 369 | 370 | * runbench.tcl: corrected error for reporting errors in sourced files 371 | 372 | * tcl/fcopy.bench: made use of bench_tmpfile for more accurate 373 | data (not skewed by network). 374 | 375 | * libbench.tcl (bench_tmpfile): correctly allow multiple calls to 376 | bench_tmpfile within one file. 377 | 378 | * normbench.tcl: new file that allows for post-process 379 | normalization of the benchmark data. 380 | Corrected last minute code checkin bug. 381 | Added support for moving left (to higher versions) to normalize 382 | when the requested version returned non-double data. 383 | 384 | * tcl/libbench.tcl: 385 | * tcl/runbench.tcl: changed -iterations to be a maximum number for 386 | timings, to override any larger number the benchmark may set for 387 | itself. 388 | Rearranged result format of benchmarks to return data by benchmark 389 | description. Benchmarks are now always returned in alphabetical 390 | order of the benchmark description. 391 | Changed benchmarks to rerun the interpreter per benchmark file 392 | instead of sourcing all files into the same interpreter. This 393 | reduces any skew related to excessive mem usage or other factors 394 | that may arise for one benchmark file. 395 | Changed midpoint numbers to time elapsed calculation. 396 | Added -normalize option that post-processes the time information 397 | to normalize against one version as a baseline. 398 | Changed -errors to -throwerrors with no arg, and changed 399 | the default to not throw errors in benchmark files. 400 | Added version string to verbose run info. 401 | 402 | * tcl/klist.bench: added support for <8.0 to all benchmarks except 403 | shuffle0, with notably reduced default run iters due to extreme 404 | slowness of <8.0 interps for these tasks. 405 | 406 | * tcl/string.bench: 407 | * tcl/regexp.bench: fixed incorrect str-repeat replacement function 408 | 409 | 2001-05-18 Jeff Hobbs 410 | 411 | * tcl/string.bench: added <8.0 compatible rev-recursive benchmark, 412 | fixed non-octal escape in ustring instantiation. 413 | 414 | * tcl/wordcount.bench: added <8.1 compatible benchmarks 415 | 416 | * tcl/methods.bench: return for interps <8.0 417 | 418 | 2001-05-19 Andreas Kupries 419 | 420 | * tcl/conditional.bench: Changed some descriptions to make them 421 | unique and matching to the code. 422 | 423 | * tcl/fcopy.bench: New benchmarks for the [fcopy] command 424 | (unsupported0 in older versions of the core). 425 | 426 | 2001-05-16 Jeff Hobbs 427 | 428 | * tcl/string.bench: added static string length benchmarks 429 | 430 | * tcl/wordcount.in: 431 | * tcl/wordcount.bench: wordcount benchmarks 432 | 433 | * tcl/heapsort.bench: new file with heapsort benchmark 434 | * tcl/string.bench: 435 | * tcl/matrix.bench: 436 | * tcl/regexp.bench: extended benchmarks 437 | 438 | 2001-05-11 Jeff Hobbs 439 | 440 | * tcl/string.bench: clarified string reverse benchmarks, added 441 | more to the string compare benchmarks. 442 | 443 | * tcl/matrix.bench: some new matrix benchmarks. Basically a seed 444 | file looking for more. procs courtesy Sofer. 445 | 446 | * tcl/list.bench: added a list-iter benchmark 447 | 448 | * tcl/klist.bench: reduced default iters in klist.bench. Accuracy 449 | seems about the same without the wait... 450 | 451 | * libbench.tcl: 452 | * runbench.tcl: added support for -rmatch option (regexp match of 453 | benchmark description). 454 | Added MIDPOINT verbose puts for interim time notes. 455 | 456 | 2001-04-11 Jeff Hobbs 457 | 458 | * tcl/klist.bench: added shuffle5* from wiki. 459 | 460 | 2001-03-28 Jeff Hobbs 461 | 462 | * tcl/string.bench: fixed str-first proc that had bogus code in it. 463 | added more split benchmarks for dkf's split improvement in 8.4. 464 | 465 | * tk/canvas.bench: expanded item draw benchmarks 466 | 467 | 2001-03-23 468 | 469 | * tk/canvas.bench: added simple item draw benchmarks 470 | 471 | 2001-03-15 472 | 473 | * tcl/klist.bench: improved non-tclbench data output. 474 | 475 | * runbench.tcl: added more error capturing. 476 | 477 | * tcl/string.bench: fixed calls to string repeat to work with 478 | <8.1.1 interps. 479 | 480 | * tcl/klist.bench: new file to benchmark various list shuffling 481 | techniques (from wiki). 482 | * tcl/methods.bench: new file to benchmark various method 483 | invocation speeds (petasis). 484 | 485 | 2000-10-19 Jeff Hobbs 486 | 487 | * tcl/string.bench (str-append-2): added more append tests 488 | 489 | 2000-08-30 Jeff Hobbs 490 | 491 | * tcl/string.bench: made string repeat calls compatible with 492 | pre-8.1.1 interpreters. 493 | 494 | * libbench.tcl (bench_tmpfile): add env to global list 495 | 496 | 2000-08-29 Eric Melski 497 | 498 | * tcl/string.bench: Extended string append benchmarks to exploit 499 | new growth algorithm for string objects in Tcl 8.4a2. 500 | 501 | 2000-05-31 Jeff Hobbs 502 | 503 | * runbench.tcl: new options -errors (passed to libbench), -verbose 504 | (by default we are now quieter on output), -output 505 | (different output types - csv is char-sep-value for Excel). 506 | Added start/finish times (in -verbose mode). 507 | * libbench.tcl: libbench now takes -option switches for 508 | flexibility, options for -errors BOOL (error suppression), -interp 509 | NAME (to specify interp), -match PATTERN (glob pattern to filter 510 | tests by desc), -iters NUM (default number of iters to run). 511 | Reorganized how data is returned to runbench master. 512 | 513 | * tk/entry.bench (new): 514 | * tk/canvas.bench (new): new tests for widget creation, config 515 | 516 | * tcl/array.bench (removed): 517 | * tcl/vars.bench: merged array.bench tests into VAR 518 | 519 | * tcl/map.bench: fixed for compatability with Tcl7.4- 520 | 521 | 2000-05-25 Jeff Hobbs 522 | 523 | * runbench.tcl: added -match, -notcl, -notk options, restructured 524 | startup sequence. 525 | 526 | * libbench.tcl: added ability to return string values from bench 527 | tests and support for filtering tests to run. 528 | 529 | * tcl/string.bench: moved string mapping benchmarks and added more 530 | string equality benchmarks 531 | * tcl/map.bench: added extended string mapping benchmark 532 | 533 | * tcl/read.bench: 534 | * tcl/startup.bench: 535 | * tk/startup.bench: updated code to reflect proc-oriented tmpfile 536 | operations. 537 | -------------------------------------------------------------------------------- /runbench.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh 2 | 3 | # runbench.tcl ?options? 4 | # 5 | set RCS {RCS: @(#) $Id$} 6 | # 7 | # Copyright (c) 2000-2010 Jeffrey Hobbs. 8 | 9 | # 10 | # Run the main script from an 8.3+ interp 11 | # 12 | if {[catch {package require Tcl 8.3}]} { 13 | set me [file tail [info script]] 14 | puts stderr "$me requires 8.3+ to run, although it can benchmark\ 15 | any Tcl v7+ interpreter" 16 | exit 1 17 | } 18 | 19 | regexp {,v (\d+\.\d+)} $RCS -> VERSION 20 | set MYDIR [file dirname [info script]] 21 | set ME [file tail [info script]] 22 | 23 | proc usage {} { 24 | puts stderr "Usage (v$::VERSION): $::ME ?options?\ 25 | \n\t-help # print out this message\ 26 | \n\t-autoscale # autoscale runtime iters to 0.1s..4s (default on)\ 27 | \n\t-repeat <#> # repeat X times and collate results (default 1) 28 | \n\t-collate min|max|avg # collate command (default min) 29 | \n\t-delta # delta range for wiki highlight (default: 0.05)\ 30 | \n\t-iterations <#> # max X of iterations to run any benchmark\ 31 | \n\t-minversion # minimum interp version to use\ 32 | \n\t-maxversion # maximum interp version to use\ 33 | \n\t-match # only run tests matching this pattern\ 34 | \n\t-rmatch # only run tests matching this pattern\ 35 | \n\t-normalize # normalize numbers to given version\ 36 | \n\t-notcl # do not run tclsh tests\ 37 | \n\t-notk # do not run wish tests\ 38 | \n\t-output # style of output (default: match input format)\ 39 | \n\t-paths # path or list of paths to search for interps\ 40 | \n\t-single # whether to run all tests in same interp instance\ 41 | \n\t-threads # num of threads to use (where possible)\ 42 | \n\t-throwerrors # propagate errors in benchmarks files\ 43 | \n\t-verbose # output interim status info\ 44 | \n\tfileList # files to source, files matching *tk*\ 45 | \n\t # will be used for Tk benchmarks" 46 | exit 1 47 | } 48 | 49 | proc convertVersion {ver} { 50 | # We must modify the version number if an abp version 51 | # is specified, because the package mechanism will choke 52 | if {[string is double -strict -fail i $ver] == 0} { 53 | set ver [string range $ver 0 [expr {$i-1}]] 54 | } 55 | return $ver 56 | } 57 | 58 | # 59 | # Default process options 60 | # 61 | array set opts { 62 | paths {} 63 | delta 0.05 64 | minver 0.0 65 | maxver 10.0 66 | match {} 67 | rmatch {} 68 | tcllist {} 69 | tklist {} 70 | tclsh "tclsh*" 71 | wish "wish*" 72 | usetk 1 73 | usetcl 1 74 | usethreads 0 75 | errors 0 76 | verbose 0 77 | output text 78 | iters 5000 79 | single 1 80 | autoscale 1 81 | norm {} 82 | repeat 0 83 | ccmd collate_min 84 | } 85 | 86 | proc parseOpts {} { 87 | global argv opts 88 | if {[llength $argv]} { 89 | set theargs $argv 90 | while {[llength $theargs]} { 91 | set key [lindex $theargs 0] 92 | set val [lindex $theargs 1] 93 | set consumed 1 94 | switch -glob -- $key { 95 | -help* { usage } 96 | -throw* { 97 | # throw errors when they occur in benchmark files 98 | set opts(errors) 1 99 | set consumed 0 100 | } 101 | -thread* { 102 | set opts(usethreads) [string is true -strict $val] 103 | } 104 | -globt* { 105 | set opts(tclsh) $val 106 | } 107 | -globw* { 108 | set opts(wish) $val 109 | } 110 | -auto* { 111 | set opts(autoscale) [string is true -strict $val] 112 | } 113 | -rep* { 114 | if {![string is integer -strict $val] || $val < 0} { usage } 115 | set opts(repeat) $val 116 | # Repeats and soft-errors don't mix 117 | if {$val} { set opts(errors) 1 } 118 | } 119 | -col* { 120 | set ccmd [info commands collate_$val] 121 | if {[llength $ccmd] != 1} { usage } 122 | set opts(ccmd) $ccmd 123 | } 124 | -iter* { 125 | # Maximum iters to run a test 126 | # The test may set a smaller iter run, but anything larger 127 | # will be reduced. 128 | set opts(iters) $val 129 | } 130 | -min* { 131 | # Allow a minimum version to search for, 132 | # restricted to version, not patchlevel 133 | set opts(minver) [convertVersion $val] 134 | } 135 | -max* { 136 | # Allow a maximum version to search for, 137 | # restricted to version, not patchlevel 138 | set opts(maxver) [convertVersion $val] 139 | } 140 | -match* { 141 | set opts(match) $val 142 | } 143 | -rmatch* { 144 | set opts(rmatch) $val 145 | } 146 | -norm* { 147 | set opts(norm) $val 148 | } 149 | -notcl { 150 | set opts(usetcl) 0 151 | set consumed 0 152 | } 153 | -notk { 154 | set opts(usetk) 0 155 | set consumed 0 156 | } 157 | -delta { 158 | set opts(delta) $val 159 | } 160 | -single* { 161 | set opts(single) [string is true -strict $val] 162 | } 163 | -out* { 164 | # Output style 165 | if {![regexp {^(text|list|csv|wiki)$} $val]} { usage } 166 | set opts(output) $val 167 | } 168 | -path* { 169 | # Support single dir path or multiple paths as a list 170 | if {[file isdir $val]} { set val [list $val] } 171 | foreach path $val { 172 | if {[file isdir $path]} { lappend opts(paths) $path } 173 | } 174 | } 175 | -v* { 176 | set opts(verbose) 1 177 | set consumed 0 178 | } 179 | default { 180 | foreach arg $theargs { 181 | if {![file exists $arg]} { 182 | usage 183 | } 184 | if {[string match *tk* $arg]} { 185 | lappend opts(tklist) $arg 186 | } else { 187 | lappend opts(tcllist) $arg 188 | } 189 | } 190 | vputs stdout "ARGS [lrange $argv 0 end-[llength $theargs]]" 191 | break 192 | } 193 | } 194 | set theargs [lreplace $theargs 0 $consumed] 195 | } 196 | } 197 | if {[llength $opts(tcllist)] == 0 && [llength $opts(tklist)] == 0} { 198 | set opts(tcllist) [lsort [glob $::MYDIR/tcl/*.bench]] 199 | set opts(tklist) [lsort [glob $::MYDIR/tk/*.bench]] 200 | } 201 | 202 | # 203 | # Find available interpreters. 204 | # The user PATH will be searched, unless specified otherwise by -paths. 205 | # 206 | if {[llength $opts(paths)] == 0} { 207 | set pathSep [expr {($::tcl_platform(platform)=="windows") ? ";" : ":"}] 208 | set opts(paths) [split $::env(PATH) $pathSep] 209 | } 210 | } 211 | 212 | # 213 | # Collect interp info from path(s) 214 | # 215 | proc getInterps {optArray pattern iArray} { 216 | upvar 1 $optArray opts $iArray var 217 | set evalString {puts [info patchlevel] ; exit} 218 | foreach path $opts(paths) { 219 | foreach interp [glob -nocomplain -directory $path $pattern] { 220 | if {$::tcl_version > 8.4} { 221 | set interp [file normalize $interp] 222 | } 223 | # Root out the soft-linked exes 224 | while {[string equal link [file type $interp]]} { 225 | set link [file readlink $interp] 226 | if {[string match relative [file pathtype $link]]} { 227 | set interp [file join [file dirname $interp] $link] 228 | } else { 229 | set interp $link 230 | } 231 | } 232 | if {[file executable $interp] && ![info exists var($interp)]} { 233 | if {[catch {exec $interp << $evalString} patchlevel]} { 234 | if {$opts(errors)} { 235 | error $::errorInfo 236 | } else { 237 | puts stderr $patchlevel 238 | continue 239 | } 240 | } 241 | # Lame package mechanism doesn't understand [abp] 242 | set ver [convertVersion $patchlevel] 243 | # Only allow versions within specified restrictions 244 | if { 245 | ([package vcompare $ver $opts(minver)] >= 0) && 246 | ([package vcompare $opts(maxver) $ver] >= 0) 247 | } { 248 | set var($interp) $patchlevel 249 | lappend var(ORDERED) [list $patchlevel $interp] 250 | } 251 | } 252 | } 253 | } 254 | set var(ORDERED) [lsort -dictionary -decreasing -index 0 $var(ORDERED)] 255 | 256 | # 257 | # Post process ordering of the interpreters for output 258 | # 259 | set i 0 260 | foreach ipair $var(ORDERED) { 261 | set label [incr i]:[lindex $ipair 0] 262 | set interp [lindex $ipair 1] 263 | if {[string equal "$i:$opts(norm)" $label]} { 264 | set opts(norm) $label 265 | set ok 1 266 | } elseif {$opts(norm) != "" && [string match "*$opts(norm)" $interp]} { 267 | set opts(norm) $label 268 | set ok 1 269 | } 270 | lappend var(VERSION) $label 271 | set var($label) $interp 272 | } 273 | if {$opts(norm) != "" && ![info exists ok]} { 274 | puts stderr "Unable to normalize \"$opts(norm)\":\ 275 | must be patchlevel or name of executable" 276 | set opts(norm) {} 277 | if {$opts(errors)} { exit } 278 | } 279 | vputs stdout "$iArray: $var(VERSION)" 280 | } 281 | 282 | # 283 | # variation of puts to allow for -verbose operation 284 | # 285 | proc vputs {args} { 286 | global opts 287 | if {$opts(verbose)} { 288 | if {$opts(output) == "wiki"} { 289 | set args [lreplace $args end end " [lindex $args end]"] 290 | } 291 | uplevel 1 [list puts] $args 292 | } 293 | } 294 | 295 | catch { 296 | lappend ::auto_path /usr/local/ActiveTcl/lib 297 | package require Tclx 298 | } 299 | 300 | # 301 | # Do benchmarking 302 | # 303 | proc collectData {iArray dArray oArray fileList} { 304 | upvar 1 $iArray ivar $dArray DATA $oArray opts 305 | 306 | array set DATA {MAXLEN 0} 307 | catch { 308 | lappend ::auto_path /usr/local/ActiveTcl/lib 309 | package require Tclx 310 | } 311 | if {$opts(repeat)} { 312 | if {$opts(repeat) < 3 && $opts(autoscale)} { 313 | # We'll waste one run not autoscaled to get good elapsed time 314 | incr opts(repeat) 315 | } 316 | } elseif {$opts(autoscale)} { 317 | # Warn users that with autoscaling, you can't compare elapsed time 318 | # to each other because the system will run different iters based 319 | # on interp speed 320 | vputs stdout "AUTOSCALING ON - total elapsed time may be skewed" 321 | } 322 | for {set i 0} {$i <= $opts(repeat)} {incr i} { 323 | if {$i} { 324 | vputs -nonewline stdout "R$i " 325 | } 326 | # Don't autoscale the first run if repeating 327 | set auto [expr {($opts(repeat)&&$i) ? $opts(autoscale) : 0}] 328 | foreach label $ivar(VERSION) { 329 | set interp $ivar($label) 330 | if {$i == 0} { 331 | vputs stdout "Benchmark $label $interp" 332 | } 333 | set cmd [list $interp [file join $::MYDIR libbench.tcl]] 334 | lappend cmd -match $opts(match) \ 335 | -rmatch $opts(rmatch) \ 336 | -autos $auto \ 337 | -iters $opts(iters) \ 338 | -interp $interp \ 339 | -errors $opts(errors) \ 340 | -threads $opts(usethreads) 341 | array set tmp {} 342 | #vputs stderr "exec $cmd $fileList" 343 | set start [clock seconds] 344 | catch { set cstart [lindex [times] 2] } 345 | if {$opts(usethreads)} { 346 | if {[catch {eval exec $cmd $fileList} output]} { 347 | if {$opts(errors)} { 348 | error $::errorInfo 349 | } else { 350 | puts stderr $output 351 | } 352 | } else { 353 | array set tmp $output 354 | } 355 | } else { 356 | if {$opts(single)} { 357 | foreach file $fileList { 358 | if {$i == 0} { 359 | vputs -nonewline stdout \ 360 | [string index [file tail $file] 0] 361 | } 362 | flush stdout 363 | if {[catch {eval exec $cmd [list $file]} output]} { 364 | if {$opts(errors)} { 365 | error $::errorInfo 366 | } else { 367 | puts stderr $output 368 | continue 369 | } 370 | } else { 371 | array set tmp $output 372 | } 373 | } 374 | } else { 375 | if {$i == 0} { 376 | vputs -nonewline "running all" 377 | } 378 | flush stdout 379 | if {[catch {eval exec $cmd $fileList} output]} { 380 | if {$opts(errors)} { 381 | error $::errorInfo 382 | } else { 383 | puts stderr $output 384 | continue 385 | } 386 | } else { 387 | array set tmp $output 388 | } 389 | } 390 | } 391 | catch { set celapsed [expr {[lindex [times] 2] - $cstart}] } 392 | set elapsed [expr {[clock seconds] - $start}] 393 | set hour [expr {$elapsed / 3600}] 394 | set min [expr {$elapsed / 60}] 395 | set sec [expr {$elapsed % 60}] 396 | if {$i == 0} { 397 | vputs stdout " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed" 398 | if {[info exists celapsed]} { 399 | vputs stdout "$celapsed milliseconds" 400 | } 401 | } 402 | catch { unset tmp(Sourcing) } 403 | if {$opts(autoscale) != $auto} { 404 | # Toss data where autoscale is tweaked (e.g. if we are 405 | # repeating, this is the first run, and it is not autoscaled) 406 | unset tmp 407 | continue 408 | } 409 | foreach desc [array names tmp] { 410 | set DATA(desc:${desc}) {} 411 | set key :$desc$label ; set val $tmp($desc) 412 | if {![info exists DATA($key)]} { # $i == 0 413 | set DATA($key) $val 414 | } elseif {[string is double -strict $val]} { 415 | # Call user-request collation type 416 | set DATA($key) [$opts(ccmd) $DATA($key) $val $i] 417 | } 418 | if {[string length $desc] > $DATA(MAXLEN)} { 419 | set DATA(MAXLEN) [string length $desc] 420 | } 421 | } 422 | unset tmp 423 | } 424 | } 425 | if {$i > 1} { 426 | vputs stdout "" 427 | } 428 | } 429 | 430 | proc collate_min {cur new runs} { 431 | # Minimum 432 | return [expr {$cur > $new ? $new : $cur}] 433 | } 434 | proc collate_avg {cur new runs} { 435 | # Average 436 | return [expr {($cur * $i + $new)/($i+1)}] 437 | } 438 | proc collate_max {cur new runs} { 439 | # Maximum 440 | return [expr {$cur < $new ? $new : $cur}] 441 | } 442 | 443 | # 444 | # Various data output styles 445 | # 446 | proc outputData-text-item {val} { 447 | set LEN 8 448 | if {[string is double -strict $val]} { 449 | if {$val > 1e6} { 450 | return [format " %8.0f" $val] 451 | } elseif {$val > 1e5} { 452 | return [format " %8.1f" $val] 453 | } else { 454 | return [format " %8.2f" $val] 455 | } 456 | } else { 457 | return [format " %8s" $val] 458 | } 459 | } 460 | 461 | proc outputData-text {iArray dArray {norm {}}} { 462 | upvar 1 $iArray ivar $dArray DATA 463 | 464 | set fmt "%.3d %-$DATA(MAXLEN)s" 465 | set i 0 466 | set out [format $fmt $i "VERSIONS:"] 467 | foreach lbl $ivar(VERSION) { append out [outputData-text-item $lbl] } 468 | append out \n 469 | 470 | foreach elem [lsort -dictionary [array names DATA {desc*}]] { 471 | set desc [string range $elem 5 end] 472 | append out [format $fmt [incr i] $desc] 473 | foreach lbl $ivar(VERSION) { 474 | # establish a default for tests that didn't exist for this interp 475 | if {![info exists DATA(:$desc$lbl)]} { set DATA(:$desc$lbl) "-=-" } 476 | } 477 | if {[info exists DATA(:$desc$norm)] && \ 478 | [string is double -strict $DATA(:$desc$norm)]} { 479 | foreach lbl $ivar(VERSION) { 480 | set val $DATA(:$desc$lbl) 481 | if {[string is double -strict $val]} { 482 | set val [expr {$val / double($DATA(:$desc$norm))}] 483 | } 484 | append out [outputData-text-item $DATA(:$desc$lbl)] 485 | } 486 | } else { 487 | foreach lbl $ivar(VERSION) { 488 | # not %d to allow non-int result codes 489 | append out [outputData-text-item $DATA(:$desc$lbl)] 490 | } 491 | } 492 | append out "\n" 493 | } 494 | 495 | append out [format $fmt $i "BENCHMARKS"] 496 | foreach lbl $ivar(VERSION) { append out [outputData-text-item $lbl] } 497 | append out \n 498 | return $out 499 | } 500 | 501 | # 502 | # List format is: 503 | # ... 504 | # 505 | proc outputData-list {iArray dArray {norm {}}} { 506 | upvar 1 $iArray ivar $dArray DATA 507 | global opts 508 | 509 | set i 0 510 | set out [list [concat [list $i VERSIONS:] $ivar(VERSION)]] 511 | 512 | foreach elem [lsort -dictionary [array names DATA {desc*}]] { 513 | set desc [string range $elem 5 end] 514 | set name [incr i] 515 | set line [list $name $desc] 516 | foreach lbl $ivar(VERSION) { 517 | # establish a default for tests that didn't exist for this interp 518 | if {![info exists DATA(:$desc$lbl)]} { set DATA(:$desc$lbl) "-=-" } 519 | } 520 | if {[info exists DATA(:$desc$norm)] && \ 521 | [string is double -strict $DATA(:$desc$norm)]} { 522 | foreach lbl $ivar(VERSION) { 523 | if {[string is double -strict $DATA(:$desc$lbl)]} { 524 | lappend line [format "%.2f" \ 525 | [expr {double($DATA(:$desc$lbl)) / \ 526 | double($DATA(:$desc$norm))}]] 527 | } else { 528 | lappend line $DATA(:$desc$lbl) 529 | } 530 | } 531 | } else { 532 | foreach lbl $ivar(VERSION) { 533 | lappend line $DATA(:$desc$lbl) 534 | } 535 | if {$opts(output) == "wiki"} { 536 | set line [lrange $line 2 end] 537 | set min [min $line] 538 | set max [max $line] 539 | set wline [list $name $desc] 540 | foreach elem $line { 541 | if {[string is double -strict $elem]} { 542 | # do magic highlighting within DELTA% of min or max 543 | if {$elem < ($min*(1.0+$opts(delta)))} { 544 | set elem "''$elem''" ; # italic 545 | } elseif {$elem > ($max*(1.0-$opts(delta)))} { 546 | set elem "'''$elem'''" ; # bold 547 | } 548 | } 549 | lappend wline $elem 550 | } 551 | set line $wline 552 | } 553 | } 554 | lappend out $line 555 | } 556 | 557 | lappend out [concat [list $i BENCHMARKS] $ivar(VERSION)] 558 | return $out 559 | } 560 | 561 | proc list2csv {list} { 562 | set out "" 563 | foreach l $list { 564 | set sep {} 565 | foreach val $l { 566 | if {[string match "*\[\",\]*" $val]} { 567 | append out $sep\"[string map [list \" \"\"] $val]\" 568 | } else { 569 | append out $sep$val 570 | } 571 | set sep , 572 | } 573 | append out \n 574 | } 575 | return $out 576 | } 577 | 578 | proc min {times} { 579 | set min [expr {1<<16}] 580 | foreach t $times { 581 | if {[string is double -strict $t]} { if {$t < $min} { set min $t } } 582 | } 583 | return $min 584 | } 585 | 586 | proc max {times} { 587 | set max 0 588 | foreach t $times { 589 | if {[string is double -strict $t]} { if {$t > $max} { set max $t } } 590 | } 591 | return $max 592 | } 593 | 594 | proc wikisafe {str} { 595 | return [string map [list | <>] $str] 596 | } 597 | 598 | proc list2wiki {list} { 599 | set out "" 600 | append out "%|[join [lindex $list 0] |]|%\n" ; # VERSIONS 601 | foreach l [lrange $list 1 end-1] { 602 | append out "&|[join [wikisafe $l] |]|&\n" 603 | } 604 | append out "%|[join [lindex $list end] |]|%\n" ; # BENCHMARKS 605 | return $out 606 | } 607 | 608 | proc outputData {optArray iArray dArray} { 609 | upvar 1 $optArray opts $iArray ivar $dArray DATA 610 | 611 | switch -exact -- $opts(output) { 612 | text { 613 | puts -nonewline stdout [outputData-text ivar DATA $opts(norm)] 614 | } 615 | list { 616 | puts stdout [join [outputData-list ivar DATA $opts(norm)] \n] 617 | } 618 | csv { 619 | puts -nonewline stdout \ 620 | [list2csv [outputData-list ivar DATA $opts(norm)]] 621 | } 622 | wiki { 623 | puts -nonewline stdout \ 624 | [list2wiki [outputData-list ivar DATA $opts(norm)]] 625 | } 626 | } 627 | } 628 | 629 | proc now {} { 630 | return [clock format [clock seconds] -format "%Y-%m-%d %H:%M:%S"] 631 | } 632 | 633 | parseOpts 634 | 635 | if {[llength $opts(tcllist)] && $opts(usetcl)} { 636 | array set TCL_INTERP {ORDERED {} VERSION {}} 637 | getInterps opts $opts(tclsh) TCL_INTERP 638 | vputs stdout "STARTED [now] ($::ME v$::VERSION)" 639 | collectData TCL_INTERP TCL_DATA opts $opts(tcllist) 640 | outputData opts TCL_INTERP TCL_DATA 641 | vputs stdout "FINISHED [now]" 642 | } 643 | 644 | if {[llength $opts(tklist)] && $opts(usetk)} { 645 | vputs stdout "" 646 | array set TK_INTERP {ORDERED {} VERSION {}} 647 | getInterps opts $opts(wish) TK_INTERP 648 | vputs stdout "STARTED [now] ($::ME v$::VERSION)" 649 | collectData TK_INTERP TK_DATA opts $opts(tklist) 650 | outputData opts TK_INTERP TK_DATA 651 | vputs stdout "FINISHED [now]" 652 | } 653 | --------------------------------------------------------------------------------