source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/bench/libbench.tcl @ 8597867d

1941-docker-image-to-testdevel
Last change on this file since 8597867d was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@2556 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 14.8 KB
Line 
1# -*- tcl -*-
2# libbench.tcl ?(<option> <value>)...? <benchFile>...
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: libbench.tcl,v 1.3 2007/08/21 20:02:21 andreas_kupries Exp $
8#
9# Copyright (c) 2000-2001 Jeffrey Hobbs.
10# Copyright (c) 2007      Andreas Kupries
11#
12
13# This code provides the supporting commands for the execution of a
14# benchmark files. It is actually an application and is exec'd by the
15# management code.
16
17# Options:
18# -help                         Print usage message.
19# -rmatch <regexp-pattern>      Run only tests whose description matches the pattern.
20# -match  <glob-pattern>        Run only tests whose description matches the pattern.
21# -interp <name>                Name of the interp running the benchmarks.
22# -thread <num>                 Invoke threaded benchmarks, number of threads to use.
23# -errors <boolean>             Throw errors, or not.
24
25# Note: If both -match and -rmatch are specified then _both_
26# apply. I.e. a benchmark will be run if and only if it matches both
27# patterns.
28
29# Application activity and results are communicated to the highlevel
30# management via text written to stdout. Each line written is a list
31# and has one of the following forms:
32#
33# __THREADED <version>     - Indicates threaded mode, and version
34#                            of package Thread in use.
35#
36# Sourcing {<desc>: <res>} - Benchmark <desc> has started.
37#                            <res> is the result from executing
38#                            it once (compilation of body.)
39#
40# Sourcing <file>          - Benchmark file <file> starts execution.
41#
42# <desc> <res>             - Result of a benchmark.
43#
44# The above implies that no benchmark may use the strings 'Sourcing'
45# or '__THREADED' as their description.
46
47# We will put our data into these named globals.
48
49global BENCH bench
50
51# 'BENCH' contents:
52#
53# - ERRORS  : Boolean flag. If set benchmark output mismatches are
54#             reported by throwing an error. Otherwise they are simply
55#             listed as BAD_RES. Default true. Can be set/reset via
56#             option -errors.
57#
58# - MATCH   : Match pattern, see -match, default empty, aka everything
59#             matches.
60#
61# - RMATCH  : Match pattern, see -rmatch, default empty, aka
62#             everything matches.
63#
64# - OUTFILE : Name of output file, default is special value "stdout".
65# - OUTFID  : Channel for output.
66#
67# The outfile cannot be set by the caller, thus output is always
68# written to stdout.
69#
70# - FILES   : List of benchmark files to run.
71#
72# - ITERS   : Number of iterations to run a benchmark body, default
73#             1000. Can be overridden by the individual benchmarks.
74#
75# - THREADS : Number of threads to use. 0 signals no threading.
76#             Limited to number of files if there are less files than
77#             requested threads.
78#
79# - EXIT    : Boolean flag. True when appplication is run by wish, for
80#             special exit processing. ... Actually always true.
81#
82# - INTERP  : Name of the interpreter running the benchmarks. Is the
83#             executable running this code. Can be overridden via the
84#             command line option -interp.
85#
86# - uniqid  : Counter for 'bench_tmpfile' to generate unique names of
87#             tmp files.
88#
89# - us      : Thread id of main thread.
90#
91# - inuse   : Number of threads active, present and relevant only in
92#             threaded mode.
93#
94# - file    : Currently executed benchmark file. Relevant only in
95#             non-threaded mode.
96
97#
98# 'bench' contents.
99
100# Benchmark results, mapping from the benchmark descriptions to their
101# results. Usually time in microseconds, but the following special
102# values can occur:
103#
104# - BAD_RES    - Result from benchmark body does not match expectations.
105# - ERR        - Benchmark body aborted with an error.
106# - Any string - Forced by error code 666 to pass to management.
107
108#
109# We claim all procedures starting with bench*
110#
111
112# bench_tmpfile --
113#
114#   Return a temp file name that can be modified at will
115#
116# Arguments:
117#   None
118#
119# Results:
120#   Returns file name
121#
122proc bench_tmpfile {} {
123    global tcl_platform env BENCH
124    if {![info exists BENCH(uniqid)]} { set BENCH(uniqid) 0 }
125    set base "tclbench[incr BENCH(uniqid)].dat"
126    if {[info exists tcl_platform(platform)]} {
127        if {$tcl_platform(platform) == "unix"} {
128            return "/tmp/$base"
129        } elseif {$tcl_platform(platform) == "windows"} {
130            return [file join $env(TEMP) $base]
131        } else {
132            return $base
133        }
134    } else {
135        # The Good Ol' Days (?) when only Unix support existed
136        return "/tmp/$base"
137    }
138}
139
140# bench_rm --
141#
142#   Remove a file silently (no complaining)
143#
144# Arguments:
145#   args        Files to delete
146#
147# Results:
148#   Returns nothing
149#
150proc bench_rm {args} {
151    foreach file $args {
152        if {[info tclversion] > 7.4} {
153            catch {file delete $file}
154        } else {
155            catch {exec /bin/rm $file}
156        }
157    }
158}
159
160# bench --
161#
162#   Main bench procedure.
163#   The bench test is expected to exit cleanly.  If an error occurs,
164#   it will be thrown all the way up.  A bench proc may return the
165#   special code 666, which says take the string as the bench value.
166#   This is usually used for N/A feature situations.
167#
168# Arguments:
169#
170#   -pre        script to run before main timed body
171#   -body       script to run as main timed body
172#   -post       script to run after main timed body
173#   -ipre       script to run before timed body, per iteration of the body.
174#   -ipost      script to run after timed body, per iteration of the body.
175#   -desc       message text
176#   -iterations <#>
177#
178# Note:
179#
180#   Using -ipre and/or -ipost will cause us to compute the average
181#   time ourselves, i.e. 'time body 1' n times. Required to ensure
182#   that prefix/post operation are executed, yet not timed themselves.
183#
184# Results:
185#
186#   Returns nothing
187#
188# Side effects:
189#
190#   Sets up data in bench global array
191#
192proc bench {args} {
193    global BENCH bench errorInfo errorCode
194
195    # -pre script
196    # -body script
197    # -desc msg
198    # -post script
199    # -ipre script
200    # -ipost script
201    # -iterations <#>
202    array set opts {
203        -pre    {}
204        -body   {}
205        -desc   {}
206        -post   {}
207        -ipre   {}
208        -ipost  {}
209    }
210    set opts(-iter) $BENCH(ITERS)
211    while {[llength $args]} {
212        set key [lindex $args 0]
213        switch -glob -- $key {
214            -res*       { set opts(-res)  [lindex $args 1] }
215            -pr*        { set opts(-pre)  [lindex $args 1] }
216            -po*        { set opts(-post) [lindex $args 1] }
217            -ipr*       { set opts(-ipre)  [lindex $args 1] }
218            -ipo*       { set opts(-ipost) [lindex $args 1] }
219            -bo*        { set opts(-body) [lindex $args 1] }
220            -de*        { set opts(-desc) [lindex $args 1] }
221            -it*        {
222                # Only change the iterations when it is smaller than
223                # the requested default
224                set val [lindex $args 1]
225                if {$opts(-iter) > $val} { set opts(-iter) $val }
226            }
227            default {
228                error "unknown option $key"
229            }
230        }
231        set args [lreplace $args 0 1]
232    }
233    if {($BENCH(MATCH) != "") && ![string match $BENCH(MATCH) $opts(-desc)]} {
234        return
235    }
236    if {($BENCH(RMATCH) != "") && ![regexp $BENCH(RMATCH) $opts(-desc)]} {
237        return
238    }
239    if {$opts(-pre) != ""} {
240        uplevel \#0 $opts(-pre)
241    }
242    if {$opts(-body) != ""} {
243        # always run it once to remove compile phase confusion
244        if {$opts(-ipre) != ""} {
245            uplevel \#0 $opts(-ipre)
246        }
247        set code [catch {uplevel \#0 $opts(-body)} res]
248        if {$opts(-ipost) != ""} {
249            uplevel \#0 $opts(-ipost)
250        }
251        if {!$code && [info exists opts(-res)] \
252                && [string compare $opts(-res) $res]} {
253            if {$BENCH(ERRORS)} {
254                return -code error "Result was:\n$res\nResult\
255                        should have been:\n$opts(-res)"
256            } else {
257                set res "BAD_RES"
258            }
259            set bench($opts(-desc)) $res
260            puts $BENCH(OUTFID) [list Sourcing "$opts(-desc): $res"]
261        } else {
262            if {($opts(-ipre) != "") || ($opts(-ipost) != "")} {
263
264                # We do the averaging on our own, to allow untimed
265                # pre/post execution per iteration. We catch and
266                # handle problems in the pre/post code as if
267                # everything was executed as one block (like it would
268                # be in the other path). We are using floating point
269                # to avoid integer overflow, easily happening when
270                # accumulating a high number (iterations) of large
271                # integers (microseconds).
272
273                set total 0.0
274                for {set i 0} {$i < $opts(-iter)} {incr i} {
275                    set code 0
276                    if {$opts(-ipre) != ""} {
277                        set code [catch {uplevel \#0 $opts(-ipre)} res]
278                        if {$code} break
279                    }
280                    set code [catch {uplevel \#0 [list time $opts(-body) 1]} res]
281                    if {$code} break
282                    set total [expr {$total + [lindex $res 0]}]
283                    if {$opts(-ipost) != ""} {
284                        set code [catch {uplevel \#0 $opts(-ipost)} res]
285                        if {$code} break
286                    }
287                }
288                if {!$code} {
289                    set res [list [expr {int ($total/$opts(-iter))}] microseconds per iteration]
290                }
291            } else {
292                set code [catch {uplevel \#0 \
293                        [list time $opts(-body) $opts(-iter)]} res]
294            }
295            if {!$BENCH(THREADS)} {
296                if {$code == 0} {
297                    # Get just the microseconds value from the time result
298                    set res [lindex $res 0]
299                } elseif {$code != 666} {
300                    # A 666 result code means pass it through to the bench
301                    # suite. Otherwise throw errors all the way out, unless
302                    # we specified not to throw errors (option -errors 0 to
303                    # libbench).
304                    if {$BENCH(ERRORS)} {
305                        return -code $code -errorinfo $errorInfo \
306                                -errorcode $errorCode
307                    } else {
308                        set res "ERR"
309                    }
310                }
311                set bench($opts(-desc)) $res
312                puts $BENCH(OUTFID) [list Sourcing "$opts(-desc): $res"]
313            } else {
314                # Threaded runs report back asynchronously
315                thread::send $BENCH(us) \
316                        [list thread_report $opts(-desc) $code $res]
317            }
318        }
319    }
320    if {($opts(-post) != "") && [catch {uplevel \#0 $opts(-post)} err] \
321            && $BENCH(ERRORS)} {
322        return -code error "post code threw error:\n$err"
323    }
324    return
325}
326
327proc usage {} {
328    set me [file tail [info script]]
329    puts stderr "Usage: $me ?options?\
330            \n\t-help                   # print out this message\
331            \n\t-rmatch <regexp>        # only run tests matching this pattern\
332            \n\t-match <glob>           # only run tests matching this pattern\
333            \n\t-interp <name>          # name of interp (tries to get it right)\
334            \n\t-thread <num>           # number of threads to use\
335            \n\tfileList                # files to benchmark"
336    exit 1
337}
338
339#
340# Process args
341#
342if {[catch {set BENCH(INTERP) [info nameofexec]}]} {
343    set BENCH(INTERP) $argv0
344}
345foreach {var val} {
346        ERRORS          1
347        MATCH           {}
348        RMATCH          {}
349        OUTFILE         stdout
350        FILES           {}
351        ITERS           1000
352        THREADS         0
353        PKGDIR          {}
354        EXIT            "[info exists tk_version]"
355} {
356    if {![info exists BENCH($var)]} {
357        set BENCH($var) [subst $val]
358    }
359}
360set BENCH(EXIT) 1
361
362if {[llength $argv]} {
363    while {[llength $argv]} {
364        set key [lindex $argv 0]
365        switch -glob -- $key {
366            -help*      { usage }
367            -err*       { set BENCH(ERRORS)  [lindex $argv 1] }
368            -int*       { set BENCH(INTERP)  [lindex $argv 1] }
369            -rmat*      { set BENCH(RMATCH)  [lindex $argv 1] }
370            -mat*       { set BENCH(MATCH)   [lindex $argv 1] }
371            -iter*      { set BENCH(ITERS)   [lindex $argv 1] }
372            -thr*       { set BENCH(THREADS) [lindex $argv 1] }
373            -pkg*       { set BENCH(PKGDIR)  [lindex $argv 1] }
374            default {
375                foreach arg $argv {
376                    if {![file exists $arg]} { usage }
377                    lappend BENCH(FILES) $arg
378                }
379                break
380            }
381        }
382        set argv [lreplace $argv 0 1]
383    }
384}
385
386if {[string length $BENCH(PKGDIR)]} {
387    set auto_path [linsert $auto_path 0 $BENCH(PKGDIR)]
388}
389
390if {$BENCH(THREADS)} {
391    # We have to be able to load threads if we want to use threads, and
392    # we don't want to create more threads than we have files.
393    if {[catch {package require Thread}]} {
394        set BENCH(THREADS) 0
395    } elseif {[llength $BENCH(FILES)] < $BENCH(THREADS)} {
396        set BENCH(THREADS) [llength $BENCH(FILES)]
397    }
398}
399
400rename exit exit.true
401proc exit args {
402    error "called \"exit $args\" in benchmark test"
403}
404
405if {[string compare $BENCH(OUTFILE) stdout]} {
406    set BENCH(OUTFID) [open $BENCH(OUTFILE) w]
407} else {
408    set BENCH(OUTFID) stdout
409}
410
411#
412# Everything that gets output must be in pairwise format, because
413# the data will be collected in via an 'array set'.
414#
415
416if {$BENCH(THREADS)} {
417    # Each file must run in it's own thread because of all the extra
418    # header stuff they have.
419    #set DEBUG 1
420    proc thread_one {{id 0}} {
421        global BENCH
422        set file [lindex $BENCH(FILES) 0]
423        set BENCH(FILES) [lrange $BENCH(FILES) 1 end]
424        if {[file exists $file]} {
425            incr BENCH(inuse)
426            puts $BENCH(OUTFID) [list Sourcing $file]
427            if {$id} {
428                set them $id
429            } else {
430                set them [thread::create]
431                thread::send -async $them { load {} Thread }
432                thread::send -async $them \
433                        [list array set BENCH [array get BENCH]]
434                thread::send -async $them \
435                        [list proc bench_tmpfile {} [info body bench_tmpfile]]
436                thread::send -async $them \
437                        [list proc bench_rm {args} [info body bench_rm]]
438                thread::send -async $them \
439                        [list proc bench {args} [info body bench]]
440            }
441            if {[info exists ::DEBUG]} {
442                puts stderr "SEND [clock seconds] thread $them $file INUSE\
443                $BENCH(inuse) of $BENCH(THREADS)"
444            }
445            thread::send -async $them [list source $file]
446            thread::send -async $them \
447                    [list thread::send $BENCH(us) [list thread_ready $them]]
448            #thread::send -async $them { thread::unwind }
449        }
450    }
451
452    proc thread_em {} {
453        global BENCH
454        while {[llength $BENCH(FILES)]} {
455            if {[info exists ::DEBUG]} {
456                puts stderr "THREAD ONE [lindex $BENCH(FILES) 0]"
457            }
458            thread_one
459            if {$BENCH(inuse) >= $BENCH(THREADS)} {
460                break
461            }
462        }
463    }
464
465    proc thread_ready {id} {
466        global BENCH
467
468        incr BENCH(inuse) -1
469        if {[llength $BENCH(FILES)]} {
470            if {[info exists ::DEBUG]} {
471                puts stderr "SEND ONE [clock seconds] thread $id"
472            }
473            thread_one $id
474        } else {
475            if {[info exists ::DEBUG]} {
476                puts stderr "UNWIND thread $id"
477            }
478            thread::send -async $id { thread::unwind }
479        }
480    }
481
482    proc thread_report {desc code res} {
483        global BENCH bench errorInfo errorCode
484
485        if {$code == 0} {
486            # Get just the microseconds value from the time result
487            set res [lindex $res 0]
488        } elseif {$code != 666} {
489            # A 666 result code means pass it through to the bench suite.
490            # Otherwise throw errors all the way out, unless we specified
491            # not to throw errors (option -errors 0 to libbench).
492            if {$BENCH(ERRORS)} {
493                return -code $code -errorinfo $errorInfo \
494                        -errorcode $errorCode
495            } else {
496                set res "ERR"
497            }
498        }
499        set bench($desc) $res
500    }
501
502    proc thread_finish {{delay 4000}} {
503        global BENCH bench
504        set val [expr {[llength [thread::names]] > 1}]
505        #set val [expr {$BENCH(inuse)}]
506        if {$val} {
507            after $delay [info level 0]
508        } else {
509            foreach desc [array names bench] {
510                puts $BENCH(OUTFID) [list $desc $bench($desc)]
511            }
512            if {$BENCH(EXIT)} {
513                exit.true ; # needed for Tk tests
514            }
515        }
516    }
517
518    set BENCH(us) [thread::id]
519    set BENCH(inuse) 0 ; # num threads in use
520    puts $BENCH(OUTFID) [list __THREADED [package provide Thread]]
521
522    thread_em
523    thread_finish
524    vwait forever
525} else {
526    foreach BENCH(file) $BENCH(FILES) {
527        if {[file exists $BENCH(file)]} {
528            puts $BENCH(OUTFID) [list Sourcing $BENCH(file)]
529            source $BENCH(file)
530        }
531    }
532
533    foreach desc [array names bench] {
534        puts $BENCH(OUTFID) [list $desc $bench($desc)]
535    }
536
537    if {$BENCH(EXIT)} {
538        exit.true ; # needed for Tk tests
539    }
540}
Note: See TracBrowser for help on using the repository browser.