Plotting Tcl Benchmarks

The benchmarks provided by the tclbench package are very interesting and useful, but sometimes hard to read. For examples, see Tcl Benchmarks and Tcl Normalized Benchmarks. What we really need is a good way to plot relative benchmark performance, so that you can easily see how different versions of Tcl differ from each other.

I wrote this little script, using BLT for graphing, and a little bit of GUI cruft around a simple parser for the Tcl Benchmarks output. Apologies for the obvious use of Tcl/Tk Template Applications, but you're free to improve on this. :-)


    #!/bin/sh
    # If running in a UNIX shell, restart wish on the next line \
            exec wish "$0" ${1+"[email protected]"}

    #--------------------------------------------------
    #
    #  plotTclBench.tcl
    #
    #  Plot tclBench comparison in BLT widget
    #
    #--------------------------------------------------

    #--------------------------------------------------
    #
    #  myAppMain
    #
    #  Performs basic initialization of myApp.
    #
    #--------------------------------------------------
    proc myAppMain { argc argv } {

        #--------------------------------------------------
        #  Construct the UI
        #--------------------------------------------------
        myAppInitGui .

        #--------------------------------------------------
        #  If we have an argument, then open the file
        #--------------------------------------------------
        if { [llength $argv] > 0 } {
            myAppFileOpen [lindex $argv 0]
        }

    }

    #--------------------------------------------------
    #
    #  myAppInitGui
    #
    #  Construct and initialize UI
    #
    #--------------------------------------------------
    proc myAppInitGui { root } {

        #--------------------------------------------------
        #  treat root window "." as a special case
        #--------------------------------------------------
        if {$root == "."} {
            set base ""
        } else {
            set base $root
        }

        #--------------------------------------------------
        #  Define the menu bar
        #--------------------------------------------------
        package require Tk
        menu $base.menu
        $root config -menu $base.menu
        foreach m {File Help} {
            # Use [string tolower] to ensure magic menu names are right - DKF
            set $m [menu $base.menu.[string tolower $m] -tearoff 0]
            $base.menu add cascade -label $m -underline 0 -menu [set $m]
        }

        $File add command -underline 0 -label "Open..." -command myAppFileOpen
        $File add separator
        $File add command -underline 1 -label "Exit" -command myAppExit

        $Help add command -label About -command myAppHelpAbout

        #--------------------------------------------------
        #  Set window manager properties for myApp
        #--------------------------------------------------
        wm protocol $root WM_DELETE_WINDOW { myAppExit }
        wm title $root "Tcl Bench Comparison"


        #  Add a BLT Graph widget
        package require BLT
        blt::graph .g
        Blt_ZoomStack .g
        bind Graph <Any-Motion> {displayClosest %x %y}
        grid .g
        grid columnconfigure . 0 -weight 1
        grid rowconfigure . 0 -weight 1

        #  Add some instructions and closes display
        grid [label .label -text "Click to zoom.  Click B3 to unzoom"] -sticky w
        grid [label .nearest -text ""] -sticky w

        #  Add a normalization selector
        grid [frame .f -relief raised]
        grid [label .f.label -text "Normalize graph to:"] -sticky w

        update
    }

    proc displayClosest {x y} {
        global valArray
        global testNames
        catch {
            .g element closest $x $y valArray
            set index $valArray(index)
            .nearest configure -text "Test [lindex $testNames $index]"
        }
    }

    #--------------------------------------------------
    #
    #  File Procedures
    #
    #  Note that opening, saving, and closing files
    #  are all intertwined.  This code assumes that
    #  new/open/close/exit may lose some data.
    #
    #--------------------------------------------------
    set myAppFileName ""
    set myAppChangedFlag 0
    set myAppFileTypes {
        {{All Files}        *             }
    }

    proc myAppFileOpen { {filename ""} } {
        global myAppFileName
        global myAppChangedFlag
        global myAppFileTypes
        global benchData
        global data
        global interpNames
        global testNames

        if {$filename == ""} {
            set filename [tk_getOpenFile -filetypes $myAppFileTypes]
        }

        if {$filename != ""} {
            if { [catch {open $filename r} fp] } {
                error "Cannot Open File $filename for Reading"
            }

            #--------------------------------------------------
            # insert code for "open" operation
            #--------------------------------------------------
            # read tclbench data into list of lines
            set benchData [split [read $fp [file size $filename]] "\n"]
            close $fp
            set myAppFileName $filename
            set myAppChangedFlag 0

            # process header - look for interpreter names (versions)
            set interpNames [list]
            for {set i 0} {$i < [llength $benchData]} {incr i} {
                set line [lindex $benchData $i]
                if {[string match "000*" $line] } {
                    break
                }
                if {[string match "Benchmark*" $line]} {
                    scan $line "Benchmark %d:%s " junk shortName
                    lappend interpNames $shortName
                }
            }

            # now that we've got the "000 VERSIONS" line,
            # figure out how wide to make that left side
            # label field
            set shortName [lindex [lindex $interpNames 0] 0]
            set labelEnd [expr {[string first $shortName $line]-4}]

            #  parse the columns into data lists, starting from
            #  the right hand side.  It is hard to tell how wide 
            #  to make the label field on the left, so we just
            #  start on the right, and put everything else in
            #  the X axis values
            for {incr i} {$i<[llength $benchData]-2} {incr i} {
                set line [lindex $benchData $i]
                set line [lindex $benchData $i]
                #  parse values
                set valueList [string range $line $labelEnd end]
                for {set j 0} {$j<[llength $interpNames]} {incr j} {
                    set name [lindex $interpNames end-$j]
                    set dataItem  [lindex $valueList end-$j]
                    if { ! [string is double $dataItem] } {
                        set dataItem 1
                    }
                    lappend data($name) $dataItem
                }
                #  get label string
                set labelString [string range $line 0 $labelEnd]
                lappend testNames $labelString
                scan $line "%d" testNum
                lappend x $testNum
            }


            #  Create a BLT graph data vector for every interpName
            set symbols [list circle square diamond plus cross splus scross triangle arrow]
            set colors [list black blue red green cyan magenta yellow orange brown]
            set i 0
            foreach name $interpNames {
                catch {rename y_$name ""}
                blt::vector create y_$name
                y_$name set $data($name)
                .g element create $name -xdata $x -ydata y_$name \
                        -symbol [lindex $symbols $i] -fill [lindex $colors $i]
                incr i
            }

            #  Add names to normalization menu
            catch {destroy [winfo children .f]}
            grid [label .f.label -text "Normalize graph to:"] -row 0
            set i 1
            foreach name $interpNames {
                set bname [string map {. _} $name]
                set b [button .f.b_$bname -text $name -command "normalize $name"]
                grid $b -row 0 -column $i
                incr i
            }

        }
    }

    proc normalize {name} {
        global interpNames
        y_$name dup temp
        foreach name $interpNames {
            set vec y_$name
            $vec expr {$vec / temp}
        }
        blt::vector destroy temp
    }

    proc myAppExit { } {
        exit
    }

    #--------------------------------------------------
    #  Cut/Copy/Paste
    #
    #  These procedures generate events
    #  for all Tk Widgets in the GUI
    #--------------------------------------------------
    proc myAppEditCut { } {
        event generate [focus] <<Cut>>
    }

    proc myAppEditCopy { } {
        event generate [focus] <<Copy>>
    }

    proc myAppEditPaste { } {
        event generate [focus] <<Paste>>
    }

    proc myAppSearchBindingsAndEval {event bindtags script} {
        foreach tag $bindtags {
            foreach sequence [bind $tag] {
                if {[string first $event $sequence] == 0} {
                    return [uplevel $script]
                }
            }
        }
    }
    proc myAppConfigEditMenu {menu bindtags} {
        foreach {event index} {
            <<Cut>>   0
            <<Copy>>  1
            <<Paste>> 2
        } {
            $menu entryconfigure $index -state disabled
            myAppSearchBindingsAndEval $event $bindtags {
                $menu entryconfigure $index -state normal
            }
        }
    }

    #--------------------------------------------------
    #  Help Operations
    #--------------------------------------------------

    proc myAppHelpAbout { } {
        tk_messageBox -message "tclbench data plotter"
    }

    #--------------------------------------------------
    #  Execute the main procedure
    #--------------------------------------------------
    myAppMain $argc $argv