libbench.tcl File Reference

Go to the source code of this file.

Functions/Subroutines
global BENCH bench ret	bench_tmpfile ()
ret	bench_rm (type args)
ret	bench (type args)
ret	usage ()

---

Function Documentation

ret bench

(

type

args

)

Definition at line 192 of file libbench.tcl.

References error(), global(), and time.

                       {
    global BENCH bench errorInfo errorCode

    # -pre script
    # -body script
    # -desc msg
    # -post script
    # -ipre script
    # -ipost script
    # -iterations <#>
    array set opts {
    -pre    {}
    -body   {}
    -desc   {}
    -post   {}
    -ipre   {}
    -ipost  {}
    }
    set opts(-iter) $BENCH(ITERS)
    while {[llength $args]} {
    set key [lindex $args 0]
    switch -glob -- $key {
        -res*   { set opts(-res)  [lindex $args 1] }
        -pr*    { set opts(-pre)  [lindex $args 1] }
        -po*    { set opts(-post) [lindex $args 1] }
        -ipr*   { set opts(-ipre)  [lindex $args 1] }
        -ipo*   { set opts(-ipost) [lindex $args 1] }
        -bo*    { set opts(-body) [lindex $args 1] }
        -de*    { set opts(-desc) [lindex $args 1] }
        -it*    {
        # Only change the iterations when it is smaller than
        # the requested default
        set val [lindex $args 1]
        if {$opts(-iter) > $val} { set opts(-iter) $val }
        }
        default {
        error "unknown option $key"
        }
    }
    set args [lreplace $args 0 1]
    }
    if {($BENCH(MATCH) != "") && ![string match $BENCH(MATCH) $opts(-desc)]} {
    return
    }
    if {($BENCH(RMATCH) != "") && ![regexp $BENCH(RMATCH) $opts(-desc)]} {
    return
    }
    if {$opts(-pre) != ""} {
    uplevel \#0 $opts(-pre)
    }
    if {$opts(-body) != ""} {
    # always run it once to remove compile phase confusion
    if {$opts(-ipre) != ""} {
        uplevel \#0 $opts(-ipre)
    }
    set code [catch {uplevel \#0 $opts(-body)} res]
    if {$opts(-ipost) != ""} {
        uplevel \#0 $opts(-ipost)
    }
    if {!$code && [info exists opts(-res)] \
        && [string compare $opts(-res) $res]} {
        if {$BENCH(ERRORS)} {
        return -code error "Result was:\n$res\nResult\
            should have been:\n$opts(-res)"
        } else {
        set res "BAD_RES"
        }
        set bench($opts(-desc)) $res
        puts $BENCH(OUTFID) [list Sourcing "$opts(-desc): $res"]
    } else {
        if {($opts(-ipre) != "") || ($opts(-ipost) != "")} {

        # We do the averaging on our own, to allow untimed
        # pre/post execution per iteration. We catch and
        # handle problems in the pre/post code as if
        # everything was executed as one block (like it would
        # be in the other path). We are using floating point
        # to avoid integer overflow, easily happening when
        # accumulating a high number (iterations) of large
        # integers (microseconds).

        set total 0.0
        for {set i 0} {$i < $opts(-iter)} {incr i} {
            set code 0
            if {$opts(-ipre) != ""} {
            set code [catch {uplevel \#0 $opts(-ipre)} res]
            if {$code} break
            }
            set code [catch {uplevel \#0 [list time $opts(-body) 1]} res]
            if {$code} break
            set total [expr {$total + [lindex $res 0]}]
            if {$opts(-ipost) != ""} {
            set code [catch {uplevel \#0 $opts(-ipost)} res]
            if {$code} break
            }
        }
        if {!$code} {
            set res [list [expr {int ($total/$opts(-iter))}] microseconds per iteration]
        }
        } else {
        set code [catch {uplevel \#0 \
            [list time $opts(-body) $opts(-iter)]} res]
        }
        if {!$BENCH(THREADS)} {
        if {$code == 0} {
            # Get just the microseconds value from the time result
            set res [lindex $res 0]
        } elseif {$code != 666} {
            # A 666 result code means pass it through to the bench
            # suite. Otherwise throw errors all the way out, unless
            # we specified not to throw errors (option -errors 0 to
            # libbench).
            if {$BENCH(ERRORS)} {
            return -code $code -errorinfo $errorInfo \
                -errorcode $errorCode
            } else {
            set res "ERR"
            }
        }
        set bench($opts(-desc)) $res
        puts $BENCH(OUTFID) [list Sourcing "$opts(-desc): $res"]
        } else {
        # Threaded runs report back asynchronously
        thread::send $BENCH(us) \
            [list thread_report $opts(-desc) $code $res]
        }
    }
    }
    if {($opts(-post) != "") && [catch {uplevel \#0 $opts(-post)} err] \
        && $BENCH(ERRORS)} {
    return -code error "post code threw error:\n$err"
    }
    return
}

Here is the call graph for this function:

ret bench_rm

(

type

args

)

Definition at line 150 of file libbench.tcl.

References file().

                          {
    foreach file $args {
    if {[info tclversion] > 7.4} {
        catch {file delete $file}
    } else {
        catch {exec /bin/rm $file}
    }
    }
}

Here is the call graph for this function:

global BENCH bench ret bench_tmpfile

(

)

Definition at line 122 of file libbench.tcl.

References file(), and global().

                      {
    global tcl_platform env BENCH
    if {![info exists BENCH(uniqid)]} { set BENCH(uniqid) 0 }
    set base "tclbench[incr BENCH(uniqid)].dat"
    if {[info exists tcl_platform(platform)]} {
    if {$tcl_platform(platform) == "unix"} {
        return "/tmp/$base"
    } elseif {$tcl_platform(platform) == "windows"} {
        return [file join $env(TEMP) $base]
    } else {
        return $base
    }
    } else {
    # The Good Ol' Days (?) when only Unix support existed
    return "/tmp/$base"
    }
}

Here is the call graph for this function:

ret usage

(

)

Definition at line 327 of file libbench.tcl.

References file().

              {
    set me [file tail [info script]]
    puts stderr "Usage: $me ?options?\
        \n\t-help           # print out this message\
        \n\t-rmatch <regexp>    # only run tests matching this pattern\
        \n\t-match <glob>       # only run tests matching this pattern\
        \n\t-interp <name>      # name of interp (tries to get it right)\
        \n\t-thread <num>       # number of threads to use\
        \n\tfileList        # files to benchmark"
    exit 1
}

Here is the call graph for this function: