path: root/tests-perf/comparePerf.tcl

#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# comparePerf.tcl --
#
#  Script to compare performance data from multiple runs.
#
# ------------------------------------------------------------------------
#
# See the file "license.terms" for information on usage and redistribution
# of this file.
#
# Usage:
#   tclsh comparePerf.tcl [--regexp RE] [--ratio time|rate] [--combine] [--base BASELABEL] PERFFILE ...
#
# The test data from each input file is tabulated so as to compare the results
# of test runs. If a PERFFILE does not exist, it is retried by adding the
# .perf extension. If the --regexp is specified, only test results whose
# id matches RE are examined.
#
# If the --combine option is specified, results of test sets with the same
# label are combined and averaged in the output.
#
# If the --base option is specified, the BASELABEL is used as the label to use
# the base timing. Otherwise, the label of the first data file is used.
#
# If --ratio option is "time" the ratio of test timing vs base test timing
# is shown. If "rate" (default) the inverse is shown.
#
# If --no-header is specified, the header describing test configuration is
# not output.
#
# The format of input files is as follows:
#
# Each line must begin with one of the characters below followed by a space
# followed by a string whose semantics depend on the initial character.
# E - Full path to the Tcl executable that was used to generate the file
# V - The Tcl patchlevel of the implementation
# D - A description for the test run for human consumption
# L - A label used to identify run environment. The --combine option will
#     average all measuremets that have the same label. An input file without
#     a label is treated as having a unique label and not combined with any other.
# P - A test measurement (see below)
# R - The number of runs made for the each test
# # - A comment, may be an arbitrary string. Usually included in performance
#     data to describe the test. This is silently ignored
#
# Any lines not matching one of the above are ignored with a warning to stderr.
#
# A line beginning with the "P" marker is a test measurement. The first word
# following is a floating point number representing the test runtime.
# The remaining line (after trimming of whitespace) is the id of the test.
# Test generators are encouraged to make the id a well-defined machine-parseable
# as well human readable description of the test. The id must not appear more
# than once. An example test measurement line:
# P    2.32280 linsert in unshared L[10000] 1 elems 10000 times at 0 (var)
# Note here the iteration count is not present.
#

namespace eval perf::compare {
    # List of dictionaries, one per input file
    variable PerfData
}

proc perf::compare::warn {message} {
    puts stderr "Warning: $message"
}
proc perf::compare::print {text} {
    puts stdout $text
}
proc perf::compare::slurp {testrun_path} {
    variable PerfData

    set runtimes [dict create]

    set path [file normalize $testrun_path]
    set fd [open $path]
    array set header {}
    while {[gets $fd line] >= 0} {
        set line [regsub -all {\s+} [string trim $line] " "]
        switch -glob -- $line {
            "#*" {
                # Skip comments
            }
            "R *" -
            "L *" -
            "D *" -
            "V *" -
            "T *" -
            "E *" {
                set marker [lindex $line 0]
                if {[info exists header($marker)]} {
                    warn "Ignoring $marker record (duplicate): \"$line\""
                }
                set header($marker) [string range $line 2 end]
            }
            "P *" {
                if {[scan $line "P %f %n" runtime id_start] == 2} {
                    set id [string range $line $id_start end]
                    if {[dict exists $runtimes $id]} {
                        warn "Ignoring duplicate test id \"$id\""
                    } else {
                        dict set runtimes $id $runtime
                    }
                } else {
                    warn "Invalid test result line format: \"$line\""
                }
            }
            default {
                puts stderr "Warning: ignoring unrecognized line \"$line\""
            }
        }
    }
    close $fd

    set result [dict create Input $path Runtimes $runtimes]
    foreach {c k} {
        L Label
        V Version
        E Executable
        D Description
    } {
        if {[info exists header($c)]} {
            dict set result $k $header($c)
        }
    }

    return $result
}

proc perf::compare::burp {test_sets} {
    variable Options

    # Print the key for each test run
    set header "           "
    set separator "           "
    foreach test_set $test_sets {
        set test_set_key "\[[incr test_set_num]\]"
        if {! $Options(--no-header)} {
            print "$test_set_key"
            foreach k {Label Executable Version Input Description} {
                if {[dict exists $test_set $k]} {
                    print "$k: [dict get $test_set $k]"
                }
            }
        }
        append header $test_set_key $separator
        set separator "                 "; # Expand because later columns have ratio
    }
    set header [string trimright $header]

    if {! $Options(--no-header)} {
        print ""
        if {$Options(--ratio) eq "rate"} {
            set ratio_description "ratio of baseline to the measurement (higher is faster)."
        } else {
            set ratio_description "ratio of measurement to the baseline (lower is faster)."
        }
        print "The first column \[1\] is the baseline measurement."
        print "Subsequent columns are pairs of the additional measurement and "
        print $ratio_description
        print ""
    }

    # Print the actual test run data

    print $header
    set test_sets [lassign $test_sets base_set]
    set fmt {%#10.5f}
    set fmt_ratio {%-6.2f}
    foreach {id base_runtime} [dict get $base_set Runtimes] {
        if {[info exists Options(--regexp)]} {
            if {![regexp $Options(--regexp) $id]} {
                continue
            }
        }
        if {$Options(--print-test-number)} {
            set line "[format %-4s [incr counter].]"
        } else {
            set line ""
        }
        append line [format $fmt $base_runtime]
        foreach test_set $test_sets {
            if {[dict exists $test_set Runtimes $id]} {
                set runtime [dict get $test_set Runtimes $id]
                if {$Options(--ratio) eq "time"} {
                    if {$base_runtime != 0} {
                        set ratio [format $fmt_ratio [expr {$runtime/$base_runtime}]]
                    } else {
                        if {$runtime == 0} {
                            set ratio "NaN   "
                        } else {
                            set ratio "Inf   "
                        }
                    }
                } else {
                    if {$runtime != 0} {
                        set ratio [format $fmt_ratio [expr {$base_runtime/$runtime}]]
                    } else {
                        if {$base_runtime == 0} {
                            set ratio "NaN   "
                        } else {
                            set ratio "Inf   "
                        }
                    }
                }
                append line "|" [format $fmt $runtime] "|" $ratio
            } else {
                append line [string repeat { } 11]
            }
        }
        append line "|" $id
        print $line
    }
}

proc perf::compare::chew {test_sets} {
    variable Options

    # Combine test sets that have the same label, averaging the values
    set unlabeled_sets {}
    array set labeled_sets {}

    foreach test_set $test_sets {
        # If there is no label, treat as independent set
        if {![dict exists $test_set Label]} {
            lappend unlabeled_sets $test_set
        } else {
            lappend labeled_sets([dict get $test_set Label]) $test_set
        }
    }

    foreach label [array names labeled_sets] {
        set combined_set [lindex $labeled_sets($label) 0]
        set runtimes [dict get $combined_set Runtimes]
        foreach test_set [lrange $labeled_sets($label) 1 end] {
            dict for {id timing} [dict get $test_set Runtimes] {
                dict lappend runtimes $id $timing
            }
        }
        dict for {id timings} $runtimes {
            set total [tcl::mathop::+ {*}$timings]
            dict set runtimes $id [expr {$total/[llength $timings]}]
        }
        dict set combined_set Runtimes $runtimes
        set labeled_sets($label) $combined_set
    }

    # Choose the "base" test set
    if {![info exists Options(--base)]} {
        set first_set [lindex $test_sets 0]
        if {[dict exists $first_set Label]} {
            # Use label of first as the base
            set Options(--base) [dict get $first_set Label]
        }
    }

    if {[info exists Options(--base)] && $Options(--base) ne ""} {
        lappend combined_sets $labeled_sets($Options(--base));# Will error if no such
        unset labeled_sets($Options(--base))
    } else {
        lappend combined_sets [lindex $unlabeled_sets 0]
        set unlabeled_sets [lrange $unlabeled_sets 1 end]
    }
    foreach label [array names labeled_sets] {
        lappend combined_sets $labeled_sets($label)
    }
    lappend combined_sets {*}$unlabeled_sets

    return $combined_sets
}

proc perf::compare::setup {argv} {
    variable Options

    array set Options {
        --ratio rate
        --combine 0
        --print-test-number 0
        --no-header 0
    }
    while {[llength $argv]} {
        set argv [lassign $argv arg]
        switch -glob -- $arg {
            -r -
            --regexp {
                if {[llength $argv] == 0} {
                    error "Missing value for option $arg"
                }
                set argv [lassign $argv val]
                set Options(--regexp) $val
            }
            --ratio {
                if {[llength $argv] == 0} {
                    error "Missing value for option $arg"
                }
                set argv [lassign $argv val]
                if {$val ni {time rate}} {
                    error "Value for option $arg must be either \"time\" or \"rate\""
                }
                set Options(--ratio) $val
            }
            --print-test-number -
            --combine -
            --no-header {
                set Options($arg) 1
            }
            --base {
                if {[llength $argv] == 0} {
                    error "Missing value for option $arg"
                }
                set argv [lassign $argv val]
                set Options($arg) $val
            }
            -- {
                # Remaining will be passed back to the caller
                break
            }
            --* {
                error "Unknown option $arg"
            }
            -* {
                error "Unknown option -[lindex $arg 0]"
            }
            default {
                # Remaining will be passed back to the caller
                set argv [linsert $argv 0 $arg]
                break;
            }
        }
    }

    set paths {}
    foreach path $argv {
        set path [file join $path]; # Convert from native else glob fails
        if {[file isfile $path]} {
            lappend paths $path
            continue
        }
        if {[file isfile $path.perf]} {
            lappend paths $path.perf
            continue
        }
        lappend paths {*}[glob -nocomplain $path]
    }
    return $paths
}
proc perf::compare::main {} {
    variable Options

    set paths [setup $::argv]
    if {[llength $paths] == 0} {
        error "No test data files specified."
    }
    set test_data [list ]
    set seen [dict create]
    foreach path $paths {
        if {![dict exists $seen $path]} {
            lappend test_data [slurp $path]
            dict set seen $path ""
        }
    }

    if {$Options(--combine)} {
        set test_data [chew $test_data]
    }

    burp $test_data
}

perf::compare::main