# 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

    if {$doslowtests} {
	foreach var {demos toCompile} {
	    upvar 1 $var thelist $var'slow' theslowlist
	    if {[info exist theslowlist]} {
		append thelist $theslowlist
	    }
	}
    }

    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:
