# demosupport.tcl --
#
# Support code for running demos.
#
# Copyright (c) 2014-2017 by Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------
proc DemoParseArguments {} {
variable ::showasm 0
variable ::logtime 0
variable ::verbose 0
variable ::printout 1
variable ::doslowtests 0
variable ::restrict {}
variable ::iterations 1359
variable ::quadcode-log {}
set map {
-asm showasm
-just restrict
-iterations iterations
-print printout
-quadcode-log quadcode-log
-slow doslowtests
}
variable ::argv
foreach {key var} $map {
if {[dict exists $argv $key]} {
upvar $var v
puts "$var <- [dict get $argv $key]"
set v [dict get $argv $key]
dict unset argv $key
}
}
puts "CONFIGURE: -quadcode-log [list ${quadcode-log}] $argv"
LLVM configure -time 2 -debug 0 -quadcode-log ${quadcode-log} {*}$argv
}
#########################################################################
#
# Support procedures for the demonstration runner.
proc Filter {args} {
global restrict
foreach var $args {
upvar 1 $var v
set filtered [regsub -all -line {^\s*#.*$} $v {}]
if {$restrict eq ""} {
set v $filtered
} else {
set v [lmap op $filtered {
if {[string first $restrict $op] < 0} continue
set op
}]
}
}
}
proc EqualRep {representation1 representation2} {
set r1 [regsub -all {0x[0-9a-f]+} $representation1 ADDR]
set r2 [regsub -all {0x[0-9a-f]+} $representation2 ADDR]
return [expr {$r1 eq $r2}]
}
# This is stolen from Tcl's test suite
proc memtest {script {iterations 5}} {
variable haveMemory
if {!$haveMemory} {
# No memory command, no leak analysis...
return 0
}
set end [lindex [split [memory info] \n] 3 3]
for {set i 0} {$i < $iterations} {incr i} {
uplevel 1 $script
set tmp $end
set end [lindex [split [memory info] \n] 3 3]
}
expr {$end - $tmp}
}
variable ::haveMemory [llength [info commands memory]]
proc CleanByteArrayValue {} {
binary scan abcdefgh w i
return [binary format w $i]
}
#########################################################################
#
# Demonstration script runner for one script.
proc RunOneDemo {NS prefix op {innerIter {1 2 3 4 5}}} {
# Configuration
variable printout
variable iterations
# Caller's variables
upvar 1 val val rep rep mem mem time time
# Test support
global bytes
# Copy/mod so that we don't have problems with bytecode caches
set script " $op "
# Run test multiple times to detect literal leakage problems
set bytes [CleanByteArrayValue]
namespace eval $NS $script
set bytes [CleanByteArrayValue]
set val($prefix,$op) [namespace eval $NS $script]
if {$printout} {
puts "eval ${op}: \"$val($prefix,$op)\""
}
set bytes [CleanByteArrayValue]
set rep($prefix,$op) [tcl::unsupported::representation \
[namespace eval $NS $script]]
set mem($prefix,$op) [memtest {
set bytes [CleanByteArrayValue]
namespace eval $NS $script
}]
set time($prefix,$op) [tcl::mathfunc::min {*}[lmap _ $innerIter {
set bytes [CleanByteArrayValue]
lindex [namespace eval $NS [list time $script $iterations]] 0
}]]
# Collect this info after the timing loop; makes sure that result leaks
# show up cleanly.
set bytes [CleanByteArrayValue]
set rep($prefix,2,$op) [tcl::unsupported::representation \
[namespace eval $NS $script]]
append time($prefix,$op) " microseconds per iteration"
if {$printout} {
puts "time ${op}: $time($prefix,$op)"
}
}
#########################################################################
#
# Demonstration runner for entire suite.
proc DemoCompileAndCompare {} {
variable printout
variable doslowtests
variable showasm
global demos toCompile demos'slow'
if {$doslowtests} {
append demos ${demos'slow'}
}
set NS ::
Filter demos toCompile
set innerIter {1 2 3 4 5}
if {$printout} {
puts "==================TIME (ORIGINAL)==================="
}
foreach op $demos {
chan flush stdout; # Replicating below
RunOneDemo $NS before $op
}
puts "======================COMPILING====================="
try {
namespace eval $NS [list LLVM optimise {*}$toCompile]
if {[LLVM configure -debug]} {
puts "========================PRE========================="
puts [LLVM pre]
}
if {$showasm} {
puts "========================POST========================"
puts [LLVM post]
}
} on error {msg opt} {
puts [dict get $opt -errorinfo]
puts "========================PRE========================="
puts [LLVM pre]
exit 1
}
if {$printout} {
puts "==================TIME (OPTIMISED)=================="
}
foreach op $demos {
chan flush stdout; # In case of crashes
RunOneDemo $NS after $op
}
puts "=====================COMPARISON====================="
set same 0
set accelerated 0
foreach op $demos {
puts "-------- $op --------"
if {$val(before,$op) ne $val(after,$op)} {
puts [format "Computed results differ: expected \"%s\" but got \"%s\"" \
$val(before,$op) $val(after,$op)]
} else {
set t0 [lindex $time(before,$op) 0]
set t1 [lindex $time(after,$op) 0]
set diff [expr {($t0-$t1)*100.0/$t1}]
puts [format "Acceleration %.2f%%" $diff]
incr same
incr accelerated [expr {$t1 < $t0}]
}
# This regexp allows us to ignore refcounts on literals. Problems with
# refcount management manifest as values in the thousands.
if {[regexp {refcount of \d{3,},} $rep(after,2,$op)]} {
puts "Representation: $rep(after,2,$op)"
if {![EqualRep $rep(after,$op) $rep(after,2,$op)]} {
puts [format "Suspiciously varying representations:\n\t%s\n\t%s" \
$rep(after,$op) $rep(after,2,$op)]
}
}
if {$mem(after,$op) > 0} {
puts "Leaked memory: $mem(after,$op) bytes"
}
}
puts [format "=====================%d/%d PASSED (%d FASTER)=====================" \
$same [llength $demos] $accelerated]
}
# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# End: