Index: codegen/build.tcl ================================================================== --- codegen/build.tcl +++ codegen/build.tcl @@ -5395,11 +5395,11 @@ method narrowToType.IMPURE_BOOLEAN(IMPURE\040ZEROONE\040BOOLEAN) {value {name ""}} { my addReference(STRING) [my impure.string $value] if {$name ne "" && [string match {[0-9]*} [GetValueName $value]]} { SetValueName $value $name - } +} return $value } # Builder:narrowToType.IMPURE_NUMERIC_BOOLEAN(STRING) -- # @@ -5549,10 +5549,27 @@ method narrowToType.IMPURE_NUMERIC(STRING) {value {name ""}} { set nval [my call ${tcl.extractNumeric} [list $value]] my addReference(STRING) $value return [my impure NUMERIC $value $nval $name] } + + # Builder:narrowToType.IMPURE_ZEROONE_BOOLEAN(STRING) -- + # + # Generate code to parse the given STRING and extract a Boolean value, + # either the integer 0 or 1 or one of the Boolean words. The STRING + # is already known to contain a value of the right type. Quadcode + # implementation ('narrowToType') + # + # Parameters: + # value - The STRING LLVM reference to parse. + # name (optional) - A name to give to the result value. + + method narrowToType.IMPURE_ZEROONE_BOOLEAN(STRING) {value {name ""}} { + set bval [my call ${tcl.extractZeroOneBoolean} [list $value]] + my addReference(STRING) $value + return [my impure {ZEROONE BOOLEAN} $value $bval $name] + } # Builder:nothing -- # # Create a Nothing NEXIST of the given type. # @@ -6287,10 +6304,26 @@ # Returns an LLVM INT reference method returnCode(FAIL) {src ecode name} { my packInt32 $ecode } + + # Builder:returnCode(FAIL DOUBLE) -- + # + # Pass the Tcl return code through to an LLVM value + # + # Parameters: + # src - The FAIL DOUBLE value that encodes the last interpreter action + # ecode - The INT32 value that holds the return code + # name (optional) - A name to give to the result value + # + # Results: + # Returns an LLVM INT reference + + method returnCode(FAIL\040DOUBLE) {src ecode name} { + my packInt32 $ecode + } # Builder:returnCode(FAIL STRING) -- # # Pass the Tcl return code through to an LLVM value # @@ -6304,10 +6337,26 @@ method returnCode(FAIL\040STRING) {src ecode name} { my dropReference(FAIL\040STRING) $src my packInt32 $ecode $name } + + # Builder:returnCode(FAIL ZEROONE) -- + # + # Pass the Tcl return code through to an LLVM value + # + # Parameters: + # src - The FAIL ZEROONE value that encodes the last interpreter action + # ecode - The INT32 value that holds the return code + # name (optional) - A name to give to the result value + # + # Results: + # Returns an LLVM INT reference + + method returnCode(FAIL\040ZEROONE) {src ecode name} { + my packInt32 $ecode + } # Builder:returnOptions(FAIL,INT) -- # # Get the Tcl exception dictionary. Quadcode implementation # ('returnOptions'). @@ -6322,10 +6371,28 @@ # An LLVM STRING reference. method returnOptions(FAIL,INT) {src value {name ""}} { my call ${tcl.getreturnopts} [list $value] $name } + + # Builder:returnOptions(FAIL DOUBLE,INT) -- + # + # Get the Tcl exception dictionary. Quadcode implementation + # ('returnOptions'). + # + # Parameters: + # src - The Tcl status, as a LLVM FAIL DOUBLE reference + # value - The Tcl result code, as an LLVM INT value reference. + # name (optional) - + # A name to give to the result value. + # + # Results: + # An LLVM STRING reference. + + method returnOptions(FAIL\040DOUBLE,INT) {src value {name ""}} { + my call ${tcl.getreturnopts} [list $value] $name + } # Builder:returnOptions(FAIL STRING,INT) -- # # Get the Tcl exception dictionary. Quadcode implementation # ('returnOptions'). Index: codegen/compile.tcl ================================================================== --- codegen/compile.tcl +++ codegen/compile.tcl @@ -1277,11 +1277,11 @@ method IssueInvokeFunction {tgt func arguments vname} { upvar 1 callframe callframe thecallframe thecallframe set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING} set result [$b call $func $arguments $vname] - if {[my ValueTypes $tgt] eq "FAIL"} { + if {[my ValueTypes $tgt] in {"FAIL" "CALLFRAME FAIL"}} { $b store $result $errorCode my SetErrorLine $errorCode } else { set ts [lmap t $BASETYPES {Type $t?}] if {[TypeOf $result] in $ts} { Index: codegen/mathlib.tcl ================================================================== --- codegen/mathlib.tcl +++ codegen/mathlib.tcl @@ -30,14 +30,15 @@ variable tcl.not.numericOrBoolean variable tcl.neg.numeric tcl.eq.numeric tcl.ne.numeric tcl.lt.numeric variable tcl.le.numeric tcl.gt.numeric tcl.ge.numeric variable tcl.isBoolean tcl.isInteger tcl.isDouble variable tcl.isNumeric tcl.isNumericOrBoolean - variable tcl.isTrue.numerc tcl.isTrue.numericOrBoolean + variable tcl.isTrue.numeric tcl.isTrue.numericOrBoolean variable tcl.isZeroOneBoolean variable tcl.extractNumeric tcl.extractNumericOrBoolean variable tcl.extractDouble tcl.extractInteger + variable tcl.extractZeroOneBoolean variable tcl.stringify.double tcl.stringify.int variable tcl.stringify.numeric variable tcl.cmp.strstr tcl.cmp.strnum # Builder:GrowingBinaryFunction -- @@ -1537,10 +1538,42 @@ my ret [my packNumericOrBooleanBoolean [my extract $b 1]] label getDouble: set i [my GetDouble $value] my br $testType } + + ##### Function tcl.extractZeroOneBoolean ##### + # + # Type signature: value:STRING -> ZEROONE + # + # Parse a STRING as a Boolean value. The value is known to be + # parsable. Part of the implementation of quadcode 'narrowToType'. + + set f [$m local "tcl.extractZeroOneBoolean" "BOOLEAN<-STRING"] + params value + build { + nonnull $value + my br $testType + label testType: + set type [my dereference $value 0 Tcl_Obj.typePtr] + my condBr [my nonnull $type] $testIsInt $testIsBoolean + label testIsInt: + my condBr [my isInteger $value] $returnInt $testIsBoolean + label returnInt: + set gw [my GetWide $value] + set i [my extract $gw 1] + my switch $i $no 0 $yes + label no: + my ret [Const true bool] + label yes: + my ret [Const false bool] + label testIsBoolean: + set b [my GetBoolean $value] + my condBr [my extract $b 0] $returnBoolean $testIsInt + label returnBoolean: + my ret [my extract $b 1] + } ##### Function tcl.extractDouble ##### # # Type signature: value:STRING -> DOUBLE # Index: codegen/stdlib.tcl ================================================================== --- codegen/stdlib.tcl +++ codegen/stdlib.tcl @@ -2623,10 +2623,11 @@ my br $loop7 label loop7: my condBr [my shared $sublist] $mustDuplicate $loop8 label mustDuplicate: set dupeSublist [$api Tcl_DuplicateObj $sublist] + my store $dupeSublist $subList $api TclListObjSetElement {} $parent $index $dupeSublist my br $loop8 label loop8: my store [my load $chain] \ [my cast(ptr) [my gep $parent 0 Tcl_Obj.internalRep 1] STRING] Index: codegen/varframe.tcl ================================================================== --- codegen/varframe.tcl +++ codegen/varframe.tcl @@ -51,11 +51,11 @@ variable tcl.arraystring.dropRef tcl.arraystring.dropRef.nexist variable tcl.array.init tcl.arraystring.init variable tcl.arraystring.extractarray tcl.arraystring.extractarray.nexist variable tcl.arraystring.extractscalar tcl.arraystring.extractscalar.nexist variable tcl.array.elemexists tcl.arraystring.elemexists - variable tcl.array.get tcl.array.set tcl.array.unset + variable tcl.array.get tcl.array.get.nexist tcl.array.set tcl.array.unset variable tcl.arraystring.isarray method VariableHelperFunctions {api} { set 0 [Const 0] set 1 [Const 1] @@ -2852,10 +2852,31 @@ my ret [my just $val] label unfound: my ret [my nothing STRING] } + ##### Function tcl.array.get.nexist ##### + # + # Type signature: array:ARRAY! * key:STRING -> STRING! + # + # Retrieves the contents of an element from an array. Retrives + # Nothing if the array does not exist + # + # TRICKY POINT: Does not handle traces or aliased elements. (Is the + # latter even possible in Tcl?) + + set f [$m local tcl.array.get.nexist STRING!<-ARRAY!,STRING] + params array key + build { + nonnull $key + my condBr [my maybe $array] $nothing $realArray + label nothing: + my ret [my nothing STRING] + label realArray: + my ret [my Call tcl.array.get [my unmaybe $array] $key] + } + ##### Function tcl.array.set ##### # # Type signature: array:ARRAY * key:STRING * value:STRING -> ARRAY # # Sets the contents of an element in an array, returning the updated Index: demos/perftest/support.tcl ================================================================== --- demos/perftest/support.tcl +++ demos/perftest/support.tcl @@ -106,35 +106,47 @@ # 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)" + puts -nonewline "eval $script:"; flush stdout + if {[catch {namespace eval $NS $script} result opts]} { + puts [dict get $opts -errorinfo] + set val($prefix,$op) [list *error* $result] + set rep($prefix,$op) FAILED + set rep($prefix,2,$op) FAILED + set mem($prefix,$op) 0; # Don't report leakage + append time($prefix,$op) Inf + } else { + + set bytes [CleanByteArrayValue] + set val($prefix,$op) [namespace eval $NS $script] + if {$printout} { + puts " \"[lindex $val($prefix,$op) 1]\"" + flush stdout + } + 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)" + flush stdout + } } } ######################################################################### # Index: demos/perftest/tester.tcl ================================================================== --- demos/perftest/tester.tcl +++ demos/perftest/tester.tcl @@ -565,11 +565,11 @@ list $l $x $y } proc lsetest {l {ix { 2 }}} { for {set i 0} {$i < [llength $l]} {incr i} { - lset l $i >[lindex $l $i]< + lset l $i >[lindex $l $i]< } lset l $ix abc lset l 1 1 def return $l } @@ -1847,10 +1847,16 @@ incr y $adder incr y $adder } list $x $y } + +proc redundant-set {x} { + set x $x + set x $x + return $x +} namespace eval ::inlinetwice { proc carry limb { list [expr {$limb & 0x0FFFFFFF}] [expr {$limb >> 28}] @@ -2239,10 +2245,21 @@ } set key [fromHex {85:d6:be:78:57:55:6d:33:7f:44:52:fe:42:d5:06:a8:01:0 3:80:8a:fb:0d:b2:fd:4a:bf:f6:af:41:49:f5:1b}] set msg "Cryptographic Forum Research Group" set tag [fromHex {a8:06:1d:c1:30:51:36:c6:c2:2b:8b:af:0c:01:27:a9}] + +namespace eval minfunc { + + proc a {p q} { + expr {min($p,$q)} + } + + proc b {} { + a 21 3 + } +} # A simple helper that is not compiled, but rather just shortens code below proc cleanopt {script} { variable cleanopt @@ -2563,33 +2580,27 @@ upvartest2::test1 upvartest2::test2 upvartest2::test3 upvartest2::test4 - {wideimpure 3.0} - - {hash::H9fast ultraantidisestablishmentarianistically} - {hash::H9mid ultraantidisestablishmentarianistically} - {hash::H9slow ultraantidisestablishmentarianistically} - {toHex [poly1305 compute $key $msg]} {poly1305 verify $key $msg $tag} {wideimpure 3.0} {cse-caller} {licm1 100} {licm2 100} {redundant-purify 2} + {redundant-set foobar} {inlinetwice::test 0x10000003 0x50000007} {hash::H9fast ultraantidisestablishmentarianistically} {hash::H9mid ultraantidisestablishmentarianistically} {hash::H9slow ultraantidisestablishmentarianistically} - {toHex [poly1305 compute $key $msg]} - {poly1305 verify $key $msg $tag} + {minfunc::b} } set demos'slow' { {flightawarebench::test 5 5 2} {llength [hash::main]} @@ -2646,11 +2657,13 @@ wideretest substtest substtest2 switchfail trimtest - magicreturn + # See email chain at + # https://sourceforge.net/p/tcl/mailman/message/36579552/ + # magicreturn <-- BUG in refactor-callframe returntest errortest1 errortest2 errortest2-caller errortest3 @@ -2671,22 +2684,48 @@ containment lsorttest lsortcmd # Dictionary operations (also see some [try] tests) dictest - dictest2 dictest3 + dictest2 + dictest3 dictest4 dictest5 dictest6 - dictest7 dictest8 dictest9 + dictest7 + dictest8 + dictest9 dictfor # Nonexistent variables nextest1 nextest2 nextest3 nextest4 # Array operations - arrayTest::* + ::arrayTest::aexists + ::arrayTest::errors1 + ::arrayTest::errors1a + ::arrayTest::errors1b + ::arrayTest::errors1c + ::arrayTest::errors1d + ::arrayTest::errors1e + ::arrayTest::errors1f + ::arrayTest::errors2 + ::arrayTest::errors2a + ::arrayTest::errors2b + ::arrayTest::errors2c + ::arrayTest::errors2d + ::arrayTest::errors2e + ::arrayTest::errors2f + ::arrayTest::errors3 + ::arrayTest::errors4a + ::arrayTest::errors4b + ::arrayTest::errors4c + ::arrayTest::errors4d + ::arrayTest::iexists + ::arrayTest::init + ::arrayTest::init2 + ::arrayTest::unsetelt wordcounter1 wordcounter2 wordcounter3 wordcounter4 # Calls of uncompiled code @@ -2705,14 +2744,14 @@ xsum xsum2 # Namespace tests nstestaux::pts nstest::nstest0 nstest::nstest1 - # nstest::nstest2 fails with command not found + # nstest::nstest2 fails with command not found BUG nstest::nstest3 nstest::nstest4 - # nstest::nstest5 fails with invalid command name + # nstest::nstest5 fails with invalid command name BUG nstest::nstest6 nstest::nstest7 nstest::nstest8 nstest9 upvartest::* @@ -2723,12 +2762,12 @@ # List expansion tests expandtest::joinsp expandtest::join/ expandtest::join, expandtest::fixed expandtest::fixedUp expandtest::test1 expandtest::test2 expandtest::test3 - # expandtest::test4 Needs support for return -code continue - # expandtest::test5 Needs support for loop exception ranges + # expandtest::test4 Needs support for return -code continue BUG + # expandtest::test5 Needs support for loop exception ranges BUG expandtest::test6 expandtest::test7 expandtest::test8 expandtest::test9 expandtest::test10 @@ -2749,11 +2788,16 @@ linesearch::colinear linesearch::sameline linesearch::getAllLines1 linesearch::getAllLines2 regexptest::* - vartest::* + ::vartest::accum + ::vartest::check + ::vartest::init + ::vartest::summarize + ::vartest::throw + ::vartest::throwcheck nsvartest::* directtest::init directtest::accum directtest::summarize directtest::check directtest::ary1 directtest::ary2 directtest::ary3 @@ -2763,19 +2807,40 @@ upvar0a upvartest0::* upvartest1::* upvartest2::* flightawarebench::* - hash::* + ::hash::H9fast + ::hash::H9mid + ::hash::H9slow + ::hash::Hfast + ::hash::Hmid + ::hash::Hslow + ::hash::main redundant-purify + redundant-set inlinetwice::* licm1 licm2 cse cse-caller wideimpure - poly1305::* - poly1305::tcl::mathfunc::* + ::poly1305::carry + ::poly1305::clamp + # ::poly1305::compute - Don't optimize this - SEGV ensues + # ::poly1305::debug - This gets optimized by the bytecode compiler if + # quadcode doesn't take it away. Need to make sure + # that quadcode does nothing gracefully, either by + # inlining the null function or by detecting it up + # front. + ::poly1305::equals + ::poly1305::load_130_le_26 + ::poly1305::verify + ::poly1305::tcl::mathfunc::* + fromHex toHex + minfunc::a minfunc::b + ::tcl::mathfunc::min } + set toCompile'slow' { parseBuiltinsTxt::main } ############################################################################# ADDED doc/20190216callframe/anticout.svg Index: doc/20190216callframe/anticout.svg ================================================================== --- /dev/null +++ doc/20190216callframe/anticout.svg @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ADDED doc/20190216callframe/avail.svg Index: doc/20190216callframe/avail.svg ================================================================== --- /dev/null +++ doc/20190216callframe/avail.svg @@ -0,0 +1,107 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ADDED doc/20190216callframe/availin.svg Index: doc/20190216callframe/availin.svg ================================================================== --- /dev/null +++ doc/20190216callframe/availin.svg @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ADDED doc/20190216callframe/callframe.md Index: doc/20190216callframe/callframe.md ================================================================== --- /dev/null +++ doc/20190216callframe/callframe.md @@ -0,0 +1,618 @@ +# Optimizing data motion into and out of callframes in Tcl + +Kevin B Kenny + + +## Introduction + +As of the current version ([0718166269]), the handling of variables in +the callframe reflects some fairly fundamental oversights in the effect of +Tcl operations on variables. Essentially, what it does is to introduce +`moveToCallFrame` and `moveToCallFrame` operations around a partial +subset of operations that might change or refer to a variable in a +callframe. This subset includes command invocations that are known to +access caller variables, assignments to potentially-aliased variables, +some direct operations, and very little else. It fails to account for +all the operations, while simultaneously introducing unnecessary data +motion. It also forecloses on optimizations such as deferring writes +to non-local variables to loop exits. + +This discussion is written at least partly for the benefit of its +author, to help with understanding what optimizations are safe and +profitable, and how to compute them. It will, however, hopefully aid +those who come after in understanding how the the decisions that were +made. + +### Back to basics - the code generation strategy + +One general strategy has been overwhelmingly successful in other areas +of quadcode manipulation. Rather than attempting to add operations +that handle the awkward cases when they are detected, it has been much +easier to generate code for the worst case always, and then optimize +it away. The code for variable accesses, for instance, is truly +horrific when initially generated: + + + test that a variable exists, and throw an error otherwise + + + test that the variable is not an array, and throw an error + otherwise. + + + test that the value is of an admissible type for the operation + that will use it, and throw an error otherwise. + + + downcast the value to an instance of the correct type. + + + if the value is used in an arithmetic operation, purify the value, + that is, extract the machine-native representation. + +Nevertheless, all of these tests become redundant if a second access +to the variable is dominated by the first. In that case, partial +redundancy elimination will eliminate all five of these steps and +simply use the pure value in the arithmetic operation. The partial +redundancy elimination is based largely on the value-based algorithms +developed in \[SIMP96\]. + +We therefore assume here that we will take the brutally simple +approach of generating code that: + + + whenever a local variable (whether potentially aliased or not) is + loaded, generate a `moveFromCallFrame` instruction transferring a + Tcl value into an SSA value. + + + whenever a local variable (whether potientially aliased or not) is + stored, generate a `moveToCallFrame` instruction transferring an + SSA value into a Tcl value. + + + whenever an operation (an invocation, a direct operation, etc.) + may potentially refer to a local variable or an alias + thereof. make sure that it has the callframe as one of its inputs. + + + whenever an operation (an invocation, a direct operation, etc.) + may potentially modify a local variable or an alias thereof, + make sure that it has the callframe as both an input and an + output. + + + upon procedure exit (normal or abnormal) make sure that any + potentially aliased local variables are actually returned to the + callframe. + +The last three items in the list ensure that we can track +antidependencies correctly; they become dependencies on the callframe +value. This, in turn, will require that we modify the `directSet`, +`directGet`, `directIncr`, etc. instructions, to include callframe +references. (This change will also address a set of issues marked with +**TODO** in `quadcode/translate.tcl` where it is assumed that the +`existStk`, `loadStk`, `storeStk`, etc. bytecode instructions refer +only to qualified names.) + +Simpson mentions fairly briefly how memory load operations (he uses +the example of array accesses, but our `moveFromCallFrame` +fits the scheme) can also be eliminated by his techniques. The +treatment is considerly less well developed than that for simple +values. Moreover, he calls out that memory store operations are not +amenable to his technique owing to anti-dependencies (a STORE +operation may not be hoisted above a LOAD operation that might refer +to the same memory). His technique also does not contemplate downward +code motion, where a STORE operation that does not affect a loop's +operation might be moved to after the loop exit. To address these +deficiencies, it falls to us to develop a better theory of Tcl +variable accesses. + +### Trace semantics + +As soon as we get into discussion of non-local variables, the question +of traces comes up. In this particular writeup, a very limited concept +of traces is admitted: + + * We assume that any traces present are 'well behaved' in the sense + that they do not invalidate the compilation (for instance, by + redefining or changing the resolution of compiled commands, + creating new aliases among local variables or changing their + values). + + * We assume that skipping traces is permissible to a limited + extent. In particular, repeated writes to the same variable may + fire only a trace for the last write, while repeated reads may + fire only a single read trace. We do, however, respect the + ordering among reads or writes; a procedure that reads a variable, + changes its value, and puts it back will fire a read trace and a + write trace in the correct sequence. We also promise that any read + trace will fire at a time when all prior writes have been traced. + +These constraints are weak enough that many loop-invariant reads +and writes can be optimized away. For instance, a procedure that +repeatedly reads the same global value in a loop can fire a trace only +for the first read, and one that accumulates a result through multiple +writes of the same value can defer the write until after the +loop. They nevertheless are strong enough that the common cases (the +read trace on `::env`, and the write traces on variables that appear +in Tk user interfaces) will work - and, in fact, may avoid needless +work relative to interpreted code. + +### Types of optimization to be considered + +The particular optimizations considered in this document all consist +of eliminating code motion to and from the callframe. There are a +number of these that we will attempt to cover: + + * Dead LOAD - An instruction moves a value from the callframe, but + the result is not used anywhere in the program. This case should + already be covered by the dead code analysis in quadcode. + + * LOAD-LOAD - An instruction moves a value from the callframe, and + an earlier instruction has already put the Tcl value into an + SSA value. It can be proven that the value in the callframe has + not changed, so the second move can be eliminated. + + * STORE-LOAD - An instruction moves a value from the callframe, and + an earlier instruction has moved an SSA value into the callframe. + It can be proven that the value in the callframe has not changed. + The move from the callframe can be eliminated. + + * Loop-invariant LOAD - An instruction inside a loop moves a + value from the callframe, and it can be proven that nothing inside + the loop alters the value. The move from the callframe can be + hoisted to before the start of the loop. (Note that in this + case, partial redundancy elimination actually works by creating + a second move outside the loop, and reducing the optimization to + the LOAD-LOAD case.) + + * Dead STORE - An instruction moves a value to the callframe, but + the variable in the callframe is not aliased and is not referred + to again before procedure exit. + + * LOAD-STORE - An instruction moves a value to the callframe, but + the value came from an earlier move from the same place in the + callframe, and it can be proven that the value has not changed. + The move to the callframe can be eliminated. + + * STORE-STORE - An instruction moves a value to the callframe, and + there is a _later_ instruction on each code path that moves a + value to the same place in the callframe, and nothing in between + the two instructions might read the value. It is safe to eliminate + the first store. + + * Loop invariant STORE - An instruction withing a loop moves a value + to the callframe, and nothing inside the loop loads the value. + (This condition will commonly be introduced by STORE-LOAD + elimination.) In this case, the STORE may be pushed to after the + loop exit(s). It is expected that it will be simplest to introduce + speculative move instructions at each loop exit, which will then + cause STORE-STORE optimization to eliminate the move inside the + loop. (It is possible that some of the speculative instructions + can then be optimized away by other means.) + +From among these, it is useful to separate those requiring +_anterograde_ analysis (proceeding from a procedure's entry to its +exits) from those requiring _retrograde_ analysis (proceeding from the +procedure exits to the entry). LOAD-LOAD, STORE-LOAD, loop-invariant +LOAD, and LOAD-STORE are all anterograde. They depend on the +availability of SSA counterparts to callframe values at a particular +point in the program and on whether the use of a value in the +callframe can be anticipated at a given point in the program. +By contrast, dead-LOAD, dead-STORE, STORE-STORE, and loop-invariant +STORE are retrograde. They depend on whether it is true that all paths +forward to the program exit will contain a move to the callframe or a +use of a callframe value, or whether some path contains a reference to +a callframe value. + +The pass structure of the two types of analysis is different. While +the 'iterate to convergence' structure would allow visiting the blocks +of a program in any order, performance demands that anterograde +analysis visit dominators before the blocks that they dominate, while +retrograde analysis visits postdominators before the blocks that they +postdominate. With that ordering, a given iteration to convergence +will require only a number of passes proportional to the loop nesting +depth. + +## TASK 1: Availability analysis + +The first part of anterograde analysis will begin with developing the +set of callframe values that are known to be available as SSA values. +This involves looking at the instructions of a block in order, and +accumulating the mapping of name and callframe instance to SSA value. + +Initially, the available set on exit from each block is empty. + +We iterate through a basic block, applying the following +rules. Initially, the set of available values is the set from the +block's dominator, or Ø if the block is the entry block or unreachable. + ++ `entry` - All variables listed on the instruction acquire `Nothing` as + their values. + ++ `moveFromCallFrame` - The result of the instruction becomes the + SSA value corresponding to the given variable name in the given + callframe. + ++ `moveToCallFrame` - The name-value mapping in the result callframe + is set up as follows: + + + The available values in the source callframe become available + values in the destination callframe. + + + For each name specified in the instruction from left to right, the + available value for the name becomes the corresponding value in + the instruction, and all other names that potentially alias the + given name lose their values. + ++ `invoke[Expanded]` - The available values in the source callframe + become available in the destination callframe. Then, any names that the + invoked command might change and any names that might alias them, + lose their available values. + ++ `extractCallframe` - The available values in the source callframe + become available in the destination callframe. + ++ `directSet` etc. - Any name that might be an alias of the changing + variable loses its available value. (If the changing variable name + cannot be determined, all names might be aliases, because in this + case we cannot determine that the name is fully qualified.) + ++ `variable`, `upvar`, `nsupvar` - Any existing value for the given + name and any possible alias thereof is no longer available. Note + that this is actually a program error, but we need to retain correct + behaviour in the case where the error is caught. + ++ φ - If several callframes meet at a φ, the set of names that have + available values will be the intersection of the available sets of + the input callframes. For each name in that intersection: + + + If all the incoming values are the same, that value becomes the value of + the name in the result callframe. + + + If values are different, then we find the available values for each + name on exit from the predecessor blocks, and construct a φ + instruction that combines them. We search for a φ that combines + them. + + + If such a φ is found, its result is the new value for the given + name. + + + If no such φ is found, we insert such a φ speculatively into the + header of the block, and give its result as the value for the + given name. + +At the end of the block, after applying these rules, we have the +block's new available set. The calculation of this set may in turn +change the available values on φ instructions at the start of loops, +so the calculation must be applied to convergence over all blocks in +the program. + +Those who are versed in formal data flow analysis are welcome to +separate the descriptions of the operations given above into separate +sets `AVAIL\_GEN` and `AVAIL\_KILL` so that the problem can be given as +the forward analysis: + +![\texttt{AVAIL\_OUT}[B] = \texttt{AVAIL\_GEN}[B] +~ \cup ~ \left( +\overline{\texttt{AVAIL\_KILL}[B]} +~ \cap \bigcap_{P\in \texttt{pred}[B]} \texttt{AVAIL\_OUT}[P] +\right) +](./avail.svg) + +This separation will be made in the code if it turns out that it +enables combining of passes with other callframe optimizations. + + +### Availability analysis: implications + +Calculating the available values already exposes opportunities for +optimization. In particular, LOAD-LOAD and STORE-LOAD redundancies can +be eliminated by checking each `moveFromCallFrame` operation in turn +for whether it is accessing an available value. If it is, it is +eliminated and its result is replaced with the available value. + +### Availability analysis: equivalence sets + +LOAD-STORE pairs can also be detected, by examining `moveToCallFrame` +instructions and eliminating them if the variable being written is +available, and known to be equal to the Tcl value in the callframe. + +Therefore, in the availability analysis, as well as accumulating the +sets of available Tcl values and the names in the callframe that +correspond to them, we must track the sets of names in a given +callframe that correspond correspond to each SSA value. That way, +when we examine a `moveToCallFrame` instruction, we can detect +that the given value is already in the callframe under the given name. + +## TASK 2: Live Tcl value analysis + +The first part of retrograde analysis needs to compute the sets of Tcl +variables whose values are possibly needed at the entry to each block +in the program. This analysis involves examining the instructions of +the block in _reverse_ order (that is, visiting postdominators before +the blocks that they postdominate) and accumulating the sets of needed +values. + +Initially, the required set at each block is empty. + +When beginning to examine a block, if the block is an exit, then the +set of required variables is the set of local variables that may be +aliased (by virtue of appearing in `[upvar]`, `[namespace +upvar]/[global]`, or `[variable]`. This assertion mirrors the +requirement that a compiled procedure must have all the nonlocal +variables in sync when it leaves. The set is marked as being relative +to the input callframe of the `return` instruction. + +If a block is not an exit block, then the set of required variables is +the union of the sets of variables required at the entry to its +successors. If a successor contains a φ operation that produces the +callframe to which the variable references refer, then the callframe +reference of each variable is updated to the appropriate input to the +φ. + +Then, back to front, the sets get updated by examining individual +instructions: + ++ `moveFromCallFrame` - The given variable, and all possible aliases + are added to the set of variables whose values are required. + ++ `moveToCallFrame` - The variables required will be relative to the + input callframe. Starting with the set of variables required in the + output callframe, we examine the variables given in the instruction + from left to right. For each of those, the given variable is removed + from the set of variables whose values are required. All possible + aliases of the given variable are added to the set. + ++ `invoke[expanded]` - The variables required will be relative to the + input callframe. We start with the set required relative to the + output callframe. All variables that may be read or written, and + all possible aliases, are added to the set. (Since we do not in + general examine whether a procedure must alter a given variable, + but only whether it may alter it, we require in general that the + previous value of the variable must already be in sync.) + ++ `extractCallframe` - The variables required in the source callframe + are precisely those anticipated in the destination callframe. + ++ `directGet` etc. - The variables required will be relative to the + input callframe. We start with the set required relative to the + output callframe. Any variable that might alias the variable being + retrieved or set in the instruction is added to the set. + ++ `variable`, `upvar`, `nsupvar` - The variables required will be + relative to the input callframe. We start with the set required + relative to the output callframe. The target variable and any + possible aliases are added to the set. + ++ φ - Analysis stops at a φ instruction that references a callframe. + The translation to the correct input callframe will happen when + analyzing the predecessor block, as noted above. + +When we arrive at a loop's entry, we may produce a greater set of +values that must be in sync at the bottom of the loop, so just as with +the availability analysis, the liveness analysis must be iterated to +convergence. + +### Liveness analysis: implications + +When liveness analysis is complete, it informs removal of certain +`moveToCallFrame` instructions. Any `moveToCallFrame` instruction that +designates a variable that is not live in the given callframe may be +safely removed. Either it is a dead STORE (that is, neither it nor +any potential alias will ever be accessed again), or it participates +in a STORE-STORE pair. + +## TASK 3: Anticipability analysis and loop-invariant loads + +With what has been developed in Tasks 1 and 2, we can get rid of +locally redundant `moveToCallFrame` and `moveFromCallFrame` +instructions. What remains is to attack loop-invariant ones: that is, +`moveFromCallFrame` that can be safely moved above a loop or +`moveToCallFrame` that can be safely be moved below. We use a plan of +attack based loosely on \[DREC93\]. + +### Anticipability + +We already have the concept of _availability,_ developed in +Task 1. Let us introduce some notation for available values. +`AVAIL_OUT[B]` will be notation for the set of ordered pairs +(_cf_. _name_) available in SSA registers on exit from block `B` of +the program. (In the pairs, _cf_ names an SSA variable designating a +callframe, and _name_ is the name of a variable in that frame. +Similarly, `AVAIL_IN[B]`will be the set of (_cf_, _name_) pairs +available on entry to block `B`, and we know that + +![\texttt{AVAIL\_IN}[B] = +\bigcap_{P\in \texttt{pred}[B]} \texttt{AVAIL\_OUT}[P] +\right)](./availin.svg) + +(This discussion glosses over the fact that the callframe reference +must be translated every time that it passes through a φ instruction. +The translation is straightforward - for the intersection above, the +available value will be the output of the phi; for the anticipability +analysis below, the anticipable value will be the input of the phi on +the code path being analyzed.) + +Availability by itself is not sufficient for loop-invariant code +motion. In addition, we need the concept of _anticipability_. A (_cf_, +_name_) pair is _anticipable_ at a given point in the program if every +execution path forward from that point contains a `moveFromCallFrame` +retrieving that value prior to the value's being modified. + +Calculating anticipability requires multiple traversals of the program +in postdominator order. Nothing is anticipable on `return`. For blocks +that do not return, we begin by taking the intersection of values +anticipable at their successors: + +![\texttt{ANTIC\_OUT}[B] = +\bigcap_{P\in \texttt{succ}[B]} \texttt{ANTIC\_IN}[P] +\right)](./anticout.svg) + +(Note that in computing this function, we translate the callframe +reference if it appears in a φ operation at the start of the block.) + +and then traverse the instructions of the block in reverse order. + ++ `moveFromCallFrame` - The given name and callframe reference become + anticipable. + ++ `moveToCallFrame` - The given name and callframe reference, if they + are anticipable, are removed from the anticipable set, along with + any names that might potentially be aliases of the given name .This + becomes the anticipable set for the input callframe. The output + callframe is no longer relevant and may be forgotten. + ++ `invoke[Expanded]` - Any variables potentially modified by the + invoked command, and any potential aliases, are removed from the + anticipable set, and the new set becomes the anticipable set for the + input callframe. The output callframe is no longer relevant and may + be forgotten. + ++ `extractCallFrame` - The store operations anticipated in the source + callframe are precisely those anticipated in the destination + callframe, and the destination callframe is no longer relevant. + ++ `directGet` - Since (as stated above) we ignore the possibility that + a read trace on one variable may modify another, we simply copy all + anticipable references. + ++ `directSet`, etc. - Any local variable that might alias the + variable being modified is no longer anticipable, and once again + the callframes are swapped as with `moveToCallFrame` and `invoke`. + ++ `variable`, `upvar`, `nsupvar` - The local variable and any aliases + are no longer anticipable. + ++ φ - Analysis stops at a φ instruction that references a callframe. + When analyzing a predecessor block, `ANTIC_IN` for its successors + will be translated to refer to the callframe that is input to the φ. + +If a block has no φ instruction for the callframe, the same callframe +will be used when constructing its `ANTIC_IN` when analyzing a predecessor. + +### Placement of load instructions + +Once the `AVAIL_OUT` and `ANTIC_IN` sets are constructed, we can +determine where to place additional `moveFromCallFrame` instructions +that will perform loop-independent code motion. + +Since the entry block of a loop is always a merge point in the control +flow, its predecessor blocks will be single-exit blocks owing to +critical edge splitting. We need consider only insertion of +`moveFromCallFrame` instructions at these points. + +The general plan is sketched in Section 4.3.2 of \[VanD04\]. We +examine merge points in the program (blocks with more than one +predecessor), in dominator order. For each (_cf_, _name_) that is +anticipable at the entry to the block, we check availability in the +predecessor blocks. If the expression is available in at least one +predecessor, but not all predecessors, we insert `moveFromCallFrame` +instructions for it in the predecessors where it is unavailable. + +This is another analysis that must be iterated to +convergence. Inserting these `moveFromCallFrame` operations produces +new available variables, which can in turn expose further +opportunities for code motion. \[VAND04\] discusses this in more +detail in chapter 4. + +### Possible combination of passes + +This analysis closely mirrors what happens in partial redundancy +elimination (`quadcode/pre.tcl`). It may be possible to combine the +two into a single pass. The principal change will be that availability +analysis will need some refactoring, to discipline the size of the +`AVAIL` sets. Unlike the description in \[SIMP96\], we do not need to +shrink any of these sets for safety, because every time we perform an +operation that might affect a value in the callframe, we assign a new +SSA value to the callframe. Nevertheless, the quadcode sequence is +structured so that only one callframe is in flight at any given +time. Even if procedure inlining gives rise to additional callframes, +we still have the weaker condition that if there is an instruction +like + +`doSomething cfout cfin moreArgs` + +the input callframe will never again be used. + +## TASK 4: Loop-invariant stores + +We have seen in Task 3 that `moveFromCallFrame` instructions can be +placed speculatively to convert partial availability of a needed +expression to full availability (and remove a `moveFromCallFrame` +later in the program on a 'busier' execution path). In a similar manner, +`moveToCallFrame` instructions can be placed speculatively at the +head of blocks in order to make partially dead assignments ("faint" +assignments in the terminology of \[KNOO94\]) fully dead and eliminate +a `moveToCallFrame` on an eariler path of the program. + +\[LO98\] demonstrates how this partial liveness analysis is precisely +dual to partial availability analysis, and introduces a dual form to +Static Single Assignment (SSA), called Static Single Use (SSU). This +latter form has similar advantages to SSA in that the dependency +chain, here from definition to use rather than from use to definition, +is factored so that there are explicit deviation points (dual to the merge +points represented by φ operations in SSA form), and all divergence +analysis can be limited to those points (just as confluence analysis +can be limited to φ operations.) + +Since this analysis, and the liveness analysis on SSA values that is +used to insert `free` instructions, appear to be the only places where +factored _du_-chains are of interest in the quadcode compiler, it +appears that converting programs to SSU (or combined SSA/SSU) form +will not be profitable, compared with the additional expense of +performing the analysis on an un-factored data flow graph. For this +reason, the more computationally complex analysis of \[KNOO94\] will +be followed, but modified to operate on basic blocks rather than +individual instructions. + +We begin with the liveness analysis of Task 2. We augment 'liveness' +with the concept of partial liveness. The data flow equations will look like + +![\textt{LIVE\_OUT}[B] formula](liveout.svg) + +![\textt{PLIVE\_OUT}[B] formula](pliveout.svg) + +![\textt{LIVE\_IN}[B] = \textt{process}(B, \textt{LIVE\_OUT}[B])](livein.svg) + +![\textt{PLIVE\_IN}[B] = \textt{process}(B, \textt{PLIVE\_OUT}[B])](plivein.svg) + +In these equations, _process_ represents the basic-block-level upward +analysis from Task 2. The _LIVE_ and _PLIVE_ sets are sets of +(callframe, variable) pairs, and it is assumed that the arguments to +the intersection and union are translated if the callframe appears in +a φ operation. + +Liveness corresponds to the 'availability' of the partial redundancy +elimination. Just as a `moveFromCallFrame` may not be hoisted over the +point where it is available, a `moveToCallFrame` may not be sunk past the +point where it is live. + +Similarly, `moveToCallFrame` creates values and corresponds to +anticipability. Just as it is of no benefit to insert a +`moveFromCallFrame` for a value that is not anticipated, it is of no +benefit to insert a `moveToCallFrame` for a value that is already present. + + + +## References + +\[DREC93\] Karl-Heinz Drechsler and Manfred P. Stadel. "A variation of +Knoop, Rüthing, and Steffen's _Lazy Code Motion_". _ACM SIGPLAN +Notices_ 28:5 (May, 1993), pp. 29-38. +[] + +\[KNOO94\] Jens Knoop, Oliver Rüthing, and Bernhard Steffen. "Partial +dead code elimination". Proc. 1994 ACM SIGPLAN Conf. Orlando, +Fla. USA: ACM, June 1994, pp. 147-158. +[] + +\[LO98\] Raymond Lo, Fred Chow, Robert Kennedy, Shin-Ming Liu, and +Peng Tu. "Register promotion by sparse partial redundancy elimination +of loads and stores." Proc. 1998 ACM SIGPLAN Conf. Programming +Language Design and Implementation (PLDI '98). Montreal, Canada: ACM, +June, 1998, pp. 26-37. +[] + +\[SIMP96\] +Loren Taylor Simpson. 1996. "Value-Driven Redundancy +Elimination". Ph.D. Dissertation. Rice University, Houston, TX, +USA. AAI9631092. +[] + +\[VanD04\] +VanDrunen, Thomas J. "Partial redundancy elimination for global value +numbering." PhD thesis, Purdue University, West Lafayette, Indiana +(August, 2004) +[] ADDED doc/20190216callframe/livein.svg Index: doc/20190216callframe/livein.svg ================================================================== --- /dev/null +++ doc/20190216callframe/livein.svg @@ -0,0 +1,62 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ADDED doc/20190216callframe/liveout.svg Index: doc/20190216callframe/liveout.svg ================================================================== --- /dev/null +++ doc/20190216callframe/liveout.svg @@ -0,0 +1,165 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ADDED doc/20190216callframe/plivein.svg Index: doc/20190216callframe/plivein.svg ================================================================== --- /dev/null +++ doc/20190216callframe/plivein.svg @@ -0,0 +1,65 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ADDED doc/20190216callframe/pliveout.svg Index: doc/20190216callframe/pliveout.svg ================================================================== --- /dev/null +++ doc/20190216callframe/pliveout.svg @@ -0,0 +1,168 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Index: doc/middle-end.md ================================================================== --- doc/middle-end.md +++ doc/middle-end.md @@ -504,15 +504,10 @@ * `removeSplitMarkers` (`quadcode/nodesplit.tcl`): Removes the `split` quadcodes that were introduced by `insertSplitMarkers` and used in `nodesplit` to track how much it had ballooned the code size. -* `removeCallFrameNop` (`quadcode/callframe.tcl`) Removes - `callFrameNop` instructions that are used to keep callframe moves - attached to assignments to linked variables. After this point, code - reoredering transformations are forbidden. - * `uselessphis`: This cleanup is needed because `removeCallFrameNop` instructions may have made `phi` operations on the callframe redundant. * `eliminateCallFrame` (`quadcode/callframe.tcl`): If the Index: quadcode/aliases.tcl ================================================================== --- quadcode/aliases.tcl +++ quadcode/aliases.tcl @@ -28,5 +28,16 @@ return [dict keys $l2] } else { return {} } } + +# quadcode::transformer method local-aliases -- +# +# Enumerates local variables that may alias a non-local variable. +# +# Results: +# Returns a list of the variable names. + +oo::define quadcode::transformer method local-aliases {} { + return [lmap x [dict keys $links] {lindex $x 1}] +} Index: quadcode/bb.tcl ================================================================== --- quadcode/bb.tcl +++ quadcode/bb.tcl @@ -339,21 +339,57 @@ # to - Successor of the new block # # Results: # Returns the new block's block number - method makeEmptyBB {to} { - # Create the block + method makeEmptyBB {{to -1}} { + + # Create the block, with a jump if needed. set newb [llength $bbcontent] - lappend bbcontent [list [list jump [list bb $to]]] + if {$to >= 0} { + lappend bbcontent [list [list jump [list bb $to]]] + } else { + lappend bbcontent {} + } lappend bbpred {} # Link $to to the new block - my bblink $newb $to + if {$to >= 0} { + my bblink $newb $to + } return $newb } + + # replaceBB -- + # + # Replaces the content of a basic block + # + # Parameters: + # b - Block number to replace + # bb - New content + # + # Results: + # None. + + method replaceBB {b bb} { + lset bbcontent $b $bb + } + + # gettBB -- + # + # Retrieves the content of a basic block + # + # Parameters: + # b - Block number to retrieve + # + # Results: + # Returns the basic block content + + method getBB {b} { + return [lindex $bbcontent $b] + } # bbcopy -- # # Makes a copy of a basic block # @@ -413,31 +449,49 @@ # of some sort). method bb2exit {b} { expr {[lindex $bbcontent $b end-1 1 0] eq "bb"} } + + # bbpred -- + # Query a basic block for its predecessors + # + # Parameters: + # b - Basic block oindex + # + # Results: + # Returns a dictionary whose keys are the basic block numbers of + # predecessors and whose values are immaterial + + method bbpred {b} { + return [lindex $bbpred $b] + } # bbsucc -- # Query a basic block for its successors. # # Parameters: # b - Basic block index + # bb - Basic block content, if the content is known or modified. # # Results: # Returns a list (0, 1 or 2 elements) of the successors of the block. # Blocks that return have no successors. - method bbsucc {b} { - if {[lindex $bbcontent $b end 0] eq "return"} { + method bbsucc {b {bb {}}} { + if {$bb eq {}} { + set bb [lindex $bbcontent $b] + } + if {[lindex $bb end 0] eq "return"} { return {} } else { set l {} - set q [lindex $bbcontent $b end-1] + set q [lindex $bb end-1] if {[lindex $q 1 0] eq "bb"} { lappend l [lindex $q 1 1] } - set q [lindex $bbcontent $b end] + set q [lindex $bb end] if {[lindex $q 1 0] eq "bb"} { lappend l [lindex $q 1 1] } } } ADDED quadcode/builder.tcl Index: quadcode/builder.tcl ================================================================== --- /dev/null +++ quadcode/builder.tcl @@ -0,0 +1,308 @@ +# builder.tcl -- +# +# Class that allows for building new quadcode inside a +# quadcode::transformer. +# +# Copyright (c) 2018 by Kevin B. Kenny +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# Some passes that modify quadcode do fairly extensive code rewriting, and +# it's convenient have procedures to track these and allow access at a level +# closer to an 'assembly language'. This class contains convenience methods +# to allow automatic tracking of variable uses and defs, named temporaries, +# and named basic blocks. +# +#------------------------------------------------------------------------------ + +# quadcode::builder -- +# +# Class with support methods for building quadcode. +# +oo::class create quadcode::builder { + + variable xfmr; # quadcode::transformer object containing + ; # the quadcode of interest. + + variable b; # Basic block number under construction + + variable bbindex; # Dictionary whose keys are the names of + ; # basic blocks and whose values are the + ; # basic block numbers. + + variable varindex; # Dictionary whose keys are named variables + ; # and whose values are the SSA names of the + ; # variables. +} + +# quadcode::builder constructor -- +# +# Makes a quadcode::builder to allow for assembling quadcode. +# +# Parameters: +# xfmr - quadcode::transformer object containing the subprogram +# b - Basic block number under construction +# bb - Basic block content of the block under construction + +oo::define quadcode::builder constructor {xfmr_ b_ bb_} { + set xfmr $xfmr_ + set b $b_ + set bb $bb_ + set bbindex {} + set varindex {} + $xfmr replaceBB $b $bb +} + +# quadcode::builder method curblock -- +# +# Returns the number of the current basic block. +# +# Results: +# Basic block number + +oo::define quadcode::builder method curblock {} { + return $b +} + +# quadcode::builder method makeblock -- +# +# Makes a new basic block. +# +# Parameters: +# name - Name to give to the block +# +# Results: +# Returns the basic block number +# +# Side effects: +# Creates the block. Stores the block index in 'bbindex' if name is +# supplied + +oo::define quadcode::builder method makeblock {{name {}}} { + + # Create the block + set newb [$xfmr makeEmptyBB] + + # Index the block + if {$name ne {}} { + dict set bbindex $name $newb + } + + return $newb +} + +# quadcode::builder method getblock -- +# +# Finds a basic block created by 'makeblock' +# +# Parameters: +# name - Name of the block +# +# Results: +# Returns the basic block number, or -1 if there is no such block + +oo::define quadcode::builder method getblock {name} { + if {![dict exists $bbindex $name]} { + return -1 + } else { + return [dict get $bbindex $name] + } +} + +# quadcode::builder method buildin -- +# +# Switch to a different basic block for building +# +# Parameters: +# newb - Basic block to start building in. +# +# Results: +# None. + +oo::define quadcode::builder method buildin {newb} { + + # Set to build in the new basic block + set b $newb + + return + +} + +# quadcode::builder method maketemp -- +# +# Makes a temporary variable. +# +# Parameters: +# name - Base name for the temporary. +# +# Results: +# Returns the name of the constructed temporary. +# +# Side effects: +# Stores the name as the most recent instance of the temporary. + +oo::define quadcode::builder method maketemp {name} { + set ssaname [$xfmr newVarInstance [list temp @$name]] + dict set varindex $name $ssaname + return $ssaname +} + +# quadcode::builder method gettemp -- +# +# Gets the last instance of a temporary variable +# +# Parameters: +# name - Base name of the temporary +# +# Results: +# Returns the SSA name of the lastest instance of the temporary, +# or "" if there is no instance. + +oo::define quadcode::builder method gettemp {name} { + if {[dict exists $varindex $name]} { + return [dict get $varindex $name] + } else { + return {} + } +} + +# quadcode::builder method emit -- +# +# Emits an instruction into the basic block under construction. +# +# Parameters: +# q - Quadcode instruction to emit +# +# Results: +# None. +# +# Side effects: +# Appends the instruction to the basic bnlock under construction. +# If the instruction is a jump, adds the basic block predecessor +# relationship. If the instruction is an assignment, updates the +# ud-chain of the assigned variable. Updates the du-chains of all +# variables used oin the instruction. + +oo::define quadcode::builder method emit {q} { + + # Split the instruction + lassign $q opcode res argl + + # Handle the result + switch -exact -- [lindex $res 0] { + "bb" { + # Instruction is a jump, link the basic block to the jump target + $xfmr bblink $b [lindex $res 1] + } + "temp" - "var" { + # Instrtuction is an assignment, update the ud-chain. + $xfmr addDef $res $b + } + } + + # Handle the arguments + foreach arg [lrange $q 2 end] { + switch -exact -- [lindex $arg 0] { + "temp" - "var" { + + # Argument is an SSA value, update the du-chain. + $xfmr addUse $arg $b + } + } + } + + # Add the instruction to the block + set bb [$xfmr getBB $b] + $xfmr replaceBB $b {} + lappend bb $q + $xfmr replaceBB $b $bb + + return +} + +# quadcode::builder method updatephi -- +# +# Adds a given basic block and value as the source of a phi +# operation in another block. +# +# Parameters: +# to - Basic block being jumped to +# var - Variable output from the phi +# val - Data source for that variable. +# +# Results: +# None. +# +# Side effects: +# Adds to the phi the given value, indicated as coming from +# the builder's current block. + +oo::define quadcode::builder method updatephi {to var val} { + + # Get the target basic block + set targetbb [$xfmr getBB $to] + $xfmr replaceBB $to {} + + # Find the phi + set pc -1 + foreach q $targetbb { + incr pc + if {[lindex $q 0] ne "phi"} { + break + } + if {[lindex $q 1] eq $var} { + set targetpc $pc + break + } + } + + # Bail out if we can't find it + if {![info exists targetpc]} { + error "Cannot find variable $var in a phi in block $to" + } + + # Update the phi + set q [lindex $targetbb $targetpc] + lset targetbb $targetpc {} + lappend q [list bb $b] $val + lset targetbb $targetpc $q + $xfmr addUse $val $to + + # Put the target basic block back + $xfmr replaceBB $to $targetbb +} + +if 0 { # Rethink, if anything uses this... +# quadcode::builder method bb -- +# +# Returns the content of the basic block under construction. +# +# Results: +# Returns the instructions. + +oo::define quadcode::builder method bb {} { + return $bb +} +} + +# quadcode::builder method log-last -- +# +# Logs the last instruction emitted to the standard output +# +# Results: +# None. + +oo::define quadcode::builder method log-last {} { + set bb [$xfmr getBB $b] + set pc [expr {[llength $bb] -1}] + puts " $b:$pc: [lindex $bb end]" +} + +# Local Variables: +# mode: tcl +# fill-column: 78 +# auto-fill-function: nil +# buffer-file-coding-system: utf-8-unix +# indent-tabs-mode: nil +# End: Index: quadcode/callframe.tcl ================================================================== --- quadcode/callframe.tcl +++ quadcode/callframe.tcl @@ -7,10 +7,1498 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ + +# Class: quadcode::callFrameAnalysis +# +# Purpose: +# +# Encapsulates code that analyzes data flows among variables in +# the callframe, and removes redundant 'moveFromCallFrame' and +# 'moveToCallFrame' instructions. +# +# This class is instantiated at any time the callframe analysis pass runs. +# It is invoked solely from the 'callframeDataFlow' method inside the +# 'quadcode::transformer' class. + +oo::class create quadcode::callFrameAnalysis { + + # xf is the quadcode::transformer object compiling the procedure at + # hand + + variable xf + + # nbb is the number of basic blocks in the program. + + variable nbb + + # Since the quadcode is structured so that only one callframe is + # in flight at any given time, the logic here can be structured + # so that only a single mapping among variables is in + # flight. For a consistency check, we store in 'activeCFOut' a + # list indexed by basic block whose values are the active + # callframe on exit from the block. On entry to a block, we + # expect that either all predecessors will agree on the active + # callframe or else that there is already a phi in the block's + # header that merges the active callframes of the individual + # predecessor blocks. If this assumption is violated, we assume + # for safety that there are no quadcode values corresponding to + # callframe variables + + variable activeCFOut + + # The 'seq' variable is used to serialize the names of temporary objects. + + variable seq + + # The 'bbdirty' variable is an array of flags indicating whether each + # basic block is 'dirty' in the current analysis pass and must be reanalyzed + + variable bbdirty + + # The 'specPhi' variable is a dictionary whose keys are the + # quadcode variable names of speculative phi instructions, and + # whose values are the right-hand sides of the phis + + variable specPhi + + # The 'availOut' variable is list of dictionaries. List indices are + # basic block numbers. Dictionary keys are the names of callframe + # variables, and the values are the quadcode values known to hold the + # variables' values on exit from the basic block. + + variable availOut + + # The 'availEquiv' variable is a dictionary whose keys are quadcode values + # that are known to be copies of a value in the callframe, and whose + # values are the copied value. + + variable availEquiv + + # The 'pointlessStore' variable is a two-level dictionary whose keys + # are result callframes of 'moveToCallFrame' instructions, second-level + # keys are Tcl variable names, and values are immaterial. It enumerates + # store operations that are returning to the callframe values that are + # known already to be there. + + variable pointlessStore + + # The 'liveIn' variable is a list of dictionaries. List indices + # are basic block numbers. Dictionary keys are callframe variables that + # are live on entry to the block, and values are immaterial. + + variable liveIn + + # The 'eliminableLoad' variable is a dictionary whose keys are the results + # of 'moveFromCallFrame' instructions and whose values are values that + # may be copied instead of loading from the callframe. + + variable eliminableLoad + + # The 'deadStore' variable is a dictionary whose keys are callframe values + # and whose values are immaterial. Entries are present in 'deadStore' if + # the corresponding 'moveToCallFrame' operations are storing values that + # will never be loaded. + + variable deadStore + + # quadcode::callFrameAnalysis constructor -- + # + # Prepares to perform data flow analysis on variables in the callframe + # + # Parameters: + # xf_ - The quadcode::transformer object that is compiling the procedure + # at hand. + # + # Results; + # None. + # + # Side effects: + # Initializes available variable sets to empty, and the active callframe + # on exit from each block to an unknown state. + # Sets the serialization number to -1 + + constructor {xf_} { + + set xf $xf_ + + set nbb [llength [$xf bbcontent]] + set availOut [lrepeat $nbb {}] + set availEquiv [dict create Nothing Nothing] + set pointlessStore {} + set liveIn [lrepeat $nbb {}] + set activeCFOut [lrepeat $nbb {}] + set specPhi {} + set eliminableLoad {} + set deadStore {} + + set seq -1 + } +} + +# quadcode::callFrameAnalysis method analyzeForward -- +# +# Performs the initial pass of forward data flow analysis on +# the quadcode sequence. +# +# Results: +# Returns 1 if there are opportunities to optimize, 0 otherwise. +# +# Side effects: +# Populates the 'availOut', 'activeCFOut' and 'eliminableLoad' arrays. +# +# In addition, may modify the quadcode to add speculative phi +# instructions that combine the quadcode values for available +# callframe variables, to enable more aggressive elimination of +# downstream 'moveFromCallFrame' operations. At the conclusion +# of this pass, it is known which speculative phis will actually +# be beneficial. Others will be eliminated in the 'eliminate' +# pass, which must run even if this pass returns 0. + +oo::define quadcode::callFrameAnalysis method analyzeForward {} { + + set did_something 0 + + # Set up 'bbq' to be a priority queue of blocks awaiting analysis, + # ordered by block number (which orders in depth-first numbering) + # and set up 'bbdirty' as an array of flags, indexed by block number, + # that contains 1 if a block is queued and 0 otherwise. Initially + # the queue contains every block in the program. + + quadcode::numheap create [namespace current]::bbq + set b -1 + set bbdirty {} + foreach bb [$xf bbcontent] { + incr b + lappend bbdirty 1 + bbq add $b + } + + # Process the queue elements. If processing any basic block changes + # the data that appears at its output, force its successors to be + # analyzed. + + while {![bbq empty]} { + set b [bbq removeFirst] + lset bbdirty $b 0 + $xf editBasicBlock bb $b { + set changed [my analyzeForwardBB $b bb] + } + if {$changed} { + foreach s [$xf bbsucc $b] { + if {![lindex $bbdirty $s]} { + lset bbdirty $s 1 + bbq add $s + } + } + } + } + + bbq destroy + + $xf debug-callframe { + puts "callframe: loads that may be eliminated:" + dict for {res source} $eliminableLoad { + puts " $res = $source" + } + puts "callframe: speculative phis that may need to be cleaned up:" + dict for {res inputs} $specPhi { + puts " $res" + } + } + + return [expr {[dict size $eliminableLoad] > 0}] +} + +# quadcode::callFrameAnalysis method analyzeForwardBB -- +# +# Analyzes one basic block in the forward direction for callframe effects +# +# Parameters: +# b - Basic block number +# bbVar - Name of a variable in caller's scope that contains the basic +# block's instructions and may be modified during the analysis. +# +# Results: +# Returns 1 if anything has changed, 0 if everything is the same +# as on a previous attempt. +# +# This method updates the b'th entry of'activeCFOut' to the active +# callframe on exit from the block, and the b'th entry of 'availOut' +# to be a dictionary mapping variable names in the callframe to the +# corresponding quadcode variables. + +oo::define quadcode::callFrameAnalysis method analyzeForwardBB {b bbVar} { + + upvar 1 $bbVar bb + namespace upvar ::quadcode::dataType CALLFRAME CALLFRAME + + $xf debug-callframe { + puts "callframe: [$xf full-name] forward analysis for block $b" + } + + # Find the active callframe and initialize available variables if possible. + # This can be done if the active callframe is the same on exit from + # each predecessor block and the available variables have the same values + # in every predecessor. (This will trivially be the case if the block has + # a single predecessor.) + + set preds [$xf bbpred $b] + set acf [my activeCallFrameIn $b] + if {$acf ne ""} { + set avail [my availVarsIn $b $acf] + } else { + set avail {} + } + $xf debug-callframe { + puts "Available in $acf on input to $b: $avail" + } + + # Walk through the quadcode, updating the active callframe and the + # available variables as needed. + + # newbb is the rewritten content of the current basic block. + set newbb {} + + # phisSeen will be a dictionary whose keys are the data sources of phi + # operations and whose values are the results of the phis. + set phisSeen {} + + # If 'cfPhi' is set, it will be the phi instruction that supplies the + # callframe on entry to this procedure. + + set didHeader 0 + set pc -1 + foreach q $bb { + incr pc + $xf debug-callframe { + puts "$b:$pc: $q" + } + set opcode [lindex $q 0 0] + + # Once we've seen all the phi's, insert any speculative phi's we need + # in order to account for callframes that meet at convergence points + + if {$opcode ne "phi" && [dict size $preds] > 1 && !$didHeader} { + set didHeader 1 + + # This is a convergence point. If we don't have a phi for the + # callframe, it must have a single source. Make a fake phi so that + # 'makeSpeculativePhis' can copy it for the input vars: + # phi $fromcf $pred1 $fromcf $pred2 $fromcf ... + if {![info exists cfPhi]} { + set cfPhi [list "phi"] + dict for {p -} $preds { + set cfin [lindex $activeCFOut $p] + if {$cfin ne {}} { + lappend cfPhi $cfin + break + } + } + dict for {p -} $preds { + lappend cfPhi [list bb $p] $cfin + } + $xf debug-callframe { + puts "FAKE PHI: $cfPhi" + } + } + + # Insert speculative phis for the variables in the source + # callframes that meet here. + dict for {var phiRHS} [my makeSpeculativePhis $cfPhi $phisSeen] { + if {[llength $phiRHS] == 1} { + set rh [lindex $phiRHS 0] + dict set avail $var $rh + dict set availEquiv $rh $rh + $xf debug-callframe { + puts " avail($var) - $rh" + puts " availEquiv($rh) - $var" + } + } else { + set newvref [$xf newVarInstance [list "var" $var]] + $xf addDef $newvref $b + set newq [list phi $newvref] + foreach {frombb source} $phiRHS { + $xf addUse $source $b + lappend newq $frombb $source + } + $xf debug-callframe { + puts " insert: $newq" + } + lappend newbb $newq + dict set avail $var $newvref + dict set availEquiv $newvref $newvref + $xf debug-callframe { + puts " avail($var) - $newvref" + puts " availEquiv($newvref) - $newvref" + } + dict set phisSeen $phiRHS $newvref + dict set specPhi $newvref $phiRHS + set changed 1 + } + } + unset cfPhi + } + + switch -exact $opcode { + + "copy" - + "extractArray" - + "extractExists" - + "extractScalar" - + "narrowToType" { + + # If we are copying or narrowing from a value that's known + # to be in the callframe, the result can be treated as + # equivalent to that value, and a store of the result can + # be eliminated + + lassign $q opcode vout vin + if {[dict exists $availEquiv $vin]} { + dict set availEquiv $vout [dict get $availEquiv $vin] + $xf debug-callframe { + puts " - availEquiv($vout) -\ + [dict get $availEquiv $vout]" + } + } + } + + "directArrayExists" - + "directArrayGet" - + "directExists" - + "directGet" - + "directIsArray" { + lassign $q opcode cfresult cfin name + # There really is nothing to do, unless 'name' is constant + # and unqualified, in which case it's a local var. + # Also, 'directGet' doesn't really need to return the + # callframe at all, as far as I can tell. + + if {$acf ne $cfin} { + $xf debug-callframe { + puts "WHAT? callframe is $cfin, active is $acf" + } + $xf diagnostic warning $b $pc \ + "invoke in other than the active callframe,\ + should not happen" + set avail {} + } + } + + "directAppend" - + "directArrayAppend" - + "directArrayLappend" - + "directArrayLappendList" - + "directArraySet" - + "directArrayUnset" - + "directLappend" - + "directLappendList" - + "directMakeArray" - + "directSet" - + "directUnset" { + lassign $q opcode cfresult cfin name value + if {$acf ne $cfin} { + $xf debug-callframe { + puts "WHAT? callframe is $cfin, active is $acf" + } + $xf diagnostic warning $b $pc \ + "invoke in other than the active callframe,\ + should not happen" + set avail {} + } + # If name is constant and qualified, spoil the aliases + # of globals. If name is not constant, spoil everything. + $xf debug-callframe { + puts "q = $q" + puts "What does setting $name do?" + } + if {[lindex $name 0] eq "literal" + && [regexp :: [lindex $name 1]]} { + foreach v [$xf local-aliases] { + $xf debug-callframe { + puts " $v will be unavailable\ + because it might alias [lindex $name 1]" + } + dict unset avail $v + } + } else { + $xf debug-callframe { + puts " direct set of an unknown variable makes\ + all values unavailable" + } + set avail {} + } + set acf $cfresult + } + + "entry" { + set acf [lindex $q 1] + set avail {} + foreach v [lindex $q 2 1] { + $xf debug-callframe { + puts " $v will be available but unset" + } + dict set avail $v Nothing + } + } + + "extractCallFrame" { + # All the variables available in the callframe+result will + # become available in the extracted callframe + set acf [lindex $q 1] + } + + "invoke" - + "invokeExpanded" { + + set args [lassign $q op cfout cfin command] + + if {[$xf typeOfOperand $cfout] & $CALLFRAME} { + + # Consistency check: Make sure that the active callframe + # is correctly linked. + if {$acf ne $cfin} { + $xf debug-callframe { + puts "WHAT? callframe is $cfin, active is $acf" + } + $xf diagnostic warning $b $pc \ + "invoke in other than the active callframe,\ + should not happen" + set avail {} + } else { + + # Determine what variables in the current frame might be + # modified by this operation. + set atypes [lmap x $args {$xf typeOfOperand $x}] + lassign [$xf variablesProducedBy $q $atypes] known wlist + if {!$known} { + + # The modified set is not known, spoil all vars + $xf debug-callframe { + puts " has an unknown effect, spoil all vars" + } + set avail {} + } else { + $xf debug-callframe { + puts " spoils $wlist and all aliases" + } + # The modified set is known. Spoil everything that + # may alias a modified variable. + foreach v $wlist { + dict unset avail $v + foreach a [$xf may-alias $v] { + $xf debug-callframe { + puts " including $a" + } + dict unset avail $a + } + } + $xf debug-callframe { + puts " preserves avail set\ + [dict keys $avail]" + } + } + } + set acf $cfout + } + } + + "moveFromCallFrame" { + + # If the thing we're pulling out of the callframe has a constant + # name and if the name has no namespace qualifiers, we can + # retain its value to do load-load and load-store optimizations. + # If we already have a value for it, we will eventually + # elide this load operation. + + lassign $q op result cfin vref + if {$acf ne $cfin} { + $xf debug-callframe { + puts "WHAT? callframe is $cfin, active is $acf" + } + $xf diagnostic warning $b $pc \ + "moveFromCallFrame other than the active callframe,\ + should not happen" + set avail {} + } elseif {[lindex $vref 0] eq "literal"} { + set v [lindex $vref 1] + if {![regexp "::" $v]} { + if {![dict exists $avail $v]} { + $xf debug-callframe { + puts " $v becomes available with\ + value $result" + } + dict set availEquiv $result $result + $xf debug-callframe { + puts " avail($v) - $result" + puts " availEquiv($result) - $result" + } + } else { + set source [dict get $avail $v] + $xf debug-callframe { + puts " Eventually, replace $result with a\ + copy from $source" + } + dict set eliminableLoad $result $source + dict set availEquiv $result \ + [dict get $availEquiv $source] + $xf debug-callframe { + puts " availEquiv($result) -\ + [dict get $availEquiv $result]" + } + } + dict set avail $v $result + + } + } + set acf $cfin + } + + "moveToCallFrame" { + + set pairs [lassign $q op cfout cfin] + if {$acf ne $cfin} { + $xf debug-callframe { + puts "WHAT? callframe is $cfin, active is $acf" + } + $xf diagnostic warning $b $pc \ + "moveToCallFrame other than the active callframe,\ + should not happen" + set avail {} + } else { + + # Walk through the values being stored. If we're storing + # into a slot with a literal, unqualified name, then + # spoil known values for all potential aliases, and + # make the new value of the named variable available. + # If the name is qualified, spoil anything that might + # alias a namespace variable. If the name is unknown, + # spoil everything, since any callframe var may have + # been overwritten. + foreach {vref val} $pairs { + lassign $vref kind v + if {$kind eq "literal"} { + # TODO: Make sure that may-alias works if $v + # is qualified. It should return all + # unqualified names that may alias a + # namespace var + foreach a [$xf may-alias $v] { + $xf debug-callframe { + puts " $a becomes unavailable because\ + it aliases $v" + } + dict unset avail $a + } + if {![regexp "::" $v]} { + + # LOAD-STORE - if we're putting into the + # callframe a value that's already there, + # there's no point. + + $xf debug-callframe { + puts " Is there a point to this?" + } + if {[dict exists $availEquiv $val] + && [dict exists $avail $v] + && ([dict get $availEquiv $val] + eq [dict get $availEquiv \ + [dict get $avail $v]])} { + $xf debug-callframe { + puts " setting $v to $val appears\ + pointless" + } + dict set pointlessStore $cfout $v {} + + } else { + + $xf debug-callframe { + puts " $v becomes available with\ + value $val" + } + dict set avail $v $val + dict set availEquiv $val $val + $xf debug-callframe { + puts " avail($v) = $val" + puts " availEquiv($val) = $val" + } + } + } + } else { + $xf debug-callframe { + puts " unknown var, spoil everything" + } + set avail {} + } + } + } + set acf $cfout + } + + "nsupvar" - "upvar" { + lassign $q op cfout cfin localname context remotename + set localname [lindex $localname 1] + dict unset avail $localname + $xf debug-callframe { + puts "$localname becomes unavailable" + } + foreach a [$xf may-alias $localname] { + $xf debug-callframe { + puts " $a becomes unavailable because\ + it aliases $localname" + } + dict unset avail $a + } + set acf $cfout + } + + "phi" { + + # If the phi is for the callframe, we will construct + # the available set from the sets for the preceding + # blocks. Defer this, however, until we've seen all the + # phi's, because we may be constructing speculative phi's + # for callframe variables, and we don't want to do that + # until we've seen all the phi's that we have already. + + set fromlist [lassign $q opcode result] + if {[$xf typeOfOperand [lindex $q 1]] & $CALLFRAME} { + set cfPhi $q + set avail {} + set acf $result + } else { + dict set phisSeen \ + [lsort -dictionary -stride 2 -index 0 $fromlist] \ + $result + } + } + + "startCatch" { + + # Entering a catch implicitly spoils errorInfo and errorCode. + # While it's pretty insane to alias these, someone probably + # does, so spoil the local aliases. + + foreach v [$xf local-aliases] { + $xf debug-callframe { + puts " $v becomes unavailable" + } + dict unset avail $v + } + set acf [lindex $q 1] + } + + "variable" { + lassign $q op cfout cfin localname remotename + set localname [lindex $localname 1] + dict unset avail $localname + $xf debug-callframe { + puts " $localname becomes unavailable" + } + foreach a [$xf may-alias $localname] { + $xf debug-callframe { + puts " $a becomes unavailable because\ + it aliases $localname" + } + dict unset avail $a + } + set acf $cfout + } + + default { + lassign $q opcode dest + if {$dest ne {} && [lindex $dest 0] in {"var" "temp"}} { + set dtype [$xf typeOfOperand $dest] + if {$dtype & $CALLFRAME} { + $xf diagnostic note $b $pc "Problem op: %s" $q + $xf diagnostic warning $b $pc \ + "I don't know the effect of %s on the callframe!" \ + $opcode + set acf [lindex $q 1] + set avail {} + } + } + } + } + + lappend newbb $q + } + + set changed 0 + if {$acf ne [lindex $activeCFOut $b]} { + set changed 1 + lset activeCFOut $b $acf + } + if {$avail ne [lindex $availOut $b]} { + set changed 1 + lset availOut $b $avail + } + set bb $newbb + + if {$changed} { + $xf debug-callframe { + puts " basic block $b has a different available set; we will" + puts " reschedule analysis of successors." + } + } + + return $changed + +} + +# quadcode::callFrameAnalysis method makeSpeculativePhis -- +# +# Determines the set of phi instructions to add speculatively in hopes +# of eliminating 'moveFromCallFrame' to retrieve their values after +# the phi. +# +# Parameters: +# cfPhi - The phi instruction at which two or more callframes meet +# phisSeen - A dictionary describing the other phi's in the basic block. +# Keys are canonicalized right-hand sides. Values are the +# left-hand sides. This dictionary is used to identify +# values that are already available. +# +# Return value: +# Returns a dictionary whose keys are the names of variables in the +# callframe and whose values are lists. If a value is a singleton list, +# it is the known value of the given variable. If a value is a list of +# two or more elements, it is the right-hand side of a phi instruction +# that should be inserted to make the given callframe variable available. +# +# This procedure works by examining each predecessor block in turn, looking +# at the available variables. For each variable seen, there are three cases. +# +# 1. The variable is unavailable in at least one predecessor. Do nothing. +# 2. The variable is available in all predecessors, and has the same value +# in all of them. Make that value available as the variable's value +# in the downstream context by adding it as a singleton to the output +# dictionary. +# 3. The variable is available in all predecessors, and has two or more +# different values. Construct the right-hand side of a phi instruction +# at which the predecessor values meet, and add that to the output +# dictionary. + +oo::define quadcode::callFrameAnalysis method makeSpeculativePhis {cfPhi + phisSeen} { + + set retval {} + set rest [lassign $cfPhi opcode result pred1 fromcf1] + set pred1 [lindex $pred1 1] + + # Consistency check: make sure we have the correct linkage of the + # active callframe. + + if {[lindex $activeCFOut $pred1] ne $fromcf1} { + return {} + } + foreach {pred2 fromcf2} $rest { + set pred2 [lindex $pred2 1] + if {[lindex $activeCFOut $pred2] ne $fromcf2} { + return {} + } + } + + # Accumulate the possible speculative phis. + + dict for {var val} [lindex $availOut $pred1] { + set avail {} + dict set avail [list bb $pred1] $val + set allsame 1 + foreach {pred2 fromcf2} $rest { + set pred2 [lindex $pred2 1] + if {![dict exists [lindex $availOut $pred2] $var]} { + unset -nocomplain avail + break + } else { + set val2 [dict get [lindex $availOut $pred2] $var] + if {$val2 ne $val} { + set allsame 0 + } + dict set avail [list bb $pred2] $val2 + } + } + if {[info exists avail]} { + if {$allsame} { + dict set retval $var [list $val] + } else { + set avail [lsort -dictionary -stride 2 -index 0 $avail] + if {[dict exists $phisSeen $avail]} { + set oldphi [dict get $phisSeen $avail] + dict set retval $var [list $oldphi] + } else { + dict set retval $var $avail + } + } + } + } + + return $retval + +} + +# quadcode::callFrameAnalysis method analyzeBackward -- +# +# Analyzes the callframe operations in quadcode in the retrograde +# direction. +# +# Results: +# Returns 1 if there are one or more opportunities to optimize, 0 +# otherwise. +# +# Side effects: +# Populates the 'liveIn' and 'deadStore' arrays. + +oo::define quadcode::callFrameAnalysis method analyzeBackward {} { + + # Find out what local variables we're managing + set q0 [lindex [$xf bbcontent] 0 0] + lassign $q0 op callframe varnames + if {[lindex $q0 0 0] ne "entry"} { + error "program does not begin with 'entry'" + } + set allvars [lindex $varnames 1] + + # Find out which among these variables are aliased + set aliases [$xf local-aliases] + + # Enumerate blocks in retrograde order, and invert the enumeration to + # give the precedence of each block. + # bbq is a priority queue of blocks awaiting analysis, in retrograde order. + # The queue entries are precedences, which can be then converted to block + # numbers by [lindex $order $precedence]. + + quadcode::numheap create [namespace current]::bbq + set order [$xf bbrorder] + set bbdirty {} + set prec [lrepeat [llength $order] -1] + set i -1 + foreach b $order { + lappend bbdirty 1 + set prc [incr i] + lset prec $b $prc + bbq add $prc + } + + # Analyze by processing elements from tail to head. + + while {![bbq empty]} { + set prc [bbq removeFirst] + set b [lindex $order $prc] + lset bbdirty $b 0 + $xf editBasicBlock bb $b { + set changed [my analyzeBackwardBB $b bb $allvars $aliases] + } + if {$changed} { + dict for {pred -} [$xf bbpred $b] { + $xf debug-callframe { + puts " ...schedule predecessor $pred" + } + if {![lindex $bbdirty $pred]} { + lset bbdirty $pred 1 + set prc [lindex $prec $pred] + bbq add $prc + } + } + } + } + + bbq destroy + + dict for {k v} $deadStore { + if {[dict size $v] == 0} { + dict unset deadStore $k + } + } + + $xf debug-callframe { + puts "callframe: stores that may be eliminated:" + dict for {k v} $deadStore { + puts " $k: [dict keys $v]" + } + } + + return [expr {[dict size $deadStore] > 0}] +} + +# quadcode::callFrameAnalysis method analyzeBackwardBB -- +# +# Analyzes a basic block in the retrograde direction. +# +# Parameters: +# b - Basic block number +# bbVar - Name of a variable in caller's scope that contains the +# basic block's instructions and may be modified during the +# analysis. +# vars - Complete set of callframe variables that are being tracked +# aliases - Set of callframe variables that may be aliases. +# +# Results: +# Returns 1 if anything has changed requiring predecessor blocks +# to be reexamined, or 0 if nothing has changed. +# +# This method updates the b'th entry of 'liveIn' to be a dictionary whose +# keys are the names of variables that are live on entry to a block, and +# adjusts 'deadLoad' for any loads in the block. + +oo::define quadcode::callFrameAnalysis method analyzeBackwardBB {b bbVar vars + aliases} { + upvar 1 $bbVar bb + namespace upvar ::quadcode::dataType CALLFRAME CALLFRAME + + $xf debug-callframe { + puts "callframe: [$xf full-name] backward analysis for block $b" + } + + # For each successor block, find the live variables on input. The + # live variables on output from this block will be the union of + # those live on input to the successors. + + set live {} + foreach s [$xf bbsucc $b $bb] { + set live [dict merge $live [lindex $liveIn $s]] + } + $xf debug-callframe { + puts " live set on exit: [dict keys $live]" + } + + # The analyzeForward pass has already checked the consistency + # of callframe linkage. + + # Pass through the instructions of this block from bottom to top, and + # update liveness. Mark any dead stores that are encountered. + + set pc [llength $bb] + while {$pc > 0} { + incr pc -1 + set q [lindex $bb $pc] + + $xf debug-callframe { + puts "$b:$pc: $q" + } + + switch -exact -- [lindex $q 0 0] { + + "return" { + + # On return from a procedure, the variables that are + # to be considered live are the ones that might alias + # variables out of scope. + + set live {} + foreach a $aliases { + $xf debug-callframe { + puts " live on exit: $a" + } + dict set live $a {} + } + + } + + "moveToCallFrame" { + + # On entry to 'moveToCallFrame', any variable that will + # be overwritten is not live. + set rest [lassign $q opcode cfout cfin] + foreach {var value} $rest { + if {[lindex $var 0] eq "literal"} { + set vname [lindex $var 1] + if {![dict exists $live $vname]} { + $xf debug-callframe { + puts " $vname appears to be a dead store" + } + dict set deadStore $cfout $vname {} + } else { + $xf debug-callframe { + puts " $vname appears to be a live store" + } + if {[dict exists $deadStore $cfout]} { + dict unset deadStore $cfout $vname + } + $xf debug-callframe { + puts " $vname not live above here" + } + dict unset live $vname + } + } + } + } + + "directAppend" - + "directArrayAppend" - + "directArrayExists" - + "directArrayGet" - + "directArrayLappend" - + "directArrayLappendList" - + "directArraySet" - + "directArrayUnset" - + "directExists" - + "directGet" - + "directIsArray" - + "directLappend" - + "directLappendList" - + "directMakeArray" - + "directSet" - + "directUnset" - + "moveFromCallFrame" { + + # On entry to an instruction that inspects the callframe, + # a variable that may be read must be live. All aliases must + # also be live. + + lassign $q opcode result cfin name + + if {[dict exists $eliminableLoad $result]} { + $xf debug-callframe { + puts " this instruction is being deleted" + } + } elseif {[lindex $name 0] ne "literal"} { + $xf debug-callframe { + puts " cannot determine variable being read, make\ + everything live" + } + foreach v $vars { + $xf debug-callframe { + puts " $v becomes live" + } + dict set live $v {} + } + } else { + set name [lindex $name 1] + if {[regexp :: $name]} { + $xf debug-callframe { + puts " variable is nonlocal, make aliases live" + } + foreach v $aliases { + $xf debug-callframe { + puts " $v becomes live" + } + dict set live $v {} + } + } else { + $xf debug-callframe { + puts " make $name live" + } + dict set live $name {} + foreach v [$xf may-alias $name] { + $xf debug-callframe { + puts " make potential alias $v live" + } + dict set live $v {} + } + } + } + } + + "invoke" - + "invokeExpanded" { + + set args [lassign $q opcode cfout cfin cmd] + set argtypes [lmap a $args {$xf typeOfOperand $a}] + lassign [$xf variablesUsedBy $q $argtypes] known vlist + if {!$known} { + $xf debug-callframe { + puts " variables used are not known,\ + make everything live" + } + foreach v $vars { + $xf debug-callframe { + puts " mark $v live" + } + dict set live $v {} + } + } else { + foreach v $vlist { + $xf debug-callframe { + puts " variable $v used by call, mark live" + } + dict set live $v {} + foreach a [$xf may-alias $v] { + $xf debug-callframe { + puts " $a is a potential alias, mark live" + } + dict set live $a {} + } + } + } + } + + "entry" - + "extractCallFrame" - + "nsupvar" - + "phi" - + "retrieveResult" - + "startCatch" - + "upvar" - + "variable" { + # It's not relevant what might be live on entry. + # THe rest of these instructions don't change the live set + } + + default { + + lassign $q opcode dest src1 + if {$src1 ne {} && [lindex $src1 0] in {"var" "temp"}} { + set stype [$xf typeOfOperand $src1] + if {$stype & $CALLFRAME} { + $xf diagnostic note $b $pc "Problem op: %s" $q + $xf diagnostic warning $b $pc \ + "I don't know the effect of %s on liveness" $opcode + foreach v $vars { + dict set live $v {} + } + } + } + } + } + } + + $xf debug-callframe { + puts " live set on entry: [dict keys $live]" + } + + set changed 0 + if {$live ne [lindex $liveIn $b]} { + lset liveIn $b $live + set changed 1 + } + + if {$changed} { + $xf debug-callframe { + puts " live set changed, reschedule analysis of predecessors" + } + } + + return $changed +} + +# quadcode::callFrameAnalysis method eliminate -- +# +# Eliminates redundant 'moveFromCallFrame' and 'moveToCallFrame' +# instructions by replacing them with copies. Eliminates any speculative +# phi instructions that were inserted unnecessarily. +# +# Results: +# None. +# +# Side effects: +# Deletes phi instructions from the quadcode and replaces +# unneeded loads with copies. + +oo::define quadcode::callFrameAnalysis method eliminate {} { + + set nbb [llength [$xf bbcontent]] + for {set b 0} {$b < $nbb} {incr b} { + $xf editBasicBlock bb $b { + + set newbb {} + + set pc -1 + foreach q $bb { + incr pc + + switch -exact -- [lindex $q 0 0] { + + "moveFromCallFrame" { + lassign $q opcode dest cfin + if {[dict exists $eliminableLoad $dest]} { + set source [dict get $eliminableLoad $dest] + my markSpecPhi $source + $xf removeUse $cfin $b + $xf addUse $source $b + set newq [list "copy" $dest $source] + $xf debug-callframe { + puts "$b:$pc: replace $q" + puts " with $newq" + } + lappend newbb $newq + } else { + $xf debug-callframe { + puts "$b:$pc: cannot eliminate $q" + } + lappend newbb $q + } + } + + "moveToCallFrame" { + set rhs [lassign $q opcode cfout cfin] + set newrhs {} + foreach {v source} $rhs { + + lassign $v kind name + set elim 0 + if {$kind ne "literal"} { + $xf debug-callframe { + puts "$b:$pc: cannot eliminate store,\ + target unknown" + } + } elseif {[dict exists $pointlessStore \ + $cfout $name]} { + $xf debug-callframe { + puts "$b:$pc: can eliminate, pointless" + } + set elim 1 + } elseif {[dict exists $deadStore $cfout $name]} { + $xf debug-callframe { + puts "$b:$pc: can eliminate, $name is dead" + } + set elim 1 + } + + if {$elim} { + $xf debug-callframe { + puts "$b:$pc: eliminate store to $name" + puts "$b:$pc: remove a use of $source" + } + $xf removeUse $source $b + } else { + lappend newrhs $v $source + } + } + if {$newrhs eq {}} { + set newq [list copy $cfout $cfin] + } else { + set newq [list $opcode $cfout $cfin {*}$newrhs] + } + $xf debug-callframe { + puts "$b:$pc replace $q" + puts " with $newq" + } + lappend newbb $newq + } + + default { + lappend newbb $q + } + + } + } + set bb $newbb + } + } + + for {set b 0} {$b < $nbb} {incr b} { + $xf editBasicBlock bb $b { + + set newbb {} + + set pc -1 + foreach q $bb { + incr pc + + switch -exact -- [lindex $q 0 0] { + + "phi" { + set pairs [lassign $q opcode dest] + if {[dict exists $specPhi $dest]} { + $xf debug-callframe { + puts "$b:$pc: remove speculative phi $dest" + } + $xf removeDef $dest + foreach {from source} $pairs { + $xf removeUse $source $b + } + } else { + lappend newbb $q + } + } + + default { + lappend newbb $q + } + } + } + set bb $newbb + } + } +} + +# quadcode::callFrameAnalysis method markSpecPhi -- +# +# When eliminating a load from the callframe, remove any phi +# instructions on which it depends from the 'specPhi' array so that +# they will be retained in the quadcode. +# +# Parameters: +# v - Output that might come from a speculative phi. +# +# Results: +# None. +# +# Side effects: +# The speculative phi, and any that it depends on, are removed. + +oo::define quadcode::callFrameAnalysis method markSpecPhi {v} { + + $xf debug-callframe { + puts "Check dependencies for $v" + } + if {[dict exists $specPhi $v]} { + $xf debug-callframe { + puts "Speculative phi $v is still required" + } + set deps [dict get $specPhi $v] + dict unset specPhi $v + dict for {frombb d} $deps { + my markSpecPhi $d + } + } + return +} + +# quadcode::callFrameAnalysis method activeCallFrameIn -- +# +# If a basic block has an active callframe on entry (that is, if the +# active callframe is the same on exit from all predecessors), locate it. +# +# Parameters: +# b - Basic block number +# +# Results: +# Returns the identity of the active callframe, or "" if it cannot be +# uniquely determined. + +oo::define quadcode::callFrameAnalysis method activeCallFrameIn {b} { + + set acf ""; # Return value + + set preds [$xf bbpred $b] + if {[dict size $preds] != 0} { + set firstTime 1 + dict for {p -} $preds { + set pcf [lindex $activeCFOut $p] + if {$firstTime} { + set acf $pcf + set firstTime 0 + } elseif {$pcf ne {}} { + if {$acf ne {} && $acf ne $pcf} { + set acf {} + break + } + } + } + } + + return $acf +} + +# quadcode::callFrameAnalysis method availVarsIn --- +# +# If a block's predecessors share a callframe, enumerate any variables +# that are available on all paths. +# +# Parameters: +# b - Basic block number +# acf - Active callframe on entry to block $b +# +# Results: +# Returns a dictionary whose keys are variable names and whose +# values are the values of variables in the callframe that are +# available in the same quadcode register on each path coming in. +# +# It is a precondition that each predecessor block have the same active +# callframe. +# +# If more than one predecessor has the variable available but +# the values are different, then there's a need for a speculative phi here. + +oo::define quadcode::callFrameAnalysis method availVarsIn {b acf} { + + set avars {} + + set preds [$xf bbpred $b] + set firstTime 1 + dict for {p -} $preds { + + if {$firstTime} { + set avars [lindex $availOut $p] + set firstTime 0 + } else { + set av2 [lindex $availOut $p] + dict for {v value} $avars { + if {![dict exists $av2 $v] + || [dict get $av2 $v] ne [dict get $avars $v]} { + dict unset avars $v + } + } + } + } + + return $avars +} + +# quadcode::transformer method callFrameFlow -- +# +# Performs data flow analysis and optimization on operations +# that affect the callframe. +# +# Parameters: +# None +# +# Results: +# Returns 1 if anything has changed, 0 otherwise +# +# Side effects: +# Rewrites code so as to eliminate redundancies among operations +# affecting the callframe. + +oo::define quadcode::transformer method callFrameFlow {} { + + my debug-callframe { + puts "Before callframe flow analysis for [my full-name]:" + foreach {v type} [lsort -dictionary -stride 2 -index 0 $types] { + puts "$v: [nameOfType $type]" + } + my dump-bb + } + + set did_something 0 + + set a [quadcode::callFrameAnalysis new [self]] + + # TODO - See doc/20190216callframe/callframe.md, tasks 2, 3, 4 + + # 1. Compute available values in the forward direction. + # (There will be other forward analysis to be done). + + if {[$a analyzeForward]} { + set did_something 1 + } + + # 2. Compute live stores in the backward direction. + # (There will be other retrograde analysis to be done.) + + if {[$a analyzeBackward]} { + set did_something 1 + } + + # 4. Clean up any speculative phi operations that were unneeded, + # replace any unneeded callframe loads and stores with copies. + $a eliminate + + # Note that the return should be 'true' if there has been code motion, + # if any inserted speculative phi has a use, or if any load has been + # eliminated. (And probably other reasons as I get farther into this). + # Inserting and removing a speculative phi doesn't count. + + my debug-callframe { + puts "After callframe flow analysis:" + my dump-bb + } + + $a destroy + + if {$did_something} { + my debug-callframe { + puts "The callframe analysis did something: reschedule code tidying" + } + } + + return $did_something + +} # quadcode::transformer method containsUpvar -- # # Quick and dirty approximation for whether a given procedure needs # to have variables in the caller's frame in sync. @@ -31,880 +1519,10 @@ return 1 } } return 0 } - -# quadcode::transformer method callframeMotion -- -# -# Adds callframe data motion for variables that may be links -# by virtue of appearing in 'nsupvar', 'upvar' or 'variable' -# opcodes, or that may be read or written by 'invoke' -# -# Results: -# None. -# -# Side effects: -# Adds the necessary instructions to keep the callframe in step -# with linked variables and with variables that may be used or -# set in invoked commands. -# -# This pass runs before SSA, so that it doesn't need to worry about -# variable renaming. It inserts a great many redundant data motions. -# 'cleanupCallFrameMotion' will take out some of them (at least any -# 'moveFromCallFrame' whose result is unused), but proper optmization -# will depend on global alias analysis, which we don't yet have. - -oo::define quadcode::transformer method callFrameMotion {} { - - my debug-callframe { - puts "Before callframeMotion:" - my dump-bb - puts "Links: $links" - } - - set catches {}; # Dictionary enumerating the places where - ; # errorInfo and errorCode must be spoilt - - # Walk through the basic blocks and insert any needed instructions - # before and after the blocks - - set b -1 - foreach bb $bbcontent { - incr b - set newbb {} - set pc -1 - foreach q $bb { - incr pc - my callFrameMovesBefore $b $pc newbb $q - lappend newbb $q - my callFrameMovesAfter $b $pc newbb $q - if {[lindex $q 0] eq "jumpMaybe"} { - dict set catches [lindex $q 1 1] {} - my debug-callframe { - puts " [lindex $q 1] appears to be a catch block" - } - } - } - lset bbcontent $b $newbb - } - - # Insert instructions to spoil ::errorCode and ::errorInfo after each - # catch. - - my debug-callframe { - puts "Clean up catch blocks:" - } - dict for {b -} $catches { - set newbb [list {startCatch {temp @callframe} {temp @callframe}}] - my debug-callframe { - puts "$b:0: [lindex $newbb 0]" - } - dict for {var -} $links { - set vname [lindex $var 1] - set newq [list moveFromCallFrame \ - $var {temp @callframe} \ - [list literal $vname]] - my debug-callframe { - puts "$b:[llength $newbb]: $newq" - } - lappend newbb $newq - } - set bb [lindex $bbcontent $b] - lset bbcontent $b {} - set bb [linsert $bb[set bb {}] 0 {*}$newbb] - lset bbcontent $b $bb - } - - my debug-callframe { - puts "After callframeMotion:" - my dump-bb - } -} - -# quadcode::transformer method callFrameMovesBefore -- -# -# Inserts any data motion to and from the callframe required before -# a given quadcode instruction. -# -# Parameters: -# b - Basic block number -# pc - Program counter within the block -# newbbv - Name of a variable in caller's scope accumulating the new -# instruction list for the block -# q - Instruction being analyzed. -# -# Results: -# None. -# -# Side effects: -# The code that is needed before $q is inserted. -# -# If an instruction is an 'invoke', then 'moveToCallFrame' is needed -# before it, with all purely local variables (those that do not appear -# in 'nsupvar', 'upvar', 'variable') listed. -# -# 'load' can be treated the same way as 'invoke'. In the worst -# case, we do not know what variables they read and write, and simply have -# to deal with whatever they do to the callframe. Once we've done copy -# propagation, we can deal with the common case where 'loadStk' and -# 'storeStk' are actually reading and writing namespace-qualified -# variables. -# -# Even though 'store' does not read variables, but only writes them, it -# still needs all the 'moveToCallFrame' operations as well. The reason -# is that if it is discovered that 'store' is storing to a predictable -# place, 'moveFromCallFrame' instructions need to be eliminated. -# In that case, we need the corresponding 'moveToCallFrame' operations -# so as to look up the reaching definition of the variable. -# -# The 'cleanupCallFrameMotion' pass will optimize away the variables -# that the 'invoke' or 'load' does not read, or that are not aliased -# to the variable that the 'store' might alter. It can also remove -# data motion involving (some of) the variables that do not need to be -# moved to the callframe because they are already there. This -# optimization may have the effect of killing 'moveFromCallFrame' -# instructions, which will be removed by the cleanup optimizations. - -oo::define quadcode::transformer method callFrameMovesBefore {b pc newbbv q} { - if {[lindex $q 0] in { - "directAppend" "directArrayAppend" "directArrayExists" "directArrayGet" - "directArrayLappend" "directArrayLappendList" "directArraySet" - "directArrayUnset" "directExists" "directGet" "directLappend" - "directLappendList" "directSet" "directUnset" "invoke" "invokeExpanded" - }} { - - # All variables are forced into the callframe before 'invoke', - # 'load' and 'store'. Variables that cannot be accessed are - # optimized away later. - - upvar 1 $newbbv newbb - set newq {moveToCallFrame {temp @callframe} {temp @callframe}} - foreach v $vars { - lappend newq [list literal [lindex $v 1]] $v - # TODO - Store-store optimization is needed, to detect that - # $v is already in the callframe - } - my debug-callframe { - puts " $newq" - puts "inserted before" - puts "$b:$pc: $q" - } - lappend newbb $newq - } -} - -# quadcode::transformer method callFrameMovesAfter -- -# -# Inserts any data motion to and from the callframe required after -# a given quadcode instruction. -# -# Parameters: -# b - Basic block number -# pc - Program counter within the block -# newbbv - Name of a variable in caller's scope accumulating the new -# instruction list for the block -# q - Instruction being analyzed. -# -# Results: -# None. -# -# Side effects: -# The code that is needed before $q is inserted. -# -# For an 'invoke', we need to insert moves from the callframe for all -# variables, both links and strictly local variables. (Links are included -# because we don't yet know what variables the invoked command may have -# written. and if any of them potentially have aliases, we need to move -# the aliases as well as the linked variables.) -# -# 'load' requires no postaction, since it cannot alter variables. -# 'store' may be treated similarly to 'invoke'. We can optimize later -# the common case where the name of the variable being loaded or -# stored is constant, once we've done copy propagation and know what -# the name is. -# -# For 'nsupvar', 'upvar' and 'variable', we need to insert a single -# move from the callframe to retrieve the initial value of the variable -# after creating the link. -# -# An instruction that assigns to a variable that may be a link must move -# the result to the callframe, and then move all linked variables from the -# callframe. (Alias analysis may be able to down-select what is moved here.) -# -# Many of these moves will be dead, and we depend on cleanup optimizations -# to get rid of them. - -oo::define quadcode::transformer method callFrameMovesAfter {b pc newbbv q} { - - upvar 1 $newbbv newbb - - switch -exact -- [lindex $q 0] { - - "invoke" - "invokeExpanded" - "nsupvar" - "upvar" - "variable" { - - # 'invoke', 'nsupvar', 'upvar', 'variable' are followed by - # 'extractCallFrame' and will be dealt with when the - # 'extractCallFrame' is encountered. - - } - - "extractCallFrame" { - - # Find the instruction that altered the callframe - - set sourceCF [lindex $q 2] - - set pc2 $pc - while {$pc2 > 0} { - incr pc2 -1 - set q2 [lindex $bbcontent $b $pc2] - if {[lindex $q2 1] eq $sourceCF} break - } - if {$pc2 < 0} { - error "cannot find source of callframe in $b:$pc: $q" - } - - switch -exact [lindex $q2 0] { - - "invoke" - "invokeExpanded" { - - # After 'invoke' or 'store', all variables are - # retrieved from the callframe. Variables that are - # not changed (either because an invoked proc - # doesn't reference them, or because they cannot - # alias the target of the 'store') are removed - # later. - - my debug-callframe { - puts "insert after" - puts "$b:$pc: $q" - puts " (origin: $b:$pc2: $q2)" - } - foreach v $vars { - set newq [list moveFromCallFrame $v [lindex $q 1] \ - [list literal [lindex $v 1]]] - my debug-callframe { - puts " $newq" - } - lappend newbb $newq - } - } - - "nsupvar" - "upvar" - "variable" { - - # After creating a new alias as a local variable, the - # value of the variable has to be retrieved from the - # callframe. - upvar 1 $newbbv newbb - my debug-callframe { - puts "insert after" - puts "$b:$pc: $q" - puts " (origin: $b:$pc2: $q2)" - } - set litname [lindex $q2 3] - set name [lindex $litname 1] - set newq [list moveFromCallFrame \ - [list var $name] [lindex $q 1] $litname] - my debug-callframe { - puts " $newq" - } - lappend newbb $newq - } - } - } - - "dictAppend" - "dictGet" - "dictIncr" - "dictIterStart" - - "dictLappend" - "dictSet" - "dictSize" - "dictUnset" - - "dictSetOrUnset" - - "div" - "expon" - "foreachStart" - - "initException" - - "listAppend" - "listConcat" - - "listIn" - "listIndex" - "listLength" - "listRange" - "listSet" - - "mod" - "not" - "originCmd" - "regexp" - - "strindex" - "strrange" - "strreplace" { - # These operations all return FAIL, and a subsequent - # 'extractMaybe' will be needed. The intermediate copy - # of the variable will not be moved to the frame. We wait - # for the 'extractMaybe' to move the actual value. - } - - default { - - # On any assignment, we move the result to the callframe, - # then move anything that the result might alias back from - # the callframe. We put a 'no op' in between so that code that - # tracks the callframe content can find the correct values. - - # On a direct assignment, we also need to recover anything - # that might alias the direct variable. - - set tgt [lindex $q 1] - set needMovesFrom 0 - if {[lindex $tgt 0] eq "var" - && [dict exists $links $tgt]} { - upvar 1 $newbbv newbb - my debug-callframe { - puts "insert after" - puts "$b:$pc: $q" - } - set vname [lindex $tgt 1] - set newq [list moveToCallFrame \ - {temp @callframe} {temp @callframe} \ - [list literal $vname] $tgt] - lappend newbb $newq - my debug-callframe { - puts " $newq" - } - set needMovesFrom 1 - } - if {[lindex $q 0] in { - "directAppend" "directArrayAppend" "directArrayLappend" - "directArrayLappendList" "directArraySet" "directArrayUnset" - "directLappend" "directLappendList" "directSet" "directUnset" - }} { - unset -nocomplain vname - set tgt Nothing - set needMovesFrom 1 - } - - if {$needMovesFrom} { - if {[info exists vname]} { - set nopArg [list literal $vname] - } else { - set nopArg Nothing - } - set newq2 [list callFrameNop \ - {temp @callframe} {temp @callframe} $nopArg] - my debug-callframe { - puts " $newq2" - } - lappend newbb $newq2 - dict for {var -} $links { - if {$tgt ne $var} { - set vname [lindex $var 1] - set newq [list moveFromCallFrame \ - $var {temp @callframe} \ - [list literal $vname]] - my debug-callframe { - puts " $newq" - } - lappend newbb $newq - } - } - } - } - } -} - -# quadcode::transformer method cleanupMoveFromCallFrame -- -# -# Removes and replaces 'moveFromCallFrame' where it is known that -# a target procedure does not write a callframe variable -# -# Results: -# Returns 1 if any code was changed by this method, 0 otherwise -# -# Side effects: -# The 'moveFromCallFrame' instruction is deleted, and its -# result is replaced with the operand on the corresponding -# 'moveToCallFrame', if the operation is known not to write -# the variable. -# -# FIXME: This procedure needs to be updated to deal with namespace variables. -# 'moveFromCallFrame' may have been inserted after a quad has assigned -# to a potentially aliased variable, rather than after an 'invoke' - -oo::define quadcode::transformer method cleanupMoveFromCallFrame {} { - - my debug-callframe { - puts "before cleanupMoveFromCallFrame:" - my dump-bb - } - - # $vw will hold a dictionary whose keys are quadcode instructions - # and whose values are the lists of variables that the - # corresponding instructions might store in the callframe. - - set vw {} - - # Walk through the quadcode looking for 'moveFromCallFrame' - - set changed 0 - - for {set b 0} {$b < [llength $bbcontent]} {incr b} { - set outpc -1 - for {set pc 0} {$pc < [llength [lindex $bbcontent $b]]} {incr pc} { - set q [lindex $bbcontent $b $pc] - if {[lindex $q 0] ne "moveFromCallFrame"} { - lset bbcontent $b [incr outpc] $q - continue - } - my debug-callframe { - puts "Examine $b:$pc: $q" - } - - # Found 'moveFromCallFrame'. Make sure the variable name is literal - lassign $q opcode tovar fromcf var - if {[lindex $var 0] ne "literal"} { - my debug-callframe { - puts " variable name not literal, can't optimize." - } - lset bbcontent $b [incr outpc] $q - continue - } - set vname [lindex $var 1] - - # Find the instruction that produced the callframe - set producer [my cfProducer [lindex $q 2]] - my debug-callframe { - puts " produced by: $producer" - } - - # Find out what variables that the producer potentially changes - if {![dict exists $vw $producer]} { - - switch -exact [lindex $producer 0] { - - "nsupvar" - "variable" - "upvar" { - - # The producer created a new link. The result variable - # was 'written' - - dict set vw $producer \ - [list 1 [list [lindex $producer 3]]] - } - - callFrameNop { - - # If the producer is 'callframeNop', then the - # potential change happened because a potentially - # aliased variable was moved to the callframe. - # The affected variables are its potential aliases - - if {[lindex $producer 3 0] eq "literal"} { - dict set vw $producer \ - [list 1 [my may-alias [lindex $producer 3]]] - } else { - dict set vw $producer {0 {}} - } - } - - startCatch { - - # When catching an error, resynchronize to make sure - # that errorCode and errorInfo are up to date. - # Our ultraconservative alias analysis has no - # real way of handling this, so simply spoil everything - - dict set vw $producer [list 1 [dict keys $links]] - } - - "invoke" - "invokeExpanded" { - - # The variables altered by the 'invoke', plus - # all aliases, are potentially changed. - - set aliases {} - set atypes [lmap x [lrange $producer 4 end] { - typeOfOperand $types $x - }] - lassign [my variablesProducedBy $producer $atypes] \ - known wlist - if {$known} { - foreach v $wlist { - dict set aliases $v {} - foreach a [my may-alias $v] { - dict set aliases $a {} - } - } - dict set vw $producer \ - [list 1 [dict keys $aliases]] - } else { - dict set vw $producer {0 {}} - } - } - } - } - - lassign [dict get $vw $producer] known vlist - my debug-callframe { - if {$known} { - puts " which writes variable(s) [list $vlist]" - } else { - puts " which potentially writes any variable" - } - } - - # Is this variable written by the operation? - if {!$known || $vname in $vlist} { - my debug-callframe { - puts " which might include $vname, so can't remove quad" - } - lset bbcontent $b [incr outpc] $q - continue - } - my debug-callframe { - puts " which does not include $vname" - } - - # This variable is known not to be written by the invocation. - # Trace its data source - set source [my cfPreviousDataSource $var $producer] - if {$source eq ""} { - my debug-callframe { - puts " $vname has an unknown source, can't optimize" - } - lset bbcontent $b [incr outpc] $q - continue - } - - my debug-callframe { - puts " replace uses of $tovar with $source, delete quad" - } - my removeUse $fromcf $b - my replaceUses $tovar $source - dict unset duchain $tovar - set changed 1 - - } - - # Truncate the basic block to its new length - - set bb [lindex $bbcontent $b] - if {[incr outpc] < [llength $bb]} { - lset bbcontent $b {} - set bb [lreplace $bb[set bb {}] $outpc end] - lset bbcontent $b $bb - } - set bb {} - } - - my debug-callframe { - puts "after cleanupMoveFromCallFrame:" - my dump-bb - } - - return $changed -} - -# quadcode::transformer method cleanupMoveToCallFrame -- -# -# Removes and replaces 'moveToCallFrame' where it is known that -# a target procedure does not access a callframe variable -# -# Results: -# Returns 1 if any code was changed by this method, 0 otherwise -# -# Side effects: -# -# If the operation is known neither to read nor to write a given -# variable, then it is safe to remove that variable from the -# 'moveToCallFrame' instruction. It is also safe to do so if the -# variable was just produced by a 'moveFromCallFrame' and the -# input callframe of the 'moveFromCallFrame' and that of the -# 'moveToCallFrame' are the same frame. If these deletions cause -# all the variables to be deleted from the instruction, then the -# instruction itself is deleted, and references to the output -# callframe are replaced by references to the input callframe. -# -# TODO: Also, we can safely remove moveToCallFrame if the value that -# we are moving was just moved from the same callframe under -# the same name. -# -# TODO: Can we track back further, by noting that some operations -# modify only specific callframe slots? - -oo::define quadcode::transformer method cleanupMoveToCallFrame {} { - - my debug-callframe { - puts "before cleanupMoveToCallFrame:" - my dump-bb - } - - # Walk through the quadcode looking for 'moveToCallFrame' - - set changed 0 - - for {set b 0} {$b < [llength $bbcontent]} {incr b} { - set outpc -1 - for {set pc 0} {$pc < [llength [lindex $bbcontent $b]]} {incr pc} { - set q [lindex $bbcontent $b $pc] - if {[lindex $q 0] ne "moveToCallFrame"} { - lset bbcontent $b [incr outpc] $q - continue - } - my debug-callframe { - puts "Examine $b:$pc: $q" - } - - set opdlist [lassign $q opcode cfout cfin] - - # Find the instruction that consumes the callframe - set consumer [my cfConsumer $cfout] - my debug-callframe { - puts " consumed by: $consumer" - } - - if {[lindex $consumer 0] in {"callFrameNop" "startCatch"}} { - # The 'callFrameNop' is there because it needs explicitly to - # consume the linked variable. Don't touch! - my debug-callframe { - puts " which is there to sync a linked variable,\ - don't touch!" - } - lset bbcontent $b [incr outpc] $q - continue - } - - # Determine argument types of the consuming call, which always - # begins with some output and a callframe input - set atypes [lmap x [lrange $consumer 4 end] { - typeOfOperand $types $x - }] - - # Find out what variables that the consumer potentially reads. - # Because potentially changed variables may also be unchanged, - # list them also. - - set known 1 - set vdict {} - lassign [my variablesUsedBy $consumer $atypes] flag vlist - if {!$flag} { - set known 0 - } else { - foreach v $vlist { - dict set vdict $v {} - } - } - lassign [my variablesProducedBy $consumer $atypes] flag vlist - if {!$flag} { - set known 0 - } else { - foreach v $vlist { - dict set vdict $v {} - } - } - - my debug-callframe { - if {$known} { - puts " which accesses variable(s)\ - [list [dict keys $vdict]]" - } else { - puts " which potentially accesses any variable" - } - } - - # Make sure that any variables that the callee is known to - # access, that are not otherwise listed in the callframe, - # get listed. - if {[lindex $bbcontent 0 0 0] eq "entry"} { - set vars [lindex $bbcontent 0 0 2 1] - dict for {v -} $vdict { - if {[lsearch -exact $vars $v] < 0} { - my debug-callframe { - puts " add pass-by-name variable $v to callframe" - } - lappend vars $v - lset bbcontent 0 0 2 1 $vars - } - } - } - - set ok 1 - set newq [list $opcode $cfout $cfin] - foreach {vnamelit var} $opdlist { - lassign $vnamelit l vname - if {$l ne "literal"} { - my debug-callframe { - puts " $vnamelit is not a literal, can't optimize" - } - set ok 0 - break - } - if {[lindex $var 0] in {"temp" "var"}} { - lassign [my findDef $var] defb defpc defq - lassign $defq defopc defvar defcf defname - } else { - set defopc "entry" - } - if {$defopc eq "moveFromCallFrame" - && $defvar eq $var - && $defcf eq $cfin - && [lindex $defname 1] eq $vname} { - my debug-callframe { - puts " $vname just came out of $cfin and\ - doesn't need to go back in." - } - my removeUse $var $b - set changed 1 - } elseif {$known && ![dict exists $vdict $vname]} { - my debug-callframe { - puts " consumer doesn't access $vname, so\ - don't put it in the callframe" - } - my removeUse $var $b - set changed 1 - } else { - my debug-callframe { - puts " consumer accesses $vname and it's not there" - } - lappend newq $vnamelit $var - } - } - - if {!$ok} { - my debug-callframe { - puts " optimization suppressed" - } - lset bbcontent $b [incr outpc] $q - } elseif {[llength $newq] eq 3} { - my debug-callframe { - puts " no variables to move, delete this quad\ - and replace $cfout with $cfin" - } - my replaceUses $cfout $cfin - my removeUse $cfin $b - dict unset duchain $cfout - } else { - my debug-callframe { - puts " new quad: $newq" - } - lset bbcontent $b [incr outpc] $newq - } - } - - # Truncate the basic block to its new length - - set bb [lindex $bbcontent $b] - if {[incr outpc] < [llength $bb]} { - lset bbcontent $b {} - set bb [lreplace $bb[set bb {}] $outpc end] - lset bbcontent $b $bb - } - set bb {} - } - - my debug-callframe { - puts "after cleanupMoveToCallFrame:" - my dump-bb - } - - return $changed -} - -# quadcode::transformer method cfConsumer -- -# -# Determines what 'invoke' or other operation consumes a callframe -# that appears in a 'moveToCallframe' operation -# -# Parameters: -# frame - Callframe variable -# -# Results: -# Returns the quadcode operation that uses the callframe in question. -# Allows for multiple 'moveToCallFrame' operations to accumulate -# values before the final use. Returns the empty string if a unique -# use cannot be determined. - -oo::define quadcode::transformer method cfConsumer {frame} { - my variable bbcontent - set qs [my allUses $frame] - if {[llength $qs] != 3} { - return {} - } - lassign $qs b pc indx - set q [lindex $bbcontent $b $pc] - if {[lindex $q 0 0] eq "moveToCallFrame"} { - tailcall my cfConsumer [lindex $q 1] - } - return $q -} - -# quadcode::transformer method cfProducer -- -# -# Locates the basic block where a given callframe originated. -# -# Parameters: -# frame - Callframe variable -# -# Results: -# Returns the quadcode instruction that produced the frame. - -oo::define quadcode::transformer method cfProducer {frame} { - lassign [my findDef $frame] bb pc q - while {[lindex $q 0] eq "extractCallFrame"} { - set frame [lindex $q 2] - lassign [my findDef $frame] bb pc q - } - return $q -} - -# quadcode::transformer method cfPreviousDataSource -- -# -# Determine the previous origin of a callframe variable if we -# have decided that a given quadcode instruction does not set it. -# -# Parameters: -# vn - Name of a callframe variable -# producer - Quadcode that does not write to the variable. -# -# Results: -# Returns a quadcode reference to the value of the variable in the -# callframe before 'producer' executes. - -oo::define quadcode::transformer method cfPreviousDataSource {vn producer} { - - # What was the previous value of the callframe? - set frame [lindex $producer 2] - - # What was the instruction that produced that frame? - lassign [my findDef $frame] b pc q - if {[lindex $q 0 0] ne "moveToCallFrame"} { - # Can't find a data source - return {} - } - - foreach {vn2 val} [lrange $q 3 end] { - if {$vn2 eq $vn} { - return $val - } - } - - tailcall my cfPreviousDataSource $vn $q -} - -# quadcode::transformer method cfAlreadyInCallFrame -- -# -# Determines whether a given value for a callframe variable -# is already in the frame. -# -# Parameters: -# vn - Name of the source variable -# val - Name of the value being stored into the frame -# frame - Name of the callframe that's receiving the value -# -# Results: -# Returns 1 if the value can be proven already to be in the frame -# (generally, because we just took it out of there), 0 otherwise. - -oo::define quadcode::transformer method cfAlreadyInCallFrame {vn val frame} { - - if {[lindex $val 0] ni {"temp" "var"}} { - # TODO - Move of Nothing can be eliminated if the target frame - # is the entry frame. - return 0 - } else { - lassign [my findDef $val] defBlock defPC defQ - if {[lindex $defQ 0] eq "moveFromCallFrame" - && [lindex $defQ 2] eq $frame} { - return 1 - } else { - return 0 - } - } -} # quadcode::transformer method cleanupCallFrameUse -- # # Determines what operations that produce callframes may have # the associated callframes eliminated entirely. @@ -1043,10 +1661,64 @@ puts "After cleanupCallFrameUse:" my dump-bb } return $changed } + +# quadcode::transformer method removeCallFrameNop -- +# +# Removes all instructions that mark callframe actions but +# generate no code, once their use for alias analysis is complete. +# +# Results: +# None. + +oo::define quadcode::transformer method removeCallFrameNop {} { + + my debug-callframe { + puts "Before removeCallFrameNop:" + my dump-bb + } + + for {set b 0} {$b < [llength $bbcontent]} {incr b} { + + set outpc 0 + set bl [llength [lindex $bbcontent $b]] + for {set pc 0} {$pc < $bl} {incr pc} { + + set q [lindex $bbcontent $b $pc] + if {[lindex $q 0] in {"startCatch"}} { + my debug-callframe { + puts "Remove $b:$pc: $q" + } + set cfout [lindex $q 1] + set cfin [lindex $q 2] + my replaceUses $cfout $cfin + dict unset udchain $cfout + my removeUse $cfin $b + } else { + lset bbcontent $b $outpc $q + incr outpc + } + } + + set bb [lindex $bbcontent $b] + if {$outpc < [llength $bb]} { + lset bbcontent $b {} + set bb [lreplace $bb[set bb {}] $outpc end] + lset bbcontent $b $bb + } + } + + my debug-callframe { + puts "After removeCallFrameNop:" + my dump-bb + } + + return +} + # quadcode::transformer method eliminateCallFrame -- # # Eliminates callframe operations on entry and return if nothing # else in a quadcode sequence uses the callframe @@ -1066,10 +1738,11 @@ oo::define quadcode::transformer method eliminateCallFrame {} { my debug-callframe { puts "Check whether callframe can be removed entirely from\ ${originProc}([lmap t $ptype {nameOfType $t}])" + my dump-bb } # The entry operation is block 0, pc 0, and its output callframe # is arg 1 @@ -1115,63 +1788,10 @@ my debug-callframe { my dump-bb } } - return -} - -# quadcode::transformer method removeCallFrameNop -- -# -# Removes all callframeNop instruction once their use for -# alias analysis is complete. -# -# Results: -# None. - -oo::define quadcode::transformer method removeCallFrameNop {} { - - my debug-callframe { - puts "Before removeCallFrameNop:" - my dump-bb - } - - for {set b 0} {$b < [llength $bbcontent]} {incr b} { - - set outpc 0 - set bl [llength [lindex $bbcontent $b]] - for {set pc 0} {$pc < $bl} {incr pc} { - - set q [lindex $bbcontent $b $pc] - if {[lindex $q 0] in {"callFrameNop" "startCatch"}} { - my debug-callframe { - puts "Remove $b:$pc: $q" - } - set cfout [lindex $q 1] - set cfin [lindex $q 2] - my replaceUses $cfout $cfin - dict unset udchain $cfout - my removeUse $cfin $b - } else { - lset bbcontent $b $outpc $q - incr outpc - } - } - - set bb [lindex $bbcontent $b] - if {$outpc < [llength $bb]} { - lset bbcontent $b {} - set bb [lreplace $bb[set bb {}] $outpc end] - lset bbcontent $b $bb - } - } - - my debug-callframe { - puts "After removeCallFrameNop:" - my dump-bb - } - return } # quadcode::transformer method variablesUsedBy -- # Index: quadcode/constfold.tcl ================================================================== --- quadcode/constfold.tcl +++ quadcode/constfold.tcl @@ -91,10 +91,14 @@ set changed 1 continue; # delete the quad } "arrayExists" { + + # arrayExists tests for the actual existence of an + # array + my debug-constfold { puts "$b:$pc: examine $q" } # What type do I want? @@ -736,10 +740,10 @@ lset bbcontent $b {} lset bbcontent $b [lrange $bb[set bb ""] 0 $newpc] } my debug-constfold { -# puts "After constfold:" -# my dump-bb + puts "After constfold:" + my dump-bb } return $changed } Index: quadcode/copyprop.tcl ================================================================== --- quadcode/copyprop.tcl +++ quadcode/copyprop.tcl @@ -45,10 +45,19 @@ if {[lindex $q 0] eq "copy"} { my debug-copyprop { puts "$b:$pc: $q" } lassign $q - to from + + # Is this copy actually an unset + if {[lindex $from 0] eq "Nothing"} { + my debug-copyprop { + puts "$b:$pc: $q - replace with unset" + } + set q [list unset $to] + set changed 1 + } # Is this copy killable? if {[lindex $to 0] eq "temp" || [lrange $from 0 1] eq [lrange $to 0 1]} { # Kill a copy Index: quadcode/dbginfo.tcl ================================================================== --- quadcode/dbginfo.tcl +++ quadcode/dbginfo.tcl @@ -52,19 +52,22 @@ } else { # Advance to the dominating block if no debug information # in the current block - set b [lindex $bbidom $b] - if {$b >= 0} { + if {$b > 0} { + set b [lindex $bbidom $b] set pc [llength [lindex $bbcontent $b]] } else { if {![info exists debugLines]} { set debugLines {0 0} } if {![info exists debugScript]} { set debugScript {} + } + if {![info exists debugContext]} { + set debugContext {} } break } } Index: quadcode/duchain.tcl ================================================================== --- quadcode/duchain.tcl +++ quadcode/duchain.tcl @@ -103,11 +103,38 @@ } } } } } - + + # addDef -- + # + # Updates ud-chain to define a variable + # + # Parameters: + # var - Variable whose definition is being added. + # b - Basic block containing the added use. + # + # Results: + # None. + + method addDef {var b} { + dict set udchain $var $b + return + } + + # removeDef -- + # + # Updates ud-chains to remove the definition of a variable + # + # Parameters: + # var - Variable to remove + + method removeDef {var} { + dict unset udchain $var + } + # addUse -- # # Updates du-chains to add a use to a variable # # Parameters: @@ -426,11 +453,11 @@ } } set bb [lindex $bbcontent $b] lset bbcontent $b {} - lset bbcontent $b [linsert $bb[unset -nocomplain bb] $pc $q] + lset bbcontent $b [linsert $bb[set bb {}] $pc $q] return } # quadcode::transformer method audit-duchain -- # DELETED quadcode/exists.tcl Index: quadcode/exists.tcl ================================================================== --- quadcode/exists.tcl +++ /dev/null @@ -1,382 +0,0 @@ -# exists.tcl -- -# -# Methods that optimize checks for variable existence in quadcode. -# -# Copyright (c) 2015 by Kevin B. Kenny -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -#------------------------------------------------------------------------------ - -# This file contains several passes over the quadcode to optimize checks -# for variable existence. The bytecode translator emits an existence check -# for every reference to a named variable, and the methods in this file -# are responsible for removing the checks when it can be proven that the -# variable in question always exists or never exists. -# -# The first pass in this file, 'existsPeephole', is a simple peephole -# check for a conditional jump that depends on the result of an 'exists' -# test in the same basic block. 'extractExists' and 'unset' are inserted -# on the 'true' and 'false' paths of the conditional jump, so that -# downstream code will see the already-determined facts of variable existence. -# -# There are two more complex passes in this file, both of which require that -# the program be in SSA form, with the basic blocks ordered in depth -# first numbering, and with ud- and du-chains on the variables. -# -# bbVarsExist - Operates on the basic blocks and sets the 'varExists' -# variable to a dictionary whose keys are variable names -# and whose values are numeric codes. The interpretation -# of the codes is: -# 0 - The existence of the variable has not been evaluated -# because its uses are unreachable. -# 1 - The variable exists -# 2 - The variable does not exist -# 3 - The variable exists on at least one code path and -# does not exist on another code path. -# doExists - Using the information from 'bbVarsExist', this pass simplifies -# the code. The following instructions are operated on: -# exists - If the variable is known to exist, the instruction -# is removed and its result replaced with the literal 1. -# If the variable is known not to exist, the instruction -# is removed and its result replaced with the literal 1. -# extractExists - The instruction is removed if the variable -# is known to exist, and its result is replaced -# with the literal 1. If the variable is known -# not to exist, a placeholder is inserted. -# (In this case, if there are no bugs in the -# earlier passes, an earlier simplification has -# made this code unreachable. -# initIfNotExists - The instruction is removed if the variable -# is known to exist, and its output is replaced -# by the value of the variable being checked. -# If the variable is known not to exist, the -# instruction is removed and the output replaced -# by the default value. -# -# This optimization may leave conditional jumps that depend on literals, -# unreachable code or unused variables, which will be cleaned up in later -# passes. - -oo::define quadcode::transformer { - - # existsPeephole -- - # - # Simple peephole optimization for code guarded by [info exists], - # - # Preconditions: - # This method must run after critical edges in the flow graph are split, - # but before conversion to SSA form. (It can't run after conversion, - # because in SSA form it would have to split variables.) - # - # Results: - # None. - # - # Side effects: - # Inserts 'extractExists' and 'unset' on the true and false branches - # of 'exists' checks. - # - # This pass runs before the conversion of quadcode to SSA form. It - # inspects basic blocks to find ones ending with a conditional that depends - # directly on 'exists' within the block. It inserts 'extractExists' and - # 'unset' on the two exits of the block. This has the effect, once - # the SSA representation is formed, of allowing all 'exists,' - # 'initIfNotExists,' and so on to be optimized away in code that depends - # on the condition. - - method existsPeephole {} { - my debug-existsPeephole { - puts "before 'exists' peephole:" - my dump-bb - } - - # Walk all the basic blocks looking for a 'jumpTrue' or 'jumpFalse' - # that depends on 'exists' - set b -1 - foreach content $bbcontent { - incr b - - # This optimization applies only to two-exit blocks. Work out - # what are the 'true' and 'false' branches - if {[lindex $content end 0] ne "jump"} continue - switch -exact [lindex $content end-1 0] { - "jumpTrue" { - set trueBranch [lindex $content end-1 1 1] - set resultVar [lindex $content end-1 2] - set falseBranch [lindex $content end 1 1] - } - "jumpFalse" { - set falseBranch [lindex $content end-1 1 1] - set resultVar [lindex $content end-1 2] - set trueBranch [lindex $content end 1 1] - } - default { - # Single-exit blocks are not suitable for this - # transformation - continue - } - } - - # Look to see if "exists" flows into the conditional branch - set peephole 0 - set pc -1 - foreach q $content { - incr pc - if {[lindex $q 0] eq "exists" && [lindex $q 1] eq $resultVar} { - - # This instruction makes the jump a possible candidate - # for [info exists] optimization - set peephole 1 - set testedVar [lindex $q 2] - - } elseif {$peephole} { - - # Spoil the peephole optimization if either of the - # two variables is reassigned on the way to the - # conditional jump. - set v [lindex $q 1] - if {$v eq $resultVar || $v eq $testedVar} { - set peephole 0 - } - - } - } - if {$peephole} { - set trueBlock [lindex $bbcontent $trueBranch] - lset bbcontent $trueBranch \ - [linsert $trueBlock 0 \ - [list extractExists $testedVar $testedVar]] - set falseBlock [lindex $bbcontent $falseBranch] - lset bbcontent $falseBranch \ - [linsert $falseBlock 0 [list unset $testedVar]] - } - } - my debug-existsPeephole { - puts "after 'exists' peephole:" - my dump-bb - } - } - - # bbVarsExist -- - # - # Determines what variables exist in the program, given a basic - # block representation in SSA form - # - # Results: - # None - # - # Side effects: - # Sets varExists to a dictionary whose keys are variable names and - # whose values are 1, 2 if it does not exist, 3 if it is unknown. - - method bbVarsExist {} { - dict set varExists Nothing 2 - - # Process the basic blocks in depth-first numbering so that - # assignments tend to happen before uses. - set changed 1 - while {$changed} { - set changed 0 - set b -1 - foreach content $bbcontent { - incr b - - # Walk through all the quads and adjust what they assign - - foreach q $content { - switch -exact -- [lindex $q 0] { - "phi" { - - # A phi inherits "exists" and "does not exist" - # flags from all its sources - set val 0 - foreach {from source} [lrange $q 2 end] { - switch -exact -- [lindex $source 0] { - "var" - "temp" { - if {[dict exists $varExists $source]} { - set sourceExists \ - [dict get $varExists $source] - } else { - set sourceExists 0 - } - } - "literal" { - set sourceExists 1 - } - "Nothing" { - set sourceExists 2 - } - "default" { - error "Why is there $source on a phi?" - } - } - set val [expr {$val | $sourceExists}] - } - } - "unset" { - - # The result of an "unset" does not exist - # Note that the SSA transformation should have - # removed all 'unset' operations, but it's - # still safe to look for them here. - set val 2 - } - default { - - # The result of anything else does exist - set val 1 - } - } - - # Update the destination variable - set v [lindex $q 1] - if {[lindex $v 0] in {"var" "temp"} - && (![dict exists $varExists $v] - || $val != [dict get $varExists $v])} { - set changed 1 - dict set varExists $v $val - } - } - } - } - - return - } - - # doExists -- - # - # Improves quadcode by simplifying instructions that depend on - # variable existence when the fact of variable existence is known - # statically. - # - # Preconditions: - # Quadcode must be in SSA form and free of critical edges. - # ud- and du-chains must exist, and 'bbVarsExist' must have been - # run to determine variable existence. - # - # Results: - # None. - # - # Side effects: - # Simplifies quadcode. - # Updates bbcontent, bbpred, udchain, and duchain to reflect the - # modifications. - - method doExists {} { - - my debug-doExists { - puts "before doExists:" - my dump-bb - } - - # Walk through all the instructions. It is tempting to do this all - # with [foreach] loops, but we need to see changes as they are made. - - for {set b 0} {$b < [llength $bbcontent]} {incr b} { - set j 0 - for {set i 0} {$i < [llength [lindex $bbcontent $b]]} {incr i} { - set q [lindex $bbcontent $b $i] - - # Identify the destination and source operands, and - # determine whether the source exists. - - set dest [lindex $q 1] - set source [lindex $q 2] - switch -exact -- [lindex $source 0] { - "var" - "temp" { - set ex [dict get $varExists $source] - } - "literal" { - set ex 1; # Literals always exist - } - "Nothing" { - set ex 2; # Nothing never exists - } - default { - set ex 0; # Everything else is unexamined - } - } - # Other instructions that manage non-existent variables: - # unset - Removed by the SSA processing before we get here - switch -exact [lindex $q 0] { - "exists" { - - # [info exists] turns into literal 1 if the - # variable always exists, or literal 0 if it never - # exists. - - if {$ex == 1} { - my removeUse $source $b - my replaceUses $dest {literal 1} - # delete the quad - } elseif {$ex == 2} { - my removeUse $source $b - my replaceUses $dest {literal 0} - # delete the quad - } else { - lset bbcontent $b $j $q - incr j - } - } - "extractExists" { - - # 'extractExists' can be removed if the variable - # always exists, and is misplaced if it never exists - - if {$ex == 1} { - my removeUse $source $b - my replaceUses $dest $source - # delete the quad - } else { - lset bbcontent $b $j $q - incr j - } - } - "initIfNotExists" { - - # 'initIfNotExists' has a value equal to the - # variable if the variable always exists, or - # to the default if it never exists - - if {$ex == 1} { - my removeUse $source $b - my removeUse [lindex $q 3] $b - my replaceUses $dest $source - # delete the quad - } elseif {$ex == 2} { - my removeUse $source $b - my removeUse [lindex $q 3] $b - my replaceUses $dest [lindex $q 3] - # delete the quad - } else { - lset bbcontent $b $j $q - incr j - } - } - default { - - # Other instructions are not changed by - # [info exists] information - - lset bbcontent $b $j $q - incr j - } - } - } - - if {$j < $i} { - set content [lindex $bbcontent $b] - lset bbcontent $b {} - lset bbcontent $b [lreplace $content[set content {}] $j end] - } - } - - my debug-doExists { - puts "After removing redundant existence checks:" - my dump-bb - } - - return - } -} DELETED quadcode/invoke.tcl Index: quadcode/invoke.tcl ================================================================== --- quadcode/invoke.tcl +++ /dev/null @@ -1,239 +0,0 @@ -# invoke.tcl -- -# -# Utilities for manipulating invocation sequences in quadcode. -# -# Copyright (c) 2018 by Kevin B. Kenny. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -#------------------------------------------------------------------------------ - -# quadcode::invocationSequence -- -# -# Class that represents the data for invoking a procedure. -# -# A quadcode::invocationSequence represents the codeburst that invokes -# a procedure, from the 'moveToCallFrame' that synchronizes the call frame -# prior to the invocation, down to the 'jumpMaybe' and 'jump' that handle -# a possible error return from the procedure. Procedure inlining and -# 'invokeExpand' repacement are two operations that need to rewrite the -# entire sequence, rather than just the 'invoke' instruction itself. -# This class abstracts the data from the codeburst. - -oo::class create quadcode::invocationSequence { - - # xfmr - quadcode::transformer object holding the bytecode - # b - Basic block number of the 'invoke' instruction - # pc - Program counter within the basic block - # pc0 - Program counter of the start of the invocation sequence. $pc0 <= $pc - # q - The 'invoke' instruction itself - # cmd - The command being invoked - # argl - The arglist from the 'invoke' instruction - # cfin - The callframe that flows into the invocation sequence, or Nothing - # cfout - The callframe that flows out of the invocation sequence, or - # {} - # invars - Dictionary whose keys are literal variable names and whose - # values are the sources of variables that need to be copied - # to the callframe prior to invocation - # retval - Return value from the invocation - # outvars - Dictionary whose keys are literal variable names and - # whose values are the quadcode values that need to be - # assigned from the callframe after the invocation - # errexit - Basic block number to jump to on error exit - # normexit - Basic block number to jump to on normal exit - - variable xfmr b pc q cmd argl \ - pc0 cfin invars retval cfout outvars errexit normexit - - constructor {} { - # Defer construction to an initialization method to avoid throwing - # constructor errors. - } - -} - -# quadcode::invocationSequence method analyze -- -# -# Decompose the codeburst that invokes a command from quadcode -# -# Parameters: -# xfmr_ - quadcode::transformer object holding the quadcode -# b_ - Basic block number in which the invoke instruction appears -# pc_ - PC within the basic block at which the invoke instruction appears -# -# Results: -# None -# -# Side effects: -# Initializes variables according to the instruction. - -oo::define quadcode::invocationSequence method analyze {xfmr_ b_ pc_} { - - set xfmr $xfmr_ - set b $b_ - set pc $pc_ - - set bb [$xfmr getBasicBlock $b] - set q [lindex $bb $pc] - - # Take apart the invocation - - set argl [lassign $q op cfo_invoke cfi_invoke cmd] - if {$op ni {"invoke" "invokeExpanded"}} { - error "cannot analyze: not an invocation." - } - - # Find the input callframe and relevant input variables - - set pc0 $pc - set cfin Nothing - set invars {} - if {$cfi_invoke ne "Nothing"} { - set qb [lindex $bb [expr {$pc-1}]] - if {[lindex $qb 0] eq "moveToCallFrame"} { - if {[lindex $qb 1] ne $cfi_invoke} { - error "cannot analyze: moveToCallFrame mislinked" - } - set varl [lassign $qb - - cfin] - foreach {namelit source} $varl { - if {[lindex $namelit 0] ne "literal"} { - error "cannot analyze: name of input var not literal" - } - dict set invars [lindex $namelit 1] $source - } - set pc0 [expr {$pc-1}] - } - } - - # Find the result value - - set retval $cfo_invoke - if {[lindex $bb [incr pc] 0] eq "retrieveResult"} { - set q2 [lindex $bb $pc] - lassign $q2 - retval cf2 - if {$cf2 ne $cfo_invoke} { - error "cannot analyze: retrieveResult mislinked" - } - } else { - incr pc -1 - } - - # Find the output callframe - - set cfout $cfo_invoke - if {[lindex $bb [incr pc] 0] eq "extractCallFrame"} { - set q2 [lindex $bb $pc] - lassign $q2 - cfout cf2 - if {$cf2 ne $cfo_invoke} { - error "cannot analyze: extractCallFrame mislinked" - } - } else { - incr pc -1 - } - - # Find the output variables - - set outvars {} - while {[lindex $bb [incr pc] 0] eq "moveFromCallFrame"} { - set q2 [lindex $bb $pc] - lassign $q2 - varout cf2 litname - if {$cf2 ne $cfout} { - error "cannot analyze: moveFromCallFrame mislinked" - } - lassign $litname kind val - if {$kind ne "literal"} { - error "cannot analyze: moveFromCallFrame with non-literal variable" - } - dict set outvars $val $varout - } - incr pc -1 - - # Find the error exit - - if {[lindex $bb [incr pc] 0] eq "jumpMaybe"} { - set q2 [lindex $bb $pc] - lassign $q2 - target cond - if {$cond ne $retval} { - error "cannot analyze: jumpMaybe mislinked" - } - set errexit [lindex $target 1] - } else { - error "cannot analyze: invocation does not end basic block." - } - - # Find the normal exit - - if {[lindex $bb [incr pc] 0] eq "jump"} { - set normexit [lindex $bb $pc 1 1] - } else { - error "cannot analyze: basic block does not end with a jump" - } - - return -} - -# quadcode::invocationSequence method cfin -- -# -# Returns the starting callframe for an invocation sequence - -oo::define quadcode::invocationSequence method cfin {} { - return $cfin -} - -# quadcode::invocationSequence method cfout -- -# -# Returns the ending callframe for an invocation sequence - -oo::define quadcode::invocationSequence method cfout {} { - return $cfout -} - -# quadcode::invocationSequence method errexit -- -# -# Returns the error exit block number for an invocation sequence - -oo::define quadcode::invocationSequence method errexit {} { - return $errexit -} - -# quadcode::invocationSequence method invars -- -# -# Returns the input variables of an invocation sequence - -oo::define quadcode::invocationSequence method invars {} { - return $invars -} - -# quadcode::invocationSequence method normexit -- -# -# Returns the normal exit block number for an invocation sequence - -oo::define quadcode::invocationSequence method normexit {} { - return $normexit -} - -# quadcode::invocationSequence method outvars -- -# -# Returns the output variables of an invocation sequence - -oo::define quadcode::invocationSequence method outvars {} { - return $outvars -} - -# quadcode::invocationSequence method pc0 -- -# -# Returns the starting program counter for an invocation sequence - -oo::define quadcode::invocationSequence method pc0 {} { - return $pc0 -} - -# quadcode::invocationSequence method retval -- -# -# Returns the return value for an invocation sequence - -oo::define quadcode::invocationSequence method retval {} { - return $retval -} - Index: quadcode/narrow.tcl ================================================================== --- quadcode/narrow.tcl +++ quadcode/narrow.tcl @@ -18,30 +18,25 @@ # Results: # None. # # Preconditions: # -# The program must be in SSA form, and the DJ graph (bbidom, bbkids, -# bbnlevels, bblevel) must be accurate. ud- and du-chains must be -# present. +# The program must be deconstructed from SSA form. ud- and du-chains +# must reflect the state of the program before deconstruction. One +# round of copy propagation must have been done. # # Side effects: # # Wherever a conditional branch tests the data type or existence of # a value, narrowing instructions are inserted in the quadcode to # mark that the value is of the required type. # -# The ud- and du-chains are updated as the narrowing instructions -# are inserted, and phi instructions for the controlled variables -# are inserted on the iterated dominance frontier. The phi's may -# turn out to be useless, in which case a subsequent 'uselessphis' -# pass will clean them up. -# # All of the operations introduced in this pass consist of introducing # new quads of the form -# v2 := some_narrowing_operation(v1) -# where v2 is a new variable instance, followed by fixup to the SSA diagram. +# v := some_narrowing_operation(v) +# where v is the value being tested (possibly indirectly) by the conditional +# jump. oo::define quadcode::transformer method narrow {} { upvar #0 quadcode::dataType::IMPURE IMPURE my debug-narrow { @@ -75,15 +70,30 @@ set falseBranch [lindex $q 1 1] set trueBranch [lindex $bb end 1 1] } # These operations may narrow if the defining instruction - # is 'exists' or 'instanceOf' + # is 'arrayExists', 'exists' or 'instanceOf' # The assignment appears at 'dpc' within basic block 'dbb' # and consists of the quadcode statement 'dquad'. - lassign [my findDef [lindex $q 2]] dbb dpc dquad + if {[catch { + + # Finding the definition will throw an error at a phi. + # The error can be ignored, because phi is not 'arrayExists' + # 'exists' or 'instanceOf'. + my findDef [lindex $q 2] + } result]} { + my debug-narrow { + puts "cannot find data source of [lindex $q 2]" + } + continue + } + lassign $result dbb dpc dquad + my debug-narrow { + puts "data source is $dbb:$dpc: $dquad" + } set dop [lindex $dquad 0 0] switch -exact -- $dop { arrayExists { @@ -91,20 +101,30 @@ if {[lindex $dvar 0] ni {var temp}} continue my insertQuad $trueBranch 0 \ [list extractArray $dvar $dvar] my insertQuad $falseBranch 0 \ [list extractScalar $dvar $dvar] - my narrow_repairSSA $dvar $trueBranch $falseBranch + my debug-narrow { + puts "$trueBranch:0:\ + [lindex $bbcontent $trueBranch 0]" + puts "$falseBranch:0:\ + [lindex $bbcontent $falseBranch 0]" + } } exists { set dvar [lindex $dquad 2] if {[lindex $dvar 0] ni {var temp}} continue my insertQuad $trueBranch 0 \ [list extractExists $dvar $dvar] my insertQuad $falseBranch 0 \ [list unset $dvar] - my narrow_repairSSA $dvar $trueBranch $falseBranch + my debug-narrow { + puts "$trueBranch:0:\ + [lindex $bbcontent $trueBranch 0]" + puts "$falseBranch:0:\ + [lindex $bbcontent $falseBranch 0]" + } } instanceOf { set typecode [lindex $dquad 0 1] set typename [lindex $dquad 0 2] @@ -118,11 +138,16 @@ [list [list narrowToType $typecode $typename] \ $dvar $dvar] my insertQuad $falseBranch 0 \ [list [list narrowToType $nottype $notname] \ $dvar $dvar] - my narrow_repairSSA $dvar $trueBranch $falseBranch + my debug-narrow { + puts "$trueBranch:0:\ + [lindex $bbcontent $trueBranch 0]" + puts "$falseBranch:0:\ + [lindex $bbcontent $falseBranch 0]" + } } } } jumpMaybe { @@ -135,45 +160,19 @@ puts " $okBranch:0: [list copy $var $var]" puts " $failBranch:0: [list extractFail $var $var]" } my insertQuad $okBranch 0 [list copy $var $var] my insertQuad $failBranch 0 [list extractFail $var $var] - my narrow_repairSSA $var $okBranch $failBranch } } } my debug-narrow { puts "after inserting narrowing operations:" my dump-bb } } - -# quadcode::transformer method narrow_repairSSA -- -# -# Repairs the SSA property after introducing a narrowing operation -# on a variable. -# -# Parameters: -# v - Variable that has been narrowed and now has duplicate assignments -# b1 - First block containing a new assignment to v -# b2 - Second block containing a new assignment to v -# -# Results: -# None. -# -# Side effects: -# The SSA property is restored by giving new names to the assignments to -# $v, and updating the uses, possibly introducing new phi operations. - -oo::define quadcode::transformer method narrow_repairSSA {v b1 b2} { - set d [dict create [dict get $udchain $v] 1] - dict incr d $b1 - dict incr d $b2 - - my repairSSAVariable $v $d -} # quadcode::transformer method cleanupNarrow -- # # Removes narrowing instructions that are no longer relevant # @@ -242,15 +241,19 @@ unset -nocomplain replacer my debug-cleanupNarrow { puts "existence \$flag=$flag" puts "type = [quadcode::nameOfType $inputType]" } + # The 'arrayExists' will return false if the value does + # not exist, or if the value is scalar if {$flag eq "no" || - ![quadcode::dataType::mightbea $inputType $ARRAY]} { + ![quadcode::dataType::mightbea $inputType $ARRAY]} { + # Does not exist or cannot be an array set replacer {literal 0} } elseif {$flag eq "yes" && [quadcode::dataType::isa $inputType $ARRAY]} { + # Exists and is an array set replacer {literal 1} } if {[info exists replacer]} { my debug-cleanupNarrow { puts "$b:$pc: Able to remove $q because $source is\ @@ -293,11 +296,18 @@ extractArray { set result [lindex $q 1] set source [lindex $q 2] set inputType [quadcode::typeOfOperand $types $source] set flag [quadcode::dataType::existence $types $source] - if {$flag eq "no" || (!($inputType & $NONARRAY) && ($inputType & $ARRAY))} { + # The 'extractArray' operation is inserted on the 'true' + # branch of 'arrayExists'. It asserts specifically that + # the value is an array, which implies that it exists. + # This quad can therefore be removed only if the input + # value exists and is an array + if {$flag eq "yes" + && (!($inputType & $NONARRAY) + && ($inputType & $ARRAY))} { lset bbcontent $b $pc {nop {}} my removeUse $source $b my replaceUses $result $source dict unset udchain $result set changed 1 @@ -364,11 +374,24 @@ extractScalar { set result [lindex $q 1] set source [lindex $q 2] set inputType [quadcode::typeOfOperand $types $source] set flag [quadcode::dataType::existence $types $source] - if {$flag eq "no" || (!($inputType & $ARRAY) && ($inputType & $NONARRAY))} { + # The 'extractScalar' operation is inserted on the + # 'false' branch of 'arrayExists'. It asserts that the + # value either is not an array or that the value does + # not exist. In either case, this operation may be + # removed. + if {$flag eq "no" + || (!($inputType & $ARRAY) + && ($inputType & $NONARRAY))} { + my debug-cleanupNarrow { + puts " (flag = $flag; inputType = \ + [nameOfType $inputType])" + puts "$b:$pc: delete $q" + puts "$b:$pc: replace $result with $source" + } lset bbcontent $b $pc {nop {}} my removeUse $source $b my replaceUses $result $source dict unset udchain $result set changed 1 @@ -426,24 +449,33 @@ instanceOf { set result [lindex $q 1] set source [lindex $q 2] set typecode [lindex $q 0 1] - set is [quadcode::dataType::isa \ - [quadcode::typeOfOperand $types $source] \ - $typecode] - set maybe [quadcode::dataType::mightbea \ - [quadcode::typeOfOperand $types $source] \ - $typecode] + set fromtype [quadcode::typeOfOperand $types $source] + set is [quadcode::dataType::isa $fromtype $typecode] + set maybe [quadcode::dataType::mightbea $fromtype $typecode] if {$is} { + my debug-cleanupNarrow { + puts "always true:" + puts "$b:$pc: $q" + puts "from type [nameOfType $fromtype]" + puts "is=$is, maybe=$maybe" + } lset bbcontent $b $pc {nop {}} my removeUse $source $b my replaceUses $result {literal 1} dict unset udchain $result set changed 1 continue; # delete the quad } elseif {!$maybe} { + my debug-cleanupNarrow { + puts "always false:" + puts "$b:$pc: $q" + puts "from type [nameOfType $fromtype]" + puts "is=$is, maybe=$maybe" + } lset bbcontent $b $pc {nop {}} my removeUse $source $b my replaceUses $result {literal 0} dict unset udchain $result set changed 1 Index: quadcode/pre.tcl ================================================================== --- quadcode/pre.tcl +++ quadcode/pre.tcl @@ -75,11 +75,11 @@ instanceOf le listAppend listConcat listIn listIndex listLength listRange listSet lshift lt - maptoint mod moveFromCallFrame mult + maptoint mod mult narrowToType neq not purify regexp retrieveResult rshift strcase strcat strclass strcmp streq strfind strindex strlen strmap strmatch strrange strreplace strrfind strtrim @@ -204,10 +204,15 @@ my pre_cleanup # 6. Now, dead code elimination and copy propagation will eliminate # any messes that step 4 left behind. + my debug-pre { + puts "After partial redundancy elimination:" + my dump-bb + } + return $did_something } # quadcode::transformer method pre_init -- Index: quadcode/specializer.tcl ================================================================== --- quadcode/specializer.tcl +++ quadcode/specializer.tcl @@ -310,31 +310,51 @@ "" 0 $procName \ fatal "Cannot analyze %s\n%s" \ $procName $::errorInfo } } - 1 { + 100 { try { my TidyInstance $procName $argTypes } on error {msg opts} { my diagnostic $procName $argTypes \ "" 0 $procName \ fatal "Cannot optimize %s\n%s" \ $procName $::errorInfo } } - 2 { + 125 { + try { + my PartialRedundancyInstance $procName $argTypes + } on error {msg opts} { + my diagnostic $procName $argTypes \ + "" 0 $procName \ + fatal "Cannot optimize %s\n%s" \ + $procName $::errorInfo + } + } + 150 { + try { + my CallFrameFlowInstance $procName $argTypes + } on error {msg opts} { + my diagnostic $procName $argTypes \ + "" 0 $procName \ + fatal "Cannot optimize %s\n%s" \ + $procName $::errorInfo + } + } + 200 { try { my NodeSplitInstance $procName $argTypes } on error {msg opts} { my diagnostic $procName $argTypes \ "" 0 $procName \ fatal "Cannot perform path splitting on %s\n%s" \ $procName $::errorInfo } } - 3 { + 300 { try { my DoneNodeSplitting $procName $argTypes } on error {msg opts} { my diagnostic $procName $argTypes \ "" 0 $procName \ @@ -1026,11 +1046,11 @@ my AddToWorklist 0 {*}$d } } } - my AddToWorklist 1 $procName $argTypes + my AddToWorklist 100 $procName $argTypes } # quadcode::specializer method TidyInstance -- # # Runs cleanup optimizations on a procedure instance @@ -1062,11 +1082,103 @@ puts "TIDY $procName ($argTypeNames):" } if {[$inf tidy]} { my AddToWorklist 0 $procName $argTypes } else { - my AddToWorklist 2 $procName $argTypes + my AddToWorklist 125 $procName $argTypes + } +} + +# quadcode::specializer method PartialRedundancyInstance -- +# +# Runs one round of partial redundancy elimination on a procedure +# instance. +# +# Parameters: +# procName - Name of the procedure being optimized +# argTypes - List of type codes for the procedure's arguments +# +# Results: +# None. +# +# Side effects: +# +# Partial redundancy elimination may introduce new quadcode +# variables, resulting in the need to repeat type analysis. It +# also introduces new opportunities for the cleanup +# optimizations. Therefore, if this pass makes changes, the +# procedure gets backtracked to type analysis. If no changes are +# made, we can continue with node splitting. + +oo::define quadcode::specializer method PartialRedundancyInstance {procName + argTypes} { + + set instance [list $procName $argTypes] + set argTypeNames [lmap x $argTypes {nameOfType $x}] + + if {[dict exists $failed $procName $argTypes]} { + my debug-specializer { + puts "DON'T PRE $procName ($argTypeNames) - it's failed" + } + return; # Don't reanalyze failed instances + } + + set inf [dict get $typeInf $instance] + + my debug-specializer { + puts "PRE $procName ($argTypeNames):" + } + if {[$inf partialredundancy]} { + my AddToWorklist 0 $procName $argTypes + } else { + my AddToWorklist 150 $procName $argTypes + } +} + +# quadcode::specializer method CallFrameFlowInstance -- +# +# Runs one round of callframe data motion analysis on a procedure +# instance. +# +# Parameters: +# procName - Name of the procedure being optimized +# argTypes - List of type codes for the procedure's arguments +# +# Results: +# None. +# +# Side effects: +# +# Optimizing call frame motion may introduce new quadcode variables, +# resulting in the need to repeat type analysis. It also +# introduces new opportunities for the cleanup optimizations. +# Therefore, if this pass makes changes, the procedure +# gets backtracked to type analysis. If no changes are made, +# we can continue with node splitting. + +oo::define quadcode::specializer method CallFrameFlowInstance {procName + argTypes} { + + set instance [list $procName $argTypes] + set argTypeNames [lmap x $argTypes {nameOfType $x}] + + if {[dict exists $failed $procName $argTypes]} { + my debug-specializer { + puts "DON'T CALLFRAME-FLOW $procName ($argTypeNames) - it's failed" + } + return; # Don't reanalyze failed instances + } + + set inf [dict get $typeInf $instance] + + my debug-specializer { + puts "CALLFRAME-FLOW $procName ($argTypeNames):" + } + if {[$inf callFrameFlow]} { + my AddToWorklist 0 $procName $argTypes + } else { + my AddToWorklist 200 $procName $argTypes } } # quadcode::specializer method NodeSplitInstance -- # @@ -1105,11 +1217,11 @@ puts "SPLIT $procName ($argTypeNames):" } if {[$inf jumpthread]} { my AddToWorklist 0 $procName $argTypes } else { - my AddToWorklist 3 $procName $argTypes + my AddToWorklist 300 $procName $argTypes } } # quadcode::specializer method DoneNodeSplitting -- # @@ -1149,13 +1261,14 @@ # Puts a procedure instance on the worklist of procedures to specialize. # # Parameters: # actNum - Number of the analysis being queued. # 0 - Type inference -# 1 - Type narrowing and cleanup optimization -# 2 - Node splitting -# 3 - Final cleanup +# 100 - Type narrowing and cleanup optimization +# 150 - Callframe data motion +# 200 - Node splitting +# 300 - Final cleanup # procName - Name of the procedure under consideration # argTy - Types of the arguments # # Results: # None. Index: quadcode/ssa.tcl ================================================================== --- quadcode/ssa.tcl +++ quadcode/ssa.tcl @@ -1247,10 +1247,13 @@ set pc -1 set singleExit 1 foreach q $bb { incr pc if {[lindex $q 0 0] eq "phi"} { + foreach {from val} [lrange $q 2 end] { + my removeUse $val $from + } continue } if {[lindex $q 0 0] eq "jump"} { break } @@ -1280,10 +1283,11 @@ set src [dict get $argl $bkey] if {$src eq "Nothing"} { set q3 [list unset $dest] } else { set q3 [list copy $dest $src] + my addUse $src $b } my debug-deconstructSSA { puts " [incr newpc]: $q3" } lappend newb $q3 Index: quadcode/transformer.tcl ================================================================== --- quadcode/transformer.tcl +++ quadcode/transformer.tcl @@ -316,30 +316,37 @@ foreach pass { bbpartition constJumpPeephole sortbb loopinv - callFrameMotion ssa ud_du_chain + deadbb + deadvars + uselessphis copyprop fqcmd varargs deadbb bbidom bblevel rewriteParamChecks + deconstructSSA narrow + ssa + ud_du_chain + deadbb + deadvars + uselessphis + copyprop } { - lappend timings $pass [lindex [time [list my $pass]] 0] - my debug-audit { - my audit-duchain $pass - my audit-phis $pass - } - } - my debug-timings { - foreach {pass usec} $timings { + my debug-transform { + puts "Run: $pass" + } + set usec [lindex [time [list my $pass]] 0] + lappend timings $pass $usec + my debug-timings { puts "$pass: $usec microseconds" } } my debug-transform { puts "after initial transform:" @@ -433,10 +440,40 @@ # Returns the desired basic block, or {} if the block does not exist. method getBasicBlock {b} { lindex $bbcontent $b } + + # editBasicBlock -- + # + # Performs a step that may edit the content of a basic block. + # This logic is set up so that the basic block content will be + # unshared while the editing step is proceeding. + # + # Parameters: + # bbVar - Variable in the caller that will be set to the basic block + # content. + # b - Basic block number of the block that is to be modified. + # script - Script to evaluate in the caller with the variable set. + # + # Results: + # Returns the result of evaluating the script + # + # Side effects: + # Sets the given variable and does whatever the script does. + # Sets the basic block to the value of 'bbVar' after the script + # returns, if no error has occurred. + + method editBasicBlock {bbVar b script} { + upvar 1 $bbVar bb + set bb [lindex $bbcontent $b] + lset bbcontent $b {}; # Remove the block from 'bbcontent' while + ; # editing + set result [uplevel 1 $script] + lset bbcontent $b $bb; # Replace the block content when done editing + return $result + } # getReturnType -- # # Retrieves the return type for a quadcode sequence. # @@ -592,12 +629,10 @@ my debug-tidy { set debugLine {tidy:} } foreach pass { copyprop - cleanupMoveFromCallFrame - cleanupMoveToCallFrame cleanupCallFrameUse cleanupNarrow bbidom bblevel deadcond @@ -606,11 +641,10 @@ deadvars uselessphis bbidom bblevel constfold - partialredundancy } { set cmd [string map [list @pass $pass] { set result [my @pass] }] lappend timings $pass [lindex [time $cmd] 0] @@ -660,11 +694,11 @@ # Side effects: # Removes the markers for which nodes have been split. Removes # any remaining 'callFrameNop' instructions. Cleans up useless phis, # and eliminates the use of the callframe entirely if possible. # -# TODO: It is very likely that removeCallFrameNop and eliminateCallFrame +# TODO: It is very likely that eliminateCallFrame # can appear much earlier in optimization than this. It might be # profitable to investigate this. oo::define quadcode::transformer method doneWithNodeSplitting {} { @@ -766,10 +800,11 @@ source [file join $quadcode::libdir types.tcl] source [file join $quadcode::libdir abbreviate.tcl] source [file join $quadcode::libdir aliases.tcl] source [file join $quadcode::libdir bb.tcl] +source [file join $quadcode::libdir builder.tcl] source [file join $quadcode::libdir bytecode.tcl] source [file join $quadcode::libdir callframe.tcl] source [file join $quadcode::libdir constfold.tcl] source [file join $quadcode::libdir constjump.tcl] source [file join $quadcode::libdir copyprop.tcl] @@ -777,11 +812,10 @@ source [file join $quadcode::libdir deadcode.tcl] source [file join $quadcode::libdir duchain.tcl] source [file join $quadcode::libdir flatten.tcl] source [file join $quadcode::libdir fqcmd.tcl] source [file join $quadcode::libdir inline.tcl] -source [file join $quadcode::libdir invoke.tcl] source [file join $quadcode::libdir jumpthread.tcl] source [file join $quadcode::libdir liveranges.tcl] source [file join $quadcode::libdir loopinv.tcl] source [file join $quadcode::libdir narrow.tcl] source [file join $quadcode::libdir pre.tcl] @@ -789,8 +823,5 @@ source [file join $quadcode::libdir translate.tcl] source [file join $quadcode::libdir typecheck.tcl] source [file join $quadcode::libdir upvar.tcl] source [file join $quadcode::libdir varargs.tcl] source [file join $quadcode::libdir widen.tcl] - -#source [file join $quadcode::libdir exists.tcl] -#source [file join $quadcode::libdir interval.tcl] Index: quadcode/translate.tcl ================================================================== --- quadcode/translate.tcl +++ quadcode/translate.tcl @@ -44,20 +44,43 @@ ; # quadcode PC in the initial translation set fixup {}; # Dictionary whose keys are jump targets ; # and the values are lists of quad program ; # counters that jump to them, used to fix up ; # forward jumps. + set cf [list temp @callframe] + ; # Callframe is used in many places, so + ; # allow it to be abbreviated + set catches {}; # Dictionary whose keys are program counters + ; # that are the targets of catch exception ranges + ; # and whose values are immaterial. Used to + ; # generate a 'startCatch' operation at each + ; # point where errorInfo and errorCode need + ; # to be spoilt. my debug-translate { puts "Translate bytecode: $originProc" } + + # vlist is a list of local variables present in the bytecode. + set vlist {} + foreach v [dict get $bytecode variables] { + if {!("temp" in [lindex $v 0])} { + lappend vlist [lindex $v 1] + } + } + + # Enumerate the catch targets + foreach row [dict get $bytecode exception] { + if {[dict get $row type] eq "catch"} { + dict set catches [dict get $row catch] {} + } + } # Construct a header that sets parameters and provides a fake point # to which live-on-entry variables can be attached. - - set vlist [lmap x [dict get $bytecode variables] {lindex $x 1}] - my quads entry {temp @callframe} [list literal $vlist] + + my quads entry $cf [list literal $vlist] my quads @debug-context {} [list literal [list proc $originProc]] if {[dict exists $bytecode sourcefile]} { my quads @debug-file {} [list literal [dict get $bytecode sourcefile]] } if {[dict exists $bytecode initiallinenumber]} { @@ -67,19 +90,31 @@ if {[dict exists $bytecode script]} { my quads @debug-script {} [list literal [dict get $bytecode script]] } # Also set the variable list in this transformer for later. - set vars [lmap v $vlist {list var $v}] + + # Put in code to transfer arguments set idx 0 foreach v [dict get $bytecode variables] { if {{arg} in [lindex $v 0]} { my quads param [list var [lindex $v 1]] [list arg $idx] } incr idx } + + # Make sure that the args are in the callframe. + set q [list moveToCallFrame $cf $cf] + foreach v [dict get $bytecode variables] { + if {{arg} in [lindex $v 0]} { + lappend q [list literal [lindex $v 1]] [list var [lindex $v 1]] + } + } + if {[llength $q] > 3} { + my quads {*}$q + } # Iterate the instruction list dict for {pc insn} [dict get $bytecode instructions] { if {![dict exists $bytecode stackState $pc]} { my debug-translate { @@ -96,11 +131,11 @@ # Fix up any quads that jump to the current quad dict set quadindex $pc [llength $quads] if {[dict exists $fixup $pc]} { foreach qi [dict get $fixup $pc] { my debug-translate { - puts " fixup $qi to proceed to $pc" + puts " fixup $qi to proceed to [llength $quads]" } lset quads $qi 1 [list pc [llength $quads]] } dict unset fixup $pc } @@ -131,10 +166,16 @@ if {$currentscript ne [dict get $c script]} { set currentscript [dict get $c script] my quads @debug-script {} [list literal [dict get $c script]] } } + + # Add a startCatch to spoil errorCode if this instruction begins + # an exception range + if {[dict exists $catches $pc]} { + my quads startCatch $cf $cf + } # Translate the current bytecode switch -exact -- [lindex $insn 0] { add - bitand - @@ -332,11 +373,11 @@ my quads strtrim $v $v $chars [list literal 1] } done { # End of bytecode set v [list temp [incr depth -1]] - my quads return {} {temp @callframe} $v + my quads return {} $cf $v } returnStk { # NOTE! Opposite order to 'returnImm' set v [list temp [incr depth -1]] set opt [list temp [incr depth -1]] @@ -434,25 +475,29 @@ set n [expr {$depth - [llength $assign] - 3}] set lists [lmap group $assign { list temp [incr n] }] set idx [list temp [expr {$depth + 1}]] + set toUpdate {} foreach varGroup $assign list $lists { if {[llength $varGroup] == 1} { my quads copy $idx $res } else { my quads mult $idx $res [list literal [llength $varGroup]] } foreach varIndex $varGroup { set var [my index-to-var $varIndex] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads listIndex $var $list $idx my quads extractMaybe $var $var + lappend toUpdate [lreplace $var 0 0 literal] $var my quads add $idx $idx [list literal 1] } } + my update-in-callframe {*}$toUpdate my quads foreachMayStep $res $pair my quads foreachAdvance $pair $pair set target [expr {$pc + $jumpOffset}] my generate-jump $target true $res } @@ -469,10 +514,11 @@ my quads listAppend $collector $collector $value my quads extractMaybe $collector $collector } dictFirst { set var [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $var set dict [list temp [incr depth -1]] set value [list temp $depth] set key [list temp [incr depth]] set done [list temp [incr depth]] my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ @@ -485,34 +531,40 @@ dictNext { set var [my index-to-var [lindex $insn 1]] set value [list temp $depth] set key [list temp [incr depth]] set done [list temp [incr depth]] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads dictIterNext $var $var my quads dictIterKey $key $var my quads dictIterValue $value $var my quads dictIterDone $done $var } dictUpdateStart { set var [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" set auxNum [string range [lindex $insn 2] 1 end] set aux [lindex [dict get $bytecode auxiliary] $auxNum] set mid [list temp opnd0] set val [list temp [incr depth -1]] set idx 0 + set toUpdate {} foreach v [dict get $aux variables] { set r [my index-to-var $v] + my generate-move-from-callframe $r my generate-scalar-check $pc $r {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my error-quads $pc listIndex $mid $val [list literal $idx] my error-quads $pc dictGetOrNexist $r $var $mid + lappend toUpdate [list literal [lindex $r 1]] $r incr idx } + my update-in-callframe {*}$toUpdate } dictUpdateEnd { set var [my index-to-var [lindex $insn 1]] set auxNum [string range [lindex $insn 2] 1 end] set aux [lindex [dict get $bytecode auxiliary] $auxNum] @@ -520,45 +572,60 @@ set isary [list temp opnd2] set mid [list temp opnd3] set updating [list temp opnd4] set val [list temp [incr depth -1]] set idx 0 + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't write \"%s\": variable is array" my quads copy $updating $var foreach v [dict get $aux variables] { set r [my index-to-var $v] + my generate-move-from-callframe $r my error-quads $pc listIndex $key $val [list literal $idx] incr idx # Convert an ARRAY into a NEXIST here; ARRAY is unreadable # so treat as NEXIST... my quads arrayExists $isary $r set n [llength $quads] + # 0 my quads jumpFalse [list pc [expr {$n + 3}]] $isary + # 1 my quads copy $mid Nothing + # 2 my quads jump [list pc [expr {$n + 4}]] - my quads extractScalar $mid $r + # 3 + my quads copy $mid $r + # 4 # Write the value to the right key of the dict - my error-quads $pc dictSetOrUnset $updating $updating $key $mid + my error-quads $pc dictSetOrUnset \ + $updating $updating $key $mid } my quads copy $var $updating + my update-in-callframe [list literal [lindex $var 1]] $var } unsetScalar { # TODO - This doesn't complain on unsetting a nonexistent # variable, it ignores '-nocomplain' set var [my index-to-var [lindex $insn 2]] my quads unset $var + if {[lindex $var 0] eq "var"} { + my quads moveToCallFrame $cf $cf \ + [list literal [lindex $var 1]] Nothing + } } unsetArray { # TODO - This doesn't complain on unsetting a nonexistent # element, it ignores '-nocomplain' set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 2]] + my generate-move-from-callframe $ary my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't unset \"%s(%s)\": variable isn't array" my quads initArrayIfNotExists $ary $ary my quads arrayUnset $ary $ary $idx + my update-in-callframe [list literal [lindex $ary 1]] $ary } dictDone { # Do nothing; general free will clean up. } verifyDict { @@ -568,38 +635,43 @@ } incrScalar1Imm { set result [list temp $depth] set var [my index-to-var [lindex $insn 1]] set delta [lindex $insn 2] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads initIfNotExists $var $var {literal 0} my quads copy $result [list literal $delta] my generate-arith-domain-check $pc incr $var $result my quads purify {temp opd0} $var my quads purify {temp opd1} $result my quads add $var {temp opd0} {temp opd1} + my update-in-callframe [list literal [lindex $var 1]] $var my quads copy $result $var } incrScalar1 { set result [list temp $depth] set val [list temp [incr depth -1]] set var [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads initIfNotExists $var $var {literal 0} my generate-arith-domain-check $pc incr $var $val my quads purify {temp opd0} $var my quads purify {temp opd1} $val my quads add $var {temp opd0} {temp opd1} + my update-in-callframe [list literal [lindex $var 1]] $var my quads copy $result $var } incrArray1Imm { set tmp [list temp $depth] set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 1]] set delta [list literal [lindex $insn 2]] + my generate-move-from-callframe $ary my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't read \"%s(%s)\": variable isn't array" my quads initArrayIfNotExists $ary $ary my quads copy $tmp $delta set res $idx @@ -609,16 +681,18 @@ my generate-arith-domain-check $pc incr $inval $tmp my quads purify {temp opd1} $inval my quads purify {temp opd2} $tmp my quads add $inval {temp opd1} {temp opd2} my quads arraySet $ary $ary $idx $inval + my update-in-callframe [list literal [lindex $ary 1]] $ary my quads copy $res $inval } incrArray1 { set delta [list temp [incr depth -1]] set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $ary my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't read \"%s(%s)\": variable isn't array" my quads initArrayIfNotExists $ary $ary set res $idx set inval {temp opd0} @@ -627,10 +701,11 @@ my generate-arith-domain-check $pc incr $inval $delta my quads purify {temp opd1} $inval my quads purify {temp opd2} $delta my quads add $inval {temp opd1} {temp opd2} my quads arraySet $ary $ary $idx $inval + my update-in-callframe [list literal [lindex $ary 1]] $ary my quads copy $res $inval } incrStkImm { set var [list temp [incr depth -1]] set delta [list literal [lindex $insn 1]] @@ -731,17 +806,17 @@ directArrayLappendList $var $var $elem $listvalue } existStk { set var [list temp [incr depth -1]] # TODO: This assumes we're dealing with qualified names! - my quads directExists $var {temp @callframe} $var + my quads directExists $var $cf $var } existArrayStk { set elem [list temp [incr depth -1]] set var [list temp [incr depth -1]] # TODO: This assumes we're dealing with qualified names! - my quads directArrayExists $var {temp @callframe} $var $elem + my quads directArrayExists $var $cf $var $elem } loadStk { set var [list temp [incr depth -1]] # TODO: This assumes we're dealing with qualified names! my generate-callframe-op $pc directGet $var $var @@ -811,16 +886,18 @@ set q {} for {set i 0} {$i < $idxNum} {incr i} { # NOTE: Reversed lappend q [list temp [incr depth -1]] } - set r [list temp $depth] + set r [list temp $depth] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} my error-quads $pc dictSet $r $var $val {*}[lreverse $q] my quads copy $var $r + my update-in-callframe [list literal [lindex $var 1]] $var } dictUnset { set idxNum [expr [lindex $insn 1]] set var [my index-to-var [lindex $insn 2]] set q {} @@ -827,37 +904,43 @@ for {set i 0} {$i < $idxNum} {incr i} { # NOTE: Reversed lappend q [list temp [incr depth -1]] } set r [list temp $depth] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} my error-quads $pc dictUnset $r $var {*}[lreverse $q] my quads copy $var $r + my update-in-callframe [list literal [lindex $var 1]] $var } dictAppend - dictLappend { set var [my index-to-var [lindex $insn 1]] set val [list temp [incr depth -1]] set key [list temp [incr depth -1]] set res [list temp $depth] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} my error-quads $pc [lindex $insn 0] $res $var $key $val my quads copy $var $res + my update-in-callframe [list literal [lindex $var 1]] $var } dictIncrImm { set delta [list literal [lindex $insn 1]] set var [my index-to-var [lindex $insn 2]] set key [list temp [incr depth -1]] set res [list temp $depth] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} my error-quads $pc dictIncr $res $var $key $delta my quads copy $var $res + my update-in-callframe [list literal [lindex $var 1]] $var } list { set acount [lindex $insn 1] set depth [expr {$depth - $acount}] set result [list temp $depth] @@ -909,13 +992,13 @@ for {set i $rcount} {$i < $acount} {incr i} { lappend qd [list temp [expr {$depth + $i}]] } my generate-function-param-check $pc $qd # generate the call itself - my quads invoke {temp @callframe} {temp @callframe} {*}$qd - my quads retrieveResult {temp @exception} {temp @callframe} - my quads extractCallFrame {temp @callframe} {temp @callframe} + my quads invoke $cf $cf {*}$qd + my quads retrieveResult {temp @exception} $cf + my quads extractCallFrame $cf $cf my generate-jump [my exception-target $pc catch] maybe \ {temp @exception} my quads extractMaybe $result {temp @exception} } invokeStk1 - invokeStk4 { @@ -926,13 +1009,13 @@ for {set i 0} {$i < $acount} {incr i} { lappend qd [list temp [expr {$depth + $i}]] } my generate-function-param-check $pc $qd # generate the call itself - my quads invoke {temp @callframe} {temp @callframe} {*}$qd - my quads retrieveResult {temp @exception} {temp @callframe} - my quads extractCallFrame {temp @callframe} {temp @callframe} + my quads invoke $cf $cf {*}$qd + my quads retrieveResult {temp @exception} $cf + my quads extractCallFrame $cf $cf my generate-jump [my exception-target $pc catch] maybe \ {temp @exception} my quads extractMaybe $result {temp @exception} } jump1 - jump4 { @@ -1010,34 +1093,38 @@ } } existScalar { set result [list temp $depth] set var [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $var my quads exists $result $var } existArray { set tmp [list temp $depth] set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 1]] set result $idx + my generate-move-from-callframe $ary my quads initArrayIfNotExists $tmp $ary my quads arrayElementExists $result $tmp $idx } loadScalar1 - loadScalar4 { # Load a variable set result [list temp $depth] set var [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $var my generate-existence-check $pc $var my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads copy $result $var } loadArray1 - loadArray4 { # Load from an array set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $ary my generate-existence-check $pc $ary my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't read \"%s(%s)\": variable isn't array" set res $idx my quads arrayGet $res $ary $idx @@ -1089,25 +1176,29 @@ } storeScalar1 - storeScalar4 { # Store a variable incr depth -1 set var [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads copy $var [list temp $depth] + my update-in-callframe [list literal [lindex $var 1]] $var } storeArray1 - storeArray4 { # Store into an array set val [list temp [incr depth -1]] set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 1]] set res $idx + my generate-move-from-callframe $ary my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't set \"%s(%s)\": variable isn't array" my quads initArrayIfNotExists $ary $ary my quads arraySet $ary $ary $idx $val my quads copy $res $val + my update-in-callframe [list literal [lindex $ary 1]] $ary } tryCvtToNumeric { # No effect on value } tryCvtToBoolean { # Push whether we're dealing with a boolean set val [list temp [expr {$depth - 1}]] @@ -1182,31 +1273,35 @@ my error-quads $pc [lindex $insn 0] $r $v0 } appendScalar1 - appendScalar4 { set val [list temp [incr depth -1]] set var [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} set result [list temp $depth] my quads strcat $var $var $val my quads copy $result $var + my update-in-callframe [list literal [lindex $var 1]] $var } appendArray1 - appendArray4 { set val [list temp [incr depth -1]] set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 1]] set res [list temp $depth] set inval {temp opd0} + my generate-move-from-callframe $ary my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't set \"%s(%s)\": variable isn't array" my quads initArrayIfNotExists $ary $ary my quads arrayGet $inval $ary $idx my quads initIfNotExists $inval $inval {literal {}} my quads strcat $inval $inval $val my quads arraySet $ary $ary $idx $inval my quads copy $res $inval + my update-in-callframe [list literal [lindex $ary 1]] $ary } strcat - concatStk { lassign $insn op count set strcatvals {} for {set i 0} {$i < $count} {incr i} { @@ -1220,58 +1315,66 @@ } lappendScalar1 - lappendScalar4 { set val [list temp [incr depth -1]] set var [my index-to-var [lindex $insn 1]] set res [list temp $depth] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} # TODO: Typecheck: need list in $var my error-quads $pc listAppend $res $var $val my quads copy $var $res + my update-in-callframe [list literal [lindex $var 1]] $var } lappendList { set listval [list temp [incr depth -1]] set var [my index-to-var [lindex $insn 1]] set res [list temp $depth] + my generate-move-from-callframe $var my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} # TODO: Typecheck: need lists in $var and $listval my error-quads $pc listConcat $res $var $listval my quads copy $var $res + my update-in-callframe [list literal [lindex $var 1]] $var } lappendArray1 - lappendArray4 { set val [list temp [incr depth -1]] set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 1]] set res [list temp $depth] set inval {temp opd0} + my generate-move-from-callframe $ary my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't set \"%s(%s)\": variable isn't array" - my quads initArrayIfNotExists $var $var + my quads initArrayIfNotExists $ary $ary my quads arrayGet $inval $ary $idx my quads initIfNotExists $inval $inval {literal {}} my error-quads $pc listAppend $inval $inval $val my quads arraySet $ary $ary $idx $inval my quads copy $res $inval + my update-in-callframe [list literal [lindex $ary 1]] $ary } lappendListArray { set listval [list temp [incr depth -1]] set idx [list temp [incr depth -1]] set ary [my index-to-var [lindex $insn 1]] set res [list temp $depth] set inval {temp opd0} + my generate-move-from-callframe $ary my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't set \"%s(%s)\": variable isn't array" my quads initArrayIfNotExists $ary $ary my quads arrayGet $inval $ary $idx my quads initIfNotExists $inval $inval {literal {}} # TODO: Typecheck: need lists in $inval and $listval my error-quads $pc listConcat $inval $inval $listval my quads arraySet $ary $ary $idx $inval my quads copy $res $inval + my update-in-callframe [list literal [lindex $ary 1]] $ary } listConcat { set list2 [list temp [incr depth -1]] set list1 [list temp [incr depth -1]] set res [list temp $depth] @@ -1278,47 +1381,50 @@ # TODO: Typecheck: need lists in $list1 and $list2 my error-quads $pc listConcat $res $list1 $list2 } arrayExistsImm { set ary [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $ary set res [list temp $depth] my quads arrayExists $res $ary } arrayMakeImm { set ary [my index-to-var [lindex $insn 1]] + my generate-move-from-callframe $ary my generate-array-check $pc $ary {} {TCL WRITE ARRAY} \ "can't array set \"%s\": variable isn't array" my quads initArrayIfNotExists $ary $ary + my update-in-callframe [list literal [lindex $ary 1]] $ary } arrayExistsStk { set ary [list temp [incr depth -1]] set res [list temp $depth] - my error-quads $pc directIsArray $res {temp @callframe} $ary + my error-quads $pc directIsArray $res $cf $ary } arrayMakeStk { set ary [list temp [incr depth -1]] set res [list temp $depth] my generate-callframe-op $pc directMakeArray $res $ary } variable { set var [my index-to-var [lindex $insn 1]] set name [list temp [incr depth -1]] - my quads [lindex $insn 0] {temp @callframe} {temp @callframe} \ + my quads [lindex $insn 0] $cf $cf \ [list literal [lindex $var 1]] $name - my quads retrieveResult {temp @exception} {temp @callframe} - my quads extractCallFrame {temp @callframe} {temp @callframe} + my quads retrieveResult {temp @exception} $cf + my quads extractCallFrame $cf $cf my generate-jump [my exception-target $pc catch] \ maybe {temp @exception} } nsupvar - upvar { set var [my index-to-var [lindex $insn 1]] set name [list temp [incr depth -1]] set context [list temp [incr depth -1]] - my quads [lindex $insn 0] {temp @callframe} {temp @callframe} \ + my quads [lindex $insn 0] $cf $cf \ [list literal [lindex $var 1]] $context $name - my quads retrieveResult {temp @exception} {temp @callframe} - my quads extractCallFrame {temp @callframe} {temp @callframe} + my quads retrieveResult {temp @exception} $cf + my quads extractCallFrame $cf $cf my generate-jump [my exception-target $pc catch] \ maybe {temp @exception} } currentNamespace { my quads copy [list temp $depth] \ @@ -1327,15 +1433,15 @@ infoLevelArgs { set value [list temp [incr depth -1]] set r [list temp $depth] my generate-arith-domain-check $pc [lindex $insn 0] $value my quads purify {temp opd0} $value - my error-quads $pc frameArgs $r {temp opd0} {temp @callframe} + my error-quads $pc frameArgs $r {temp opd0} $cf } infoLevelNumber { set r [list temp $depth] - my quads frameDepth $r {temp @callframe} + my quads frameDepth $r $cf } expandStart { # do nothing } expandStkTop { @@ -1349,13 +1455,13 @@ set qd {} for {set i $depthWas} {$i < $depth} {incr i} { lappend qd [list temp $i] } my quads \ - invokeExpanded {temp @callframe} {temp @callframe} {*}$qd - my quads retrieveResult {temp @exception} {temp @callframe} - my quads extractCallFrame {temp @callframe} {temp @callframe} + invokeExpanded $cf $cf {*}$qd + my quads retrieveResult {temp @exception} $cf + my quads extractCallFrame $cf $cf my generate-jump [my exception-target $pc catch] maybe \ {temp @exception} my quads extractMaybe $result {temp @exception} } default { @@ -1369,16 +1475,16 @@ if {[dict exists $fixup -1]} { foreach q [dict get $fixup -1] { lset quads $q 1 [list pc [llength $quads]] } - # let the flow analysis figure out whether this is confluent! - # lappend quads confluence + # spoil errorCode and errorInfo + my quads startCatch $cf $cf my quads returnCode [set code [list temp 0]] {temp @exception} my quads procLeave $code $code \ [list literal [namespace tail $originProc]] - my quads return {} {temp @callframe} $code + my quads return {} $cf $code dict unset fixup -1 } if {[dict size $fixup] > 0} { error "Failed to fix jumps at [join [dict keys $fixup] ,]" } @@ -1428,11 +1534,11 @@ set varIndex [string range $varIndex 1 end] } lassign [lindex [dict get $bytecode variables] $varIndex] flags name if {"temp" in $flags} { # Variable name is not legal for Tcl scalar local variables - return [list var ($varIndex)] + return [list temp @var$varIndex] } return [list var $name] } # exception-target -- @@ -1544,10 +1650,29 @@ my quads jump[string totitle $type] $target $var } else { my quads jump $target } } + +# generate-move-from-callframe -- +# +# Generates a 'moveFromCallFrame' instruction for a given variable. +# +# Parameters: +# var - Variable to load +# +# Results: +# None. +# +# Side effects: +# Emits the quad + +oo::define quadcode::transformer method generate-move-from-callframe {var} { + if {[lindex $var 0] ne "var"} return + my quads moveFromCallFrame $var {temp @callframe} \ + [list literal [lindex $var 1]] +} # generate-existence-check -- # # Generates a check to make sure that a variable exists, and # appends it to the list of quadcodes being built. Do not call from @@ -1615,10 +1740,18 @@ # None. # # Side effects: # Emits a sequence that tests the variable's type and throws the # requested error if it is incorrect. +# +# Notes: +# A variable that does not exist will pass both the scalar check +# and the array check. +# When writing a variable, the check will determine +# whether write will succeed or be rejected. +# When reading a variable, these checks must be paired with an +# existence check. oo::define quadcode::transformer method generate-array-check {pc var idx error msg} { set varname [lindex $var 1] ; # Name of the variable being checked @@ -1832,10 +1965,39 @@ my quads [list purifyParam $i] $val $val $functionName # 6 # (next instruction) } + return +} + +# update-in-callframe -- +# +# Generates code to update a variable's value in the callframe. +# +# Parameters: +# args - Alternating list of variables names and variable values +# +# Results: +# None. +# +# Side effects: +# Emits `moveToCallFrame`. + +oo::define quadcode::transformer method update-in-callframe {args} { + set q {moveToCallFrame {temp @callframe} {temp @callframe}} + set need 0 + foreach {name value} $args { + if {[lindex $value 0] eq "var"} { + lappend q $name $value + set need 1 + } + } + if {$need} { + my quads {*}$q + } + return } # quads -- # # Generate the given quadcode. @@ -1870,17 +2032,42 @@ oo::define quadcode::transformer method error-quads {pc opcode result args} { my quads $opcode {temp @exception} {*}$args set target [my exception-target $pc catch] my generate-jump $target maybe {temp @exception} - my quads extractMaybe {temp @exception} {temp @exception} - my quads copy $result {temp @exception} + my quads extractMaybe $result {temp @exception} return } + +# callframe-error-quads -- +# +# Generate the given quadcode, and the sequence that intercepts +# its errors and unpacks its (callframe, maybe result} tuple. +# +# Parameters: +# pc - Program counter from the original bytecode +# opcode - Opcode being emitted +# result - Result of the operation, which must be CALLFRAME FAIL SOMETHING +# args - Inputs to the operation. +# +# Results: +# None + +oo::define quadcode::transformer method callframe-error-quads {pc opcode result + args} { + + my quads $opcode {temp @tuple} {temp @callframe} $args + my quads extractCallFrame {temp @callframe} {temp @tuple} + my quads retrieveResult {temp @exception} {temp @tuple} + set target [my exception-target $pc catch] + my generate-jump $target maybe {temp @exception} + my quads extractMaybe $result {temp @exception} + +} # interp alias {} tcl::mathfunc::istype {} ::dataType::isa # Local Variables: # mode: tcl # fill-column: 78 # auto-fill-function: nil # End: Index: quadcode/types.tcl ================================================================== --- quadcode/types.tcl +++ quadcode/types.tcl @@ -409,11 +409,11 @@ # Initialize all types to BOTTOM set types {} dict for {v -} $udchain { dict set types $v $BOTTOM } - dict set types return $BOTTOM + dict set types return $FAIL # Put all basic blocks on the worklist for processing in depth-first # order set worklist {} for {set b [expr {[llength $bbcontent]-1}]} {$b >= 0} {incr b -1} { @@ -426,12 +426,13 @@ set b [lindex $worklist end] set worklist [lrange $worklist[set worklist {}] 0 end-1] set content [lindex $bbcontent $b] # Process instructions in each block from top to bottom - set pc 0 + set pc -1 foreach q $content { + incr pc my debug-inferTypes { puts "$b:$pc: $q" } switch -exact -- [lindex $q 0] { return { @@ -447,10 +448,12 @@ if {[lindex $rvar 0] in {"var" "temp"}} { set type [my typeOfResult $q] if {$type != [dict get $types $rvar]} { my debug-inferTypes { puts " $rvar: [nameOfType $type]" + puts " was [nameOfType \ + [dict get $types $rvar]]" } dict set types $rvar $type if {[dict exists $duchain $rvar]} { dict for {use -} [dict get $duchain $rvar] { set idx [lsearch -sorted -integer \ @@ -512,11 +515,11 @@ narrowToType { set targetTypeCode [lindex $q 0 1] return [quadcode::dataType::typeIntersect $targetTypeCode \ [typeOfOperand $types [lindex $q 2]]] } - entry { + entry - extractCallFrame { return $CALLFRAME } param { if {[lindex $q 2 1] < [llength $ptype]} { return [lindex $ptype [lindex $q 2 1]] @@ -579,11 +582,11 @@ strlen - strrfind - frameDepth { return $INT } - copy { + copy - startCatch { return [typeOfOperand $types [lindex $q 2]] } purify { return [expr {[typeOfOperand $types [lindex $q 2]] & ~$IMPURE}] } @@ -698,24 +701,17 @@ # We can eliminate callframe in a smaller set of cases than # with 'invoke' - but punt for now. set inty [typeOfOperand $types [lindex $q 2]] return [expr {($inty & $CALLFRAME) | $FAIL | $STRING}] } - callFrameNop - startCatch { - return $CALLFRAME - } nsupvar - upvar - variable { return [expr {$CALLFRAME | $ZEROONE | $FAIL}] } retrieveResult { # Pull from the callframe of the earlier 'invoke' return [expr {[typeOfOperand $types [lindex $q 2]] & ~$CALLFRAME}] } - extractCallFrame { - # Trim the non-callframe part - return $CALLFRAME - } list - unshareList - result - returnOptions - dictIterKey - dictIterValue - concat - strcat - strmap - strtrim - strcase { return $STRING @@ -861,10 +857,24 @@ default { error "What is the type of $opd in [info level -1]?" } } } + +# oo::transformer method typeOfOperand -- +# +# Looks up the type of an operand +# +# Parameters: +# opd - Operand to query +# +# Results: +# Returns the type code + +oo::define quadcode::transformer method typeOfOperand {opd} { + return [quadcode::typeOfOperand $types $opd] +} # typeOfLiteral -- # # Determines whether a literal represents a number, and returns # its type. Index: quadcode/upvar.tcl ================================================================== --- quadcode/upvar.tcl +++ quadcode/upvar.tcl @@ -186,11 +186,10 @@ # {nonlocal} - The variable may be in the callframe of an # outer caller, so calling this procedure might # have nonlocal effects. # # Operations that change the aliasing status of one or more variables: -# callFrameNop # extractCallFrame # moveToCallFrame # Do noting about aliasing, simply copy the aliasing information from # the source callframe to the destination callframe. # entry - @@ -244,14 +243,12 @@ # resFrame, if set is the alias info for the new quad. unset -nocomplain resFrame # Analyze individual quads switch -exact -- [lindex $opcode 0] { - callFrameNop - extractCallFrame - - invoke - - startCatch { + invoke { # These instructions do not change aliases, so copy # the input frame to the result frame. if {![dict exists $aliasInfo $arg1]} { set resFrame {} @@ -441,13 +438,13 @@ # # Determines the effect of a procedure on the outer callframes of # the stack. # # Parameters: -# state - Dictionaries whose keys are the names of quadcode variables -# that designate callframes, and whose values are the possible -# aliases of the variables in outer frames. +# aliasInfo - Dictionaries whose keys are the names of quadcode variables +# that designate callframes, and whose values are the possible +# aliases of the variables in outer frames. # # Results: # Returns a dictionary that characterizes the code's effect. oo::define quadcode::transformer method upvarProcEffect {aliasInfo} { @@ -481,11 +478,12 @@ switch -exact -- [lindex $q 0] { "directArrayExists" - "directArrayGet" - "directExists" - - "directGet" { + "directGet" - + "directIsArray" { dict set result readsGlobal {} dict unset result pure } "directAppend" - @@ -501,10 +499,11 @@ dict set result writesGlobal {} dict unset result pure dict unset result killable } + "directMakeArray" - "directSet" { dict set result writesGlobal {} dict unset result pure dict unset result killable } @@ -563,10 +562,18 @@ my diagnostic error $b $pc [dict get $attrs error] dict unset attrs error } my upvarInvoke result $aliasInfo $attrs $q $typeList } + + "startCatch" { + # Any procedure that does a [catch] implicitly writes + # ::errorInfo and ::errorCode. It's insane to alias these, + # but someone probably does, so indicate that this proc + # writes globals. + dict set result writesGlobal {} + } } my debug-upvar { if {$did} { Index: quadcode/varargs.tcl ================================================================== --- quadcode/varargs.tcl +++ quadcode/varargs.tcl @@ -29,14 +29,12 @@ # This pass presumes that the quadcode is partitioned into basic blocks, # and that SSA conversion has been run (so a constant procedure name # will have propagated into 'invoke' instructions. It also presumes # that procedure names have been resolved into the fully qualified names. # -# This pass introduces temporaries, but only locally to basic blocks, -# so it does not require elaborate rewriting of SSA form. It must run -# prior to parameter type checking (including the 'rewriteParamChecks' -# peephole). +# This pass must run prior to parameter type checking (including the +# 'rewriteParamChecks' peephole). # # There is a hidden assumption in this method that default args are # always of acceptable type - and so type checks need not be # emitted for default parameters. (There is major rethinking needed # if this ever might not be the case.) @@ -61,20 +59,17 @@ incr pc # At this point in optimization, all invokes are part of a # sequence that is followed within a few instructions by a # jumpMaybe, so there can never be more than one in a basic - # block. Since rewriting invocations can peform major surgery - # on the program, simply call out to the appropriate handling - # routine and 'break' to the next basic block. - + # block. switch -exact [lindex $q 0] { "invoke" - "invokeExpanded" { my debug-varargs { puts "varargs: examine $b:$pc: $q" } - my varargsRewriteInvoke $b $pc $q + my va_RewriteInvoke $b $pc $q break } } } } @@ -82,13 +77,18 @@ my debug-varargs { puts "After variadic call replacement:" my dump-bb } + my debug-audit { + my audit-phis varargs + my audit-duchain varargs + } + } -# quadcode::transformer method varargsRewriteInvoke -- +# quadcode::transformer method va_RewriteInvoke -- # # Rewrites 'invoke' and 'invokeExpanded' instructions to accommodate # compiled procs that accept variable numbers of arguments without going # through a call thunk or losing data type information. # @@ -101,715 +101,629 @@ # None. # # Side effects: # Rewrites the instruction and 'expand' instructions that it # uses. Updates ud- and du-chains. -# -# We actually have to work on a whole code burst here. What we need to -# consider is a sequence like -# -# (may be omitted) moveToCallFrame cf1 cf0 name0 var0 name1 var1 ... -# invokeExpanded res0 cf1 command args... -# (may be omitted) retrieveResult res1 res0 -# (may be omitted) extractCallframe cf2 res0 -# (zero or more) moveFromCallFrame var cf2 name -# jumpMaybe catchHandler res1 -# jump normalReturn -# -# The reason is that there is a considerable amount of logic in -# optimization and code generation that isn't prepared to have -# a moveFromCallFrame's callframe argument be the result of a phi. -# (There are places where the optimizer needs to track moveFromCallFrame -# back to a unique 'invoke' or other callframe-altering operation). -# -# What we want the result to look like: -# -# (... code to unpack arguments. Normal exit is bbNormal. Wrong -# number of args exit is bbWrong.) -# -# bbNormal: -# moveToCallFrame cf3 cf0 name0 var0 name1 var1 ... -# invoke res2 cf3 command args ... -# retrieveResult res3 res2 -# extractCallframe cf4 res3 -# moveFromCallFrame var' cf4 name (zero or more) -# jumpMaybe bb0 res3 -# jump bb1 -# -# bbWrong: -# (no need for moveToCallFrame) -# invokeExpanded res4 Nothing command originalArgs... -# (no need for callframe manipulation) -# jumpMaybe bb0 res4 -# jump bb1 (this jump is never taken, the 'invokeExpanded' always errors -# out in this case). -# -# bb0: -# cf2* = phi(cf4 [bbNormal], cf0 [bbWrong]) -# res1* = phi(res3 [bbNormal], res4 [bbWrong]) -# zero or more: -# var* = phi(var' [bbnormal], var' reaching def [bbWrong]) -# jump catchHandler -# -# bb1: -# cf2** = phi(cf4 [bbNormal], cf0 [bbWrong]) -# res1** = phi(res3 [bbNormal], res4 [bbWrong]) -# zero or more: -# var** = phi(var' [bbnormal], var' reaching def [bbWrong]) -# jump normalReturn -# -# Then, cf2*/cf2**, res1*/res1** and all instances of var*/var** become and -# are treated as duplicate definitions for repairSSAVariable. -# -# Note that the reaching definition of each variable in 'moveFromCallFrame' -# is easily obtained, because it has to be in the 'moveToCallFrame' that -# precedes the 'invokeExpanded'. - -oo::define quadcode::transformer method varargsRewriteInvoke {b pc q} { - - set newqds {} - - # Take apart the quad - set argv [lassign $q opcode cfout cfin calleeLit] - - # We care only about 'invokeExpanded' operations where the procedure - # name is known a priori, the expected args are known, and - # the target procedure is compiled. - - # TODO: We also care about {*} expansion passed to non-variadic - # Core commands. That will give us information about - # their stack effects. - - if {[lindex $calleeLit 0] ne "literal" - || [catch { - set callee [lindex $calleeLit 1] - info args $callee - } arginfo] - || ![$specializer compiling $callee]} { - - return - } - + +oo::define quadcode::transformer method va_RewriteInvoke {b pc q} { + + # We can process only those sequences where the procedure name is known + # a priori, the expected arguments are known, and the target procedure + # is compiled. BUG - We know the arguments to a great many Core commands + # and need to work with them as well. + lassign [my va_GetArgInfo $q] status arginfo + if {!$status} return my debug-varargs { puts "[my full-name]: $b:$pc: $q" - } - - # Analyze the codeburst that carries out the 'invokeExpanded'. - # This codeburst will run from the 'moveToCallFrame' preceding - # the invocation out to the end of the basic block. - # We will be rewriting it. - - set call [::quadcode::invocationSequence new] - trace add variable call unset [list $call destroy] - $call analyze [self] $b $pc + puts " arginfo = $arginfo" + } # We are going to be doing major surgery on the basic block. # Remove the 'invokeExpanded' and all following instructions # from the block. Unlink the block from its successors, and # remove ud- and du-chaining for the removed instructions. - - set bb [my varargsUnlinkTail $b [$call pc0]] - - # Create the basic blocks for the actual invocation sequences. We make - # them in advance to avoid backpatching. - # Blocks 'err0b', 'norm0b', 'err1b' and 'norm1b' will be empty and are - # present in order to split critical edges. - - set norm0b [llength $bbcontent] - lappend bbcontent {}; lappend bbpred {} - set err0b [llength $bbcontent] - lappend bbcontent {}; lappend bbpred {} - set notokb [llength $bbcontent] - lappend bbcontent {}; lappend bbpred {} - set norm1b [llength $bbcontent] - lappend bbcontent {}; lappend bbpred {} - set err1b [llength $bbcontent] - lappend bbcontent {}; lappend bbpred {} - set normb [llength $bbcontent] - lappend bbcontent {}; lappend bbpred {} - set normphis {} - set errorb [llength $bbcontent] - lappend bbcontent {}; lappend bbpred {} - set errorphis {} - - # Create the first part of the 'invoke' instruction - set invokeres [my newVarInstance $cfin] - set newq [list invoke $invokeres $cfin $calleeLit] - - # Generate code for the 'wrong # args' case - set notokbb {} - set invexpres [my newVarInstance [$call retval]] - foreach qq [my varargsEmitWrongArgs $invexpres {} Nothing $calleeLit] { - my varargsEmitAndTrack $notokb notokbb $qq - } - dict set normphis [$call retval] [list bb $norm1b] $invexpres - dict set errorphis [$call retval] [list bb $err1b] $invexpres - dict set normphis [$call cfout] [list bb $norm1b] [$call cfin] - dict set errorphis [$call cfout] [list bb $err1b] [$call cfin] - my varargsEmitAndTrack $notokb notokbb \ - [list jumpMaybe [list bb $err1b] $invexpres] - my varargsEmitAndTrack $notokb notokbb [list jump [list bb $norm1b]] - lset bbcontent $notokb $notokbb - - # Split the critical edges - foreach {edge target} [list $norm0b $normb $err0b $errorb \ - $norm1b $normb $err1b $errorb] { - set splitbb {} - my varargsEmitAndTrack $edge splitbb [list jump [list bb $target]] - lset bbcontent $edge $splitbb - } - - # Now start the parameter checking logic - + set bb [my va_UnlinkTail $b $pc] + set B [quadcode::builder new [self] $b [lindex $bbcontent $b]] + + # Prepare parameters for the 'invoke' (or 'invokeExpanded') call, and + # add the call to the instruction sequence under construction. + set newq [my va_PrepareArgs $B $b $pc $q $arginfo] + + # Emit the call + $B emit $newq + my debug-varargs { + $B log-last + } + + # Check that the return value from the invoke is linked correctly, and + # bring in the 'retrieveResult' + set q1 [lindex $bb 0] + my debug-varargs { + puts "varargs: result retrieval: $q1" + } + if {[lindex $q1 0] ne "retrieveResult" || [lindex $q1 2] ne [lindex $q 1]} { + error "mislinked invoke: should be followed with 'retrieveResult'" + } + set result [lindex $q1 1] + $B emit [list retrieveResult [$B maketemp "result"] [lindex $newq 1]] + my debug-varargs { + $B log-last + } + + # Check that the extractCallFrame is linked correctly, and bring in + # the 'extractCallFrame' + set q2 [lindex $bb 1] + my debug-varargs { + puts "varargs: callframe extraction: $q2" + } + if {[lindex $q2 0] ne "extractCallFrame" + || [lindex $q2 2] ne [lindex $q 1]} { + error "mislinked invoke: should be followed with 'extractCallFrame'" + } + set cf [lindex $q2 1] + $B emit [list extractCallFrame [$B maketemp "callframe"] [lindex $newq 1]] + my debug-varargs { + $B log-last + } + + set cfin [lindex $newq 2] + my va_ConvergeErrorPath $B $result $cf $cfin [lreplace $bb[set bb ""] 0 1] + + $B destroy + + return +} + +# quadcode::transformer method va_GetArgInfo -- +# +# Determines the target of an invocation and performs [info args] on +# that target to get its argument list. +# +# Parameters: +# q - Quadcode 'invoke' or 'invokeExpanded' instruction +# +# Results: +# Returns [list 1 $arglist] if the callee is known and [info args] +# succeeds. Returns [list 0 {}] for an unknown callee or one whose +# expected args are unknown. + +oo::define quadcode::transformer method va_GetArgInfo {q} { + + set cmd [lindex $q 3] + my debug-varargs { + puts "varargs: callee is $cmd" + } + if {[lindex $cmd 0] ne "literal"} { + my debug-varargs { + puts "varargs: command name is not literal, do not rewrite" + } + return {0 {}} + } + if {[catch {info args [lindex $cmd 1]} arginfo]} { + my debug-varargs { + puts "varargs: do not rewrite [lindex $cmd 1]: $arginfo" + } + return {0 {}} + } + if {![$specializer compiling [lindex $cmd 1]]} { + my debug-varargs { + puts "varargs: do not rewrite [lindex $cmd 1], it's not compiled." + } + return {0 {}} + } else { + return [list 1 $arginfo] + } +} + +# quadcode::transformer method va_UnlinkTail -- +# +# Removes the invocation sequence from a basic block in preparation +# for rewriting it. +# +# Parameters: +# b - Number of the basic block +# pc - Program counter of the first instruction being deleted +# +# Results: +# Returns the partial basic block that remains. +# +# Side effects: +# Variable defs and uses in the invocation sequence are removed +# from ud- and du-chains. The basic block is unlinked from its +# successors. + +oo::define quadcode::transformer method va_UnlinkTail {b pc} { + + set bb [lindex $bbcontent $b] + lset bbcontent $b {} + my debug-varargs { + puts "varargs: Split basic block $b:" + puts " $b:$pc: [lindex $bb $pc]" + } + + set tail [lrange $bb $pc end] + set bb [lreplace $bb[set bb {}] $pc end] + lset bbcontent $b $bb + foreach q $tail { + if {[lindex $q 1 0] in {"temp" "var"}} { + dict unset udchain [lindex $q 1] + } + foreach arg [lrange $q 2 end] { + if {[lindex $arg 0] in {"temp" "var"}} { + my removeUse $arg $b + } + } + } + foreach b2 [my bbsucc $b] { + my removePred $b2 $b + } + + return [lreplace $tail[set tail {}] 0 0] +} + +# quadcode::transformer method va_PrepareArgs -- +# +# Emits code to prepare the arguments for an 'invoke' or +# 'invokeExpanded' command, up to the point where the actual +# 'invoke' is issued. +# +# Parameters: +# B - quadcode::builder where the new invocation sequence is being built. +# b - Basic block where the original 'invoke' instruction resided +# pc - Program counter within the basic block +# q - 'invoke' or 'invokeExpanded' instruction. +# arginfo - Arguments expected by the invoked command +# +# Results: +# Returns the rewritten 'invoke' instruction +# +# Side effects: +# Emits code so that the args off the rewritten instruction are +# known to be available. May emit error handling code, qin which +# case the following locations will be known to $B: +# block 'error' - The block to which control transfers on +# an error +# value 'error' - The FAIL value that is used to report an error +# The callframe on error is always the callframe input to the 'invoke' +# instruction. +# +# The command name being invoked, and the expected arguments, are always known +# at this point. + +oo::define quadcode::transformer method va_PrepareArgs {B b pc q arginfo} { + + set argl [lassign $q opcode result cfin cmd] + set callee [lindex $cmd 1] + + # Create the first part of the 'invoke' instruction. + + set iresult [my newVarInstance $result] + set newq [list invoke $iresult $cfin $cmd] + + # Find out how many plain parameters (that is, not 'args') the + # called command has. set nPlainParams [llength $arginfo] set haveargs 0 if {[lindex $arginfo end] eq "args"} { set haveargs 1 incr nPlainParams -1 } - # Start by matching off non-expanded args with parameters in the callee - + # Any leading plain arguments that do not have {*} can simply be retained + # in the parameter list of [invoke]. + # $pos will be the position in the parameter list of the first + # parameter that needs special handling. + set argl [lrange $q 4 end] set pos 0 + my debug-varargs { + puts "varargs: pos = $pos (of $nPlainParams)" + puts " argl = $argl" + } while {$pos < $nPlainParams} { - if {[my varargsNonExpandedArgument newq $arginfo $pos $q]} break + if {[my va_NonExpandedArgument newq $arginfo $pos $argl]} break incr pos } - # Concatenate the remaining args into a list. 'listLoc' will - # be the name of the object that holds the list. my debug-varargs { - puts "varargs: $b:$pc: $q:\n\ - \ Matched leading non-expanded args.\ - $pos of $nPlainParams plain params" + puts "varargs: $b:$pc: matched $pos out of $nPlainParams\ + leading non-expanded arg(s)." } - set tempIndex -1 - set listLoc [my varargsExpandFixed bb tempIndex pos $b $q] + + # Generate code to make the rest of the args into a list + set mightThrow [my va_MakeArgList $B $argl $pos $cfin] # We are going to need the length of the list, so # extract that now. (If it turns out somehow that we # don't use it, 'deadvars' will get rid of this, anyway.) - set lenLoc1 [my newVarInstance [list temp [incr tempIndex]]] - set lenLoc [my newVarInstance [list temp $tempIndex]] - my varargsEmitAndTrack $b bb [list listLength $lenLoc1 $listLoc] - my varargsEmitAndTrack $b bb [list extractMaybe $lenLoc $lenLoc1] + set lenLoc1 [my newVarInstance {temp @arglen}] + set lenLoc [$B maketemp arglen] + $B emit [list listLength $lenLoc1 [$B gettemp arglist]] + my debug-varargs { + $B log-last + } + if {$mightThrow} { + my va_MakeErrorCheck $B $lenLoc1 + set mightThrow 0 + } + $B emit [list extractMaybe $lenLoc $lenLoc1] + my debug-varargs { + $B log-last + } + # Count the mandatory args - set firstMandatory $pos while {$pos < $nPlainParams} { + my debug-varargs { + puts "varargs: does arg $pos: \"[lindex $arginfo $pos]\"\ + have a default?" + } if {[info default $callee [lindex $arginfo $pos] defaultVal]} { + my debug-varargs { + puts " yes: \"defaultVal\"" + } break } incr pos } + my debug-varargs { + puts "varargs: first optional arg is at position $pos" + } set firstOptional $pos - set compTemp [list temp [incr $tempIndex]] - set nMandatory 0 if {$firstOptional > $firstMandatory} { - # Make code to check length of arg list, starting a - # new basic block + # Make code to check length of arg list set nMandatory [expr {$firstOptional - $firstMandatory}] - set b [my varargsCheckEnough $b $bb $lenLoc $compTemp \ - $nMandatory $notokb] - set bb {} + my va_CheckEnough $B $callee $nMandatory # Make code to transfer mandatory args - my varargsUnpackMandatory tempIndex bb newq $b $listLoc $nMandatory + set newq [my va_UnpackMandatory $B $newq $nMandatory] } # Now we have the parameters that have default values. set j $nMandatory if {$nPlainParams > $firstOptional} { # Emit a code burst for each optional parameter to # check the list length and extract the parameter - set optInfo {} - set finishB [llength $bbcontent] - lappend bbcontent {} - lappend bbpred {} set i $firstOptional + while {$i < $nPlainParams} { + info default $callee [lindex $arginfo $i] defaultVal - lassign [my varargsUnpackOptional tempIndex b bb \ - $finishB $compTemp $listLoc $lenLoc $j] \ - fromBlock argLoc + + my debug-varargs { + puts "Emit length check and extraction for optional param \ + $i: [lindex $arginfo $i] (default=$defaultVal)" + } + lassign [my va_UnpackOptional $B $j] fromBlock argLoc lappend optInfo [list $fromBlock $defaultVal $argLoc] incr i incr j } # Close out the last basic block, switch to the 'finish' block # and emit 'phi' instructions to get the correct parameter set - my varargsFinishOptional b bb newq $finishB $optInfo + set newq [my va_FinishOptional $B $newq $optInfo] } # If the procedure has 'args', then fill it in with the remainder of the # arg list. if {$haveargs} { - my varargsDoArgs tempIndex $b bb newq $listLoc $j + my va_DoArgs $B newq $j } else { - my varargsCheckTooMany b bb $lenLoc $compTemp $j $notokb - } - - # Create the normal invocation sequence. - # 1. Create moveToCallFrame - - set cfin [$call cfin] - set invars [$call invars] - if {[$call pc0] < $pc} { - set cf2 [my newVarInstance $cfin] - set q2 [list moveToCallFrame $cf2 $cfin] - dict for {vname val} $invars { - lappend q2 [list literal $vname] $val - } - my varargsEmitAndTrack $b bb $q2 - set cfin $cf2 - lset newq 2 $cfin - } - - # 2. Emit the call as rewritten - my varargsEmitAndTrack $b bb $newq - - # 3. Make the 'retrieveResult' - set okresult [my newVarInstance [$call retval]] - my varargsEmitAndTrack $b bb [list retrieveResult $okresult $invokeres] - dict set normphis [$call retval] [list bb $norm0b] $okresult - dict set errorphis [$call retval] [list bb $err0b] $okresult - - # 4. Make the 'extractCallFrame' - set okcf [my newVarInstance [$call cfout]] - my varargsEmitAndTrack $b bb [list extractCallFrame $okcf $invokeres] - dict set normphis [$call cfout] [list bb $norm0b] $okcf - dict set errorphis [$call cfout] [list bb $err0b] $okcf - - # 5. Make 'moveFromCallFrame' for all output values - dict for {vname outval} [$call outvars] { - set okval [my newVarInstance $outval] - my varargsEmitAndTrack $b bb \ - [list moveFromCallFrame $okval $okcf [list literal $vname]] - dict set normphis $outval [list bb $norm0b] $okval - dict set errorphis $outval [list bb $err0b] $okval - set notokval [dict get [$call invars] $vname] - dict set normphis $outval [list bb $norm1b] $notokval - dict set errorphis $outval [list bb $err1b] $notokval - } - - # 6. Make the terminal jumps - my varargsEmitAndTrack $b bb [list jumpMaybe [list bb $err0b] $okresult] - my varargsEmitAndTrack $b bb [list jump [list bb $norm0b]] - - # Emit the final basic block rewrite - - lset bbcontent $b $bb - - # toRepair will have the variables that have to be fixed up by - # repairSSAVariable after this stuff runs - set toRepair {} - - # Make the block for the normal exit - set normbb {} - foreach {v sources} $normphis { - set val 0 - if {[dict exists $toRepair $v $normb]} { - set val [dict get $toRepair $v $normb] - } - incr val - dict set toRepair $v $normb $val - my varargsEmitAndTrack $normb normbb [list phi $v {*}$sources] - } - my varargsEmitAndTrack $normb normbb [list jump [list bb [$call normexit]]] - lset bbcontent $normb $normbb - - # Make the block for the error exit - set errorbb {} - foreach {v sources} $errorphis { - set val 0 - if {[dict exists $toRepair $v $errorb]} { - set val [dict get $toRepair $v $errorb] - } - incr val - dict set toRepair $v $errorb $val - my varargsEmitAndTrack $errorb errorbb [list phi $v {*}$sources] - } - my varargsEmitAndTrack $errorb errorbb [list jump [list bb [$call errexit]]] - lset bbcontent $errorb $errorbb - - # Restore dominance relationships - my bbidom; my bblevel - - my debug-varargs { - puts "Before repairing SSA relationships:" - my dump-bb - } - - # Repair variable relationships that have been damaged - dict for {v defs} $toRepair { - my debug-varargs { - puts "Replace $v with reaching definitions $defs" - } - my repairSSAVariable $v $defs - my debug-varargs { - puts "Replaced $v" - } - } - - my debug-varargs { - puts "After repairing SSA relationships:" - my dump-bb - } - - return -} - -# quadcode::transformer method varargsUnlinkTail -- -# -# Takes the last few instructions of a basic block and removes -# them temporarily, unlinking the block from its successors and -# the instructions from their ud- and du-chains. -# -# Parameters: -# b - Number of the basic block -# pc - Program counter of the first instruction being deleted -# -# Results: -# Returns the partial basic block that remains -# -# Side effects: -# Linkages are destroyed. - -oo::define quadcode::transformer method varargsUnlinkTail {b pc} { - set bb [lindex $bbcontent $b] - set head [lrange $bb 0 [expr {$pc-1}]] - set tail [lrange $bb $pc end] - foreach q $tail { - if {[lindex $q 1 0] in {"temp" "var"}} { - dict unset udchain [lindex $q 1] - } - foreach arg [lrange $q 2 end] { - if {[lindex $arg 0] in {"temp" "var"}} { - my removeUse $arg $b - } - } - } - foreach b2 [my bbsucc $b] { - my removePred $b2 $b - } - - lset bbcontent $b $head - - return $head -} - -# quadcode::transformer method varargsNonExpandedArgument -- + my va_CheckTooMany $B $callee $j + } + + return $newq +} + +# quadcode::transformer method va_NonExpandedArgument -- # # Transfer a leading non-expanded argument into a quad # under construction when rewriting 'invokeExpanded' # # Parameters: # newqVar - Name of a variable in caller's scope storing the # plain 'invoke' operation under construction # arginfo - Result of [info args] against the invoked proc # pos - Position of the argument (0 = first) in the argument list -# q - Quadruple under construction +# argl - Argument list of the 'invoke' or 'invokeExpanded' instruction # # Results: # Returns 0 if the parameter was transferred, 1 if we are at the # end of the possible static transfers. -oo::define quadcode::transformer method \ - varargsNonExpandedArgument {newqVar arginfo pos q} { - - upvar 1 $newqVar newq - - set param [lindex $arginfo $pos] - set arg [lindex $q [expr {4 + $pos}]] - switch -exact -- [lindex $arg 0] { - "literal" { - } - "temp" - "var" { - lassign [my findDef $arg] defb defpc defstmt - if {[lindex $defstmt 0] eq "expand"} { - return 1 - } - } - default { - return 1 - } - } - lappend newq $arg - return 0 - } - -# quadcode::transformer method varargsExpandFixed -- +oo::define quadcode::transformer method va_NonExpandedArgument {newqVar arginfo + pos argl} { + + upvar 1 $newqVar newq + + # If the list is exhausted, return. + if {$pos >= [llength $argl]} { + return 1 + } + + # Extract the parameter and its name + set param [lindex $arginfo $pos] + set arg [lindex $argl $pos] + my debug-varargs { + puts "varargs: transfer actual arg [list $arg] into formal arg\ + \"$param\"" + } + + # Quit at the first {*} expansion or on a parameter that is not understood + switch -exact -- [lindex $arg 0] { + "literal" { + } + "temp" - "var" { + lassign [my findDef $arg] defb defpc defstmt + if {[lindex $defstmt 0] eq "expand"} { + return 1 + } + } + default { + return 1 + } + } + + # Put the parameter on the new 'invoke' instruction + lappend newq $arg + return 0 +} + +# quadcode::transformer method va_MakeArgList -- # # Takes the non-fixed-position arguments of 'invokeExpanded' # and emits code to make them into a list. # # Parameters: -# bbVar - Variable in caller holding the basic block under construction -# tempIdxVar - Variable in caller holding the number of the last -# temporary allocated. -# posVar - Position in the parameter list where the list construction -# should begin. -# b - Basic block number of the block under construction -# q - 'invokeExpanded' instruction being deconstructed -# -# Results: -# -# Returns the name of a variable, temporary or literal that holds the -# expanded list. - -oo::define quadcode::transformer method \ - varargsExpandFixed {bbVar tempIdxVar posVar b q} { - - upvar 1 $bbVar bb $tempIdxVar tempIndex $posVar pos - - set listTemp [list temp [incr tempIndex]] - - # Handle the first arg. Since 'invokeExpanded' always - # has at least one expanded arg, there has to be a first - # arg. - if {4 + $pos >= [llength $q]} { - set listLoc "literal {}" - } else { - set arg [lindex $q [expr {4 + $pos}]] - switch -exact -- [lindex $arg 0] { - "literal" { - set listLoc [my newVarInstance $listTemp] - my varargsEmitAndTrack $b bb [list list $listLoc $arg] - } - "temp" - "var" { - lassign [my findDef $arg] defb defpc defstmt - if {[lindex $defstmt 0] eq "expand"} { - set listLoc [lindex $defstmt 2] - } else { - set listLoc [my newVarInstance $listTemp] - my varargsEmitAndTrack $b bb [list list $listLoc $arg] - } - } - } - } - - # listLoc now is holding the location of the list under - # construction. Concatenate the remaining params onto it. - - foreach arg [lrange $q [expr {5 + $pos}] end] { - - # Do we need to expand this arg? - switch -exact -- [lindex $arg 0] { - "literal" { - set op listAppend - } - "temp" - "var" { - lassign [my findDef $arg] defb defpc defstmt - if {[lindex $defstmt 0] eq "expand"} { - set op listConcat - } else { - set op listAppend - } - } - } - - # Make variable to hold Maybe result from the concatenation, - # and emit the concatenation. - # This can't fail, $listTemp is known to be a list - set nloc [my newVarInstance $listTemp] - my varargsEmitAndTrack $b bb [list $op $nloc $listLoc $arg] - - # extract the result from the Maybe - set listLoc [my newVarInstance $listTemp] - my varargsEmitAndTrack $b bb [list extractMaybe $listLoc $nloc] - } - - return $listLoc - } - -# quadcode::transformer method varargsCheckEnough -- -# -# Emits code to check for too few args passed to invokeExpanded -# -# Parameters: -# b - Basic block number under construction -# bb - Instructions in the block -# lenLoc - Location holding the length of the arg list -# compTemp - Temporary variable name to use for comparison -# nMandatory - Number of mandatory args still unpaired -# errorB - Basic block to jump to if too few args -# -# Results: -# Returns the new basic block number; this method ends the block. - -oo::define quadcode::transformer method varargsCheckEnough {b bb lenLoc compTemp - nMandatory errorB} { - # Emit {$nMandatory > $lenLoc} - set compLoc [my newVarInstance $compTemp] - my varargsEmitAndTrack $b bb \ - [list gt $compLoc [list literal $nMandatory] $lenLoc] - - # Emit jumpTrue to the error block. This has to go through an - # intermediate block because it will be a critical edge otherwise. - # Emit jump to the following block - set intb [llength $bbcontent] - lappend bbcontent {} - lappend bbpred {} - set newb [llength $bbcontent] - lappend bbcontent {} - lappend bbpred {} - - my varargsEmitAndTrack $b bb [list jumpTrue [list bb $intb] $compLoc] - my varargsEmitAndTrack $b bb [list jump [list bb $newb]] - - lset bbcontent $b $bb - set bb {} - - # Emit the intermediate jump - my varargsEmitAndTrack $intb bb [list jump [list bb $errorB]] - lset bbcontent $intb $bb - set bb {} - - return $newb -} - -# quadcode::transformer method varargsUnpackMandatory -- +# B - quadcode::builder that is rewriting the invocation sequence. +# argl - Argument list being analyzed +# pos - Position in the argument list +# cfin - Callframe input to the 'invoke' instruction. +# +# Results: +# +# Returns 1 if it is possible that the argument list is a non-list, +# and 0 otherwise. + +oo::define quadcode::transformer method va_MakeArgList {B argl pos cfin} { + + my debug-varargs { + puts "varargs: make arg list for [list $argl] from position $pos" + } + + set listLoc [$B maketemp arglist] + + # Handle the first arg. 'listloc' will be the variable holding the + # expanded arglist. 'mightThrow' will be 1 if 'listloc' + # might be a non-list and 0 otherwise. + if {$pos >= [llength $argl]} { + my debug-varargs { + puts "varargs: there are no args to list" + } + $B emit [list copy $listLoc {literal {}}] + my debug-varargs { + $B log-last + } + set mightThrow 0 + } else { + set arg [lindex $argl $pos] + my debug-varargs { + puts "varargs: transfer first arg [list $arg]" + } + switch -exact -- [lindex $arg 0] { + "literal" { + $B emit [list list $listLoc $arg] + my debug-varargs { + $B log-last + } + set mightThrow 0 + } + "temp" - "var" { + lassign [my findDef $arg] defb defpc defstmt + if {[lindex $defstmt 0] eq "expand"} { + my debug-varargs { + puts " (which is expanded!)" + } + $B emit [list copy $listLoc [lindex $defstmt 2]] + my debug-varargs { + $B log-last + } + set mightThrow 1 + } else { + my debug-varargs { + puts " (which is not expanded)" + } + $B emit [list list $listLoc $arg] + my debug-varargs { + $B log-last + } + set mightThrow 0 + } + } + } + } + my debug-varargs { + puts "varargs: transferred first arg into [list $listLoc]." + puts " mightThrow = $mightThrow" + } + + # listLoc now holds the location of the list under + # construction. Concatenate the remaining params onto it. + + foreach arg [lrange $argl [expr {1 + $pos}] end] { + + my debug-varargs { + puts "varargs: transfer arg $arg" + } + + # Do we need to expand this arg? + switch -exact -- [lindex $arg 0] { + "literal" { + set op "listAppend" + } + "temp" - "var" { + lassign [my findDef $arg] defb defpc defstmt + if {[lindex $defstmt 0] eq "expand"} { + set op "listConcat" + set mightThrow 1 + } else { + set op "listAppend" + } + } + } + + # Make variable to hold Maybe result from the concatenation, + # and emit the concatenation. + set nloc [$B maketemp arglist] + $B emit [list $op $nloc $listLoc $arg] + my debug-varargs { + $B log-last + } + + # If the concatenation might have failed, emit the error check + if {$mightThrow} { + my va_MakeErrorCheck $B $nloc + set mightThrow 0 + } + + # On normal exit from list construction, extract the result from the + # 'maybe' returned by listAppend or listConcat + set listLoc [$B maketemp arglist] + $B emit [list extractMaybe $listLoc $nloc] + my debug-varargs { + $B log-last + } + } + + my debug-varargs { + puts "varargs: arg list assembled in [$B gettemp arglist]" + puts " mightThrow = $mightThrow" + } + return $mightThrow + +} + +# quadcode::transformer method va_UnpackMandatory -- # # Unpacks the mandatory args to a proc from the list created # by argument expansion # # Parameters; -# tempIdxVar - Variable in caller's scope containing the last -# allocated temporary -# bbVar - Variable in caller's scope containing basic block content -# newqVar - Variable in caller's scope containing the new 'invoke' -# quad being constructed. -# b - Basic block number under construction -# listLoc - Variable or temp holding the list being unpacked +# B - Builder that is emitting quadcode +# newq - 'invoke' instruction under construction # nMandatory - Number of parameters to unpack # # Results: -# None. +# Returns the 'invoke' instruction with the mandatory parameters added. # # Side effects: # Emits code to unpack the mandatory parameters -oo::define quadcode::transformer method varargsUnpackMandatory {tempIdxVar - bbVar newqVar - b listLoc - nMandatory} { - upvar 1 $tempIdxVar tempIdx $bbVar bb $newqVar newq +oo::define quadcode::transformer method va_UnpackMandatory {B newq nMandatory} { + + set arglist [$B gettemp arglist] for {set i 0} {$i < $nMandatory} {incr i} { + + my debug-varargs { + puts "varargs: transfer mandatory argument $i" + } # Emit the 'listIndex' instruction for one arg. It can't fail # because we know we have a list - set argTemp [list temp [incr tempIdx]] - set argLoc [my newVarInstance $argTemp] - my varargsEmitAndTrack $b bb \ - [list listIndex $argLoc $listLoc [list literal $i]] - - # Emit the 'extractMaybe' to get the arg from the Maybe - # result of 'listIndex' - set argLoc2 [my newVarInstance $argTemp] - my varargsEmitAndTrack $b bb [list extractMaybe $argLoc2 $argLoc] + set argtemp [$B maketemp arg$i] + $B emit [list listIndex $argtemp $arglist [list literal $i]] + my debug-varargs { + $B log-last + } + + set argloc [$B maketemp arg$i] + $B emit [list extractMaybe $argloc $argtemp] + my debug-varargs { + $B log-last + } # Put the extracted arg on the 'invoke' instruction - lappend newq $argLoc2 + lappend newq $argloc } + + return $newq } -# quadcode::transformer method varargsUnpackOptional -- +# quadcode::transformer method va_UnpackOptional -- # # Emits code to unpack one optional parameter in an invokeExpanded # # Parameters: -# tempIdxVar - Variable holding the index of the last used temporary -# bVar - Variable holding the current basic block number -# bbVar - Variable holding the content of the basic block under -# construction -# finishB - Basic block number of the finishing block -# compTemp - Temporary to use for list comparisons -# listLoc - Location where the arg list is found -# lenLoc - Location where the list length is found -# j - Index in the arg list of the current parameter +# B - Builder that is emitting the invocation sequence +# j - Position of the parameter being unpacked # # Results: -# Returns a two-element list giving the block number that jumps -# to the finish if the parameter is not supplied and the -# location of a temporary holding the unpacked value if it is. +# +# Returns a two-element list: the block number that will jump to the +# finish if there are too few arguments to match all optional +# parameters, and the location of the argument if one was successfully +# unpacked # # Side effects: # Emits code to unpack one value, or jump to the finish block if # there is nothing to unpack. -oo::define quadcode::transformer method varargsUnpackOptional {tempIdxVar bVar - bbVar finishB - compTemp listLoc - lenLoc j} { - upvar 1 $tempIdxVar tempIndex $bVar b $bbVar bb - - set pos [list literal $j] - set compLoc [my newVarInstance $compTemp] - set argTemp [list temp [incr tempIndex]] - set argLoc1 [my newVarInstance $argTemp] - set argLoc2 [my newVarInstance $argTemp] - - # Emit the list length comparison - my varargsEmitAndTrack $b bb [list ge $compLoc $pos $lenLoc] - - # Emit the jump to the finish block We need to make an intermediate block - # because otherwise the flowgraph edge would be critical - set intb [llength $bbcontent] - lappend bbcontent {} - lappend bbpred {} - my varargsEmitAndTrack $b bb [list jumpTrue [list bb $intb] $compLoc] - - # Create the next block and jump to it - set newb [llength $bbcontent] - lappend bbcontent {} - lappend bbpred {} - my varargsEmitAndTrack $b bb [list jump [list bb $newb]] - lset bbcontent $b $bb - - # Make the intermediate block - set b $intb - set bb {} - my varargsEmitAndTrack $b bb [list jump [list bb $finishB]] - lset bbcontent $b $bb - - # Advance to the new block - - set b $newb - set bb {} - - # Emit the 'listIndex' to unpack the arg - my varargsEmitAndTrack $b bb [list listIndex $argLoc1 $listLoc $pos] - - # Emit the 'extractMaybe' on the 'listIndex' result - my varargsEmitAndTrack $b bb [list extractMaybe $argLoc2 $argLoc1] - +oo::define quadcode::transformer method va_UnpackOptional {B j} { + + set compLoc [$B maketemp arg${j}found] + + $B emit [list ge $compLoc [list literal $j] [$B gettemp arglen]] + my debug-varargs { + $B log-last + } + set intb [$B makeblock] + set nextb [$B makeblock] + $B emit [list jumpTrue [list bb $intb] $compLoc] + my debug-varargs { + $B log-last + } + $B emit [list jump [list bb $nextb]] + my debug-varargs { + $B log-last + } + + $B buildin $nextb + + set intLoc [$B maketemp arg$j] + set argLoc [$B maketemp arg$j] + + $B emit [list listIndex $intLoc [$B gettemp arglist] [list literal $j]] + my debug-varargs { + $B log-last + } + $B emit [list extractMaybe $argLoc $intLoc] + my debug-varargs { + $B log-last + } + # Return the place where we stored the arg - return [list $intb $argLoc2] + return [list $intb $argLoc] } -# quadcode::transformer method varargsFinishOptional -- +# quadcode::transformer method va_FinishOptional -- # # Finish transmitting the args that have default values when # compiling {*} # # Parameters: -# bVar - Variable in caller holding the current basic block number -# bbVar - Variable in caller's scope holding basic block content -# newqVar - Variable in caller's scope holding the 'invoke' -# quadcode under construction -# finishB - Basic block number reserved for the 'finish' block +# B - Builder that is emitting the quadcode invocation sequence +# newq - 'invoke' instruction under construction # optInfo - List of triples: fromBlock defaultValue tempLoc # giving the phi inputs for the block under construction # # Results: # None. @@ -818,29 +732,30 @@ # Closes out the current basic block, opens the finish block, # and emits phi instructions into the finish block. Adds the # outputs of the phi instructions to the 'invoke' instruction # under construction. -oo::define quadcode::transformer method varargsFinishOptional {bVar bbVar - newqVar finishB - optInfo} { - - upvar 1 $bVar b $bbVar bb $newqVar newq - - # Finish the current block and start building into 'finishB' - - my varargsEmitAndTrack $b bb [list jump [list bb $finishB]] - lset bbcontent $b $bb - set bb {} - set fromb $b - set b $finishB +oo::define quadcode::transformer method va_FinishOptional {B newq optInfo} { + + # Finish the current block and make the join point + set finishB [$B makeblock] + + $B emit [list jump [list bb $finishB]] + set fromb [$B curblock] + $B buildin $finishB # Emit the phi instructions set n 0 foreach tuple $optInfo { - lassign $tuple - defaultVal tempLoc + lassign $tuple fblk defaultVal tempLoc + $B buildin $fblk + $B emit [list jump [list bb $finishB]] + my debug-varargs { + $B log-last + } + $B buildin $finishB set defaultLit [list literal $defaultVal] set newTemp [my newVarInstance $tempLoc] incr n set q [list phi $newTemp] set k -1 @@ -853,204 +768,429 @@ } else { lappend q $defaultLit } } lappend q [list bb $fromb] $tempLoc - my varargsEmitAndTrack $b bb $q + $B emit $q + my debug-varargs { + $B log-last + } lappend newq $newTemp } + + return $newq } -# quadcode::transformer method varargsDoArgs -- +# quadcode::transformer method va_DoArgs -- # # Emits code to extract the parameter sequence needed to fill '$args' # from the parameter list. # # Parameters: -# tempIdxVar - Variable containing the last temporary index used -# b - basic block number under construction -# bbVar - Variable containing the code of the basic block -# newqVar - Variable containing the 'invoke' instruction under -# construction -# listLoc - LLVM location holding the argument list -# i - Index in the arg list at which 'args' starts +# B - Builder that is emitting the code sequence +# newqVar - Variable in caller's scope containing the quadcode +# 'invoke' instruction under construction +# i - Position in the argument list at which 'args' starts. # # Results: # None. # # Side effects: # Emits any code necessary to fill in 'args', and adds the resulting # variable onto the end of the new instruction. -oo::define quadcode::transformer method varargsDoArgs {tempIdxVar b bbVar - newqVar listLoc i} { +oo::define quadcode::transformer method va_DoArgs {B newqVar i} { + + upvar 1 $newqVar newq + set listLoc [$B gettemp arglist] + my debug-varargs { + puts "varargs: args will come from positions $i-end in $listLoc" + } - upvar 1 $tempIdxVar tempIndex $bbVar bb $newqVar newq - + # If args is the whole list, just concatenate it onto the invoke if {$i == 0} { lappend newq $listLoc } else { - set argsTemp [list temp [incr tempIndex]] - set argsLoc1 [my newVarInstance $argsTemp] - my varargsEmitAndTrack $b bb [list listRange $argsLoc1 $listLoc \ - [list literal $i] [list literal end]] - set argsLoc2 [my newVarInstance $argsTemp] - my varargsEmitAndTrack $b bb [list extractMaybe $argsLoc2 $argsLoc1] + set argsLoc1 [$B maketemp \$args] + $B emit [list listRange $argsLoc1 $listLoc \ + [list literal $i] {literal end}] + my debug-varargs { + $B log-last + } + + set argsLoc2 [$B maketemp \$args] + $B emit [list extractMaybe $argsLoc2 $argsLoc1] lappend newq $argsLoc2 } + +} + +# quadcode::transformer method va_CheckEnough -- +# +# Emits code to check for too few args passed to invokeExpanded +# +# Parameters: +# B - Builder that is managing code for this invocation +# callee - Name of the invoked command +# minLength - Minumum length of the arglist +# +# Results: +# None. +# +# Side effects: +# Emits the check, the 'wrong # args' error if needed, and generates +# the error block if needed +# +# The assumption is made that the 'arglen' temporary in $B has the +# length of the + +oo::define quadcode::transformer method va_CheckEnough {B callee minLength} { + + set currentb [$B curblock] + set compLoc [my newVarInstance {temp @toofew}] + set lenLoc [$B gettemp arglen] + + # compare args provided to args needed + $B emit [list gt $compLoc [list literal $minLength] $lenLoc] + my debug-varargs { + $B log-last + } + my va_JumpTrueToWrongArgs $B $callee $compLoc + + return } -# quadcode::transformer method varargsCheckTooMany -- +# quadcode::transformer method va_CheckTooMany -- # # Emits a codeburst to check whether an 'invokeExpanded' has # too many args # # Parameters: -# bVar - Variable holding the basic block number -# bbVar - Variable holding the content of the current basic block -# lenLoc - LLVM location holding the argument list length -# compTemp - Name of a temporary to use as a comparison result -# i - Index of the next unclaimed argument -# errorB - Basic block number to jump to if there are too many args +# B - Builder that is emitting the quadcode sequence +# callee - Name of the called procedure +# maxLength - Maximum length of the arg list +# +# Results: +# None. +# +# Side effects: +# Emits the check. # # Results: # None # # Side effects: # Emits code and closes the basic block -oo::define quadcode::transformer method varargsCheckTooMany {bVar bbVar lenLoc - compTemp i - errorB} { - - upvar 1 $bVar b $bbVar bb - - - set compLoc [my newVarInstance $compTemp] - my varargsEmitAndTrack $b bb [list gt $compLoc $lenLoc [list literal $i]] - - set intb [llength $bbcontent] - lappend bbcontent {} - lappend bbpred {} - my varargsEmitAndTrack $b bb [list jumpTrue [list bb $intb] $compLoc] - - set newb [llength $bbcontent] - lappend bbcontent {} - lappend bbpred {} - my varargsEmitAndTrack $b bb [list jump [list bb $newb]] - lset bbcontent $b $bb - - set b $intb - set bb {} - my varargsEmitAndTrack $b bb [list jump [list bb $errorB]] - lset bbcontent $b $bb - - set b $newb - set bb {} - -} - -# quadcode::transformer method varargsEmitWrongArgs -- -# -# Generates code to throw the 'wrong # args' error when needed -# -# Parameters: -# result - Quadcode value that will hold the command result -# cfout - Quadcode value that will hold the result callframe, -# or {} if no callframe need be produced -# cfin - Quadcode value that holds the pre-invoke callframe, -# or Nothing if no callframe need be produced -# cmd - Quadcode literal with the name of the command being invoked +oo::define quadcode::transformer method va_CheckTooMany {B callee maxLength} { + + set compLoc [my newVarInstance {temp @toomany}] + set lenLoc [$B gettemp arglen] + + # Compare args provided against maximum + $B emit [list gt $compLoc $lenLoc [list literal $maxLength]] + my debug-varargs { + $B log-last + } + my va_JumpTrueToWrongArgs $B $callee $compLoc + + return +} + +# quadcode::transformer method va_JumpTrueToWrongArgs +# +# Common logic for va_CheckEnough and va_CheckTooMany +# +# Parameters: +# B - Builder that is emitting an invocation sequence. +# callee - Name of the called command +# compLoc - Quadcode location that contains a true value iff +# the wrong number of arguments is supplied. # # Results: # None. # # Side effects: -# Returns a codeburst that throws the exception - -oo::define quadcode::transformer method varargsEmitWrongArgs {result cfout - cfin cmd} { - - set burst {} - if {$cfin ne "Nothing"} { - lappend burst [list copy $cfout $cfin] - } - - set argl [info args [lindex $cmd 1]] +# Emits a 'jumpTrue' instruction to code that reports the wrong +# number of arguments, and a 'jump' to the following block, and +# builds in the following block + +oo::define quadcode::transformer method va_JumpTrueToWrongArgs {B callee + compLoc} { + + set intb [$B makeblock] + set okb [$B makeblock] + $B emit [list jumpTrue [list bb $intb] $compLoc] + my debug-varargs { + $B log-last + } + $B emit [list jump [list bb $okb]] + my debug-varargs { + $B log-last + } + + set errb [my va_MakeWrongArgs $B $callee] + $B buildin $intb + $B emit [list jump [list bb $errb]] + my debug-varargs { + $B log-last + } + + # return to the 'no failure' branch + $B buildin $okb + +} + +# quadcode::transformer method va_MakeWrongArgs -- +# +# Generates code to throw the 'wrong # args' error when needed +# +# Parameters: +# B - Builder that is generating quadcode +# callee - Name of the called procedure +# +# Results: +# Returns the basic block number of the generated block +# +# Side effects: +# Generates a block that creates an exception and jumps to the +# error handler. + +oo::define quadcode::transformer method va_MakeWrongArgs {B callee} { + + set wrongb [$B getblock "wrongargs"] + if {$wrongb >= 0} { + return $wrongb + } + set wrongb [$B makeblock "wrongargs"] + set currentb [$B curblock] + + set argl [info args $callee] set left [llength $argl] - set sbval [list [lindex $cmd 1]] + set sbval [list $callee] foreach a $argl { incr left -1 if {$a eq "args" && $left == 0} { append sbval " ?arg ...?" - } elseif {[info default [lindex $cmd 1] $a -]} { + } elseif {[info default $callee $a -]} { lappend sbval ?$a? } else { lappend sbval $a } } set msgval "wrong # args: should be \"$sbval\"" - set intres [my newVarInstance $result] - set q [list initException $intres [list literal $msgval] \ - {literal {-errorcode {TCL WRONGARGS}}} \ - {literal 1} \ - {literal 0}] - lappend burst $q - set q [list extractFail $result $intres] - lappend burst $q - return $burst - -} - -# quadcode::transformer method varargsEmitAndTrack -- -# -# Emits a quadcode instruction and tracks its effects -# -# Parameters: -# b - Basic block number -# bbVar - Variable containing the basic block content -# q - Quadcode instruction to emit + set intres [$B maketemp wrongargs] + + $B buildin $wrongb + $B emit [list initException $intres [list literal $msgval] \ + {literal {-errorcode {TCL WRONGARGS}}} \ + {literal 1} \ + {literal 0}] + my debug-varargs { + $B log-last + } + + set excloc [$B maketemp wrongargs] + $B emit [list extractFail $excloc $intres] + my debug-varargs { + $B log-last + } + + set errorb [my va_MakeErrorBlock $B] + $B emit [list jump [list bb $errorb]] + + # Add phis for the error result and the callframe to the error block + set errorInPhi [$B gettemp error] + $B updatephi $errorb $errorInPhi $excloc + + $B buildin $currentb + return $wrongb + +} + +# quadcode::transformer method va_MakeErrorCheck -- +# +# Emits code to jump to an error block if a given value is FAIL. +# +# Parameters: +# B - Builder that is emitting code +# val - Value that might be FAIL +# +# Results: +# None. +# +# Side effects: +# Emits the necessary jumpMaybe, and adds FAIL value +# to the phi operation at the head of the error block. + +oo::define quadcode::transformer method va_MakeErrorCheck {B val} { + + # Emit any required error checking when building the variable + # argument list. + my va_MakeErrorBlock $B + set errorb [$B getblock error] + set intb [$B makeblock] + set nextb [$B makeblock] + + # Close out the current block with jumpMaybe to an intermediate + # block and jump to the normal return + $B emit [list jumpMaybe [list bb $intb] $val] + my debug-varargs { + $B log-last + } + $B emit [list jump [list bb $nextb]] + my debug-varargs { + $B log-last + } + + # Make an intermediate block that jumps to the error block + $B buildin $intb + $B emit [list jump [list bb $errorb]] + my debug-varargs { + $B log-last + } + + # Add phis for the error result ant the callframe to the error block + set errorInPhi [$B gettemp error] + $B updatephi $errorb $errorInPhi $val + + # Now continue building in the normal exit + $B buildin $nextb +} + +# quadcode::transformer method va_MakeErrorBlock -- +# +# Makes the block to which all the error paths in an invocation +# sequence jump. +# +# Parameters: +# B - Builder that is emitting code +# +# Results: +# Returns the number of the block. +# +# Side effects: +# Creates the block, and adds a vacuous 'phi' operation to it that +# will hold the FAIL value from the error. The block and the result +# of the 'phi' are both named 'error' in the builder. + +oo::define quadcode::transformer method va_MakeErrorBlock {B} { + + my debug-varargs { + puts "varargs: Create a block for error exits." + } + set errorb [$B getblock error] + if {$errorb >= 0} { + return $errorb + } + + set currentb [$B curblock] + set errorb [$B makeblock error] + + $B buildin $errorb + set errortemp [$B maketemp error] + $B emit [list phi $errortemp] + my debug-varargs { + $B log-last + } + + $B buildin $currentb + return $errorb +} + +# oo::transformer method va_ConvergeErrorPath -- +# +# Converges the code for the error and normal paths after an 'invoke'. +# +# Parameters: +# B - Builder that is emitting code +# result - Quadcode variable that will hold the result +# cf - Quadcode variable that will hold the callframe +# cfin - Callframe on input to the 'invoke' +# bb - Remainder of the basic block following 'invoke', 'retrieveResult' +# and 'extractCallFrame'. # # Results: # None. # # Side effects: -# Instruction is added to the basic block, and linked in ud- and du-chains -# Basic block is linked in control flow if needed. - -oo::define quadcode::transformer method varargsEmitAndTrack {b bbVar q} { - - upvar 1 $bbVar bb - - set res [lindex $q 1] - switch -exact -- [lindex $res 0] { - "bb" { - my bblink $b [lindex $res 1] - } - "temp" - "var" { - dict set udchain $res $b - } - } - - foreach arg [lrange $q 2 end] { - switch -exact -- [lindex $arg 0] { - "temp" - "var" { - my addUse $arg $b - } - } - } - - my debug-varargs { - puts "--> $b:[llength $bb]: $q" - } - lappend bb $q - +# Emits all the remaining code. + +oo::define quadcode::transformer method va_ConvergeErrorPath {B result + cf cfin bb} { + + # Find where errors were routed + set errorb [$B getblock "error"] + set normresult [$B gettemp "result"] + set normcf [$B gettemp "callframe"] + if {$errorb < 0} { + + # Nothing could throw, so just emit copies of the callframe and + # the command's result. The copies will get cleaned up later + + $B emit [list copy $cf $normcf] + my debug-varargs { + $B log-last + } + $B emit [list copy $result $normresult] + my debug-varargs { + $B log-last + } + } else { + + # There is an error path that has to join here. Emit a jump to the + # join point. + set normb [$B curblock] + set finalb [$B makeblock] + $B emit [list jump [list bb $finalb]] + my debug-varargs { + $B log-last + } + + # Move to the error block, and emit a jump to the join point + set errResult [$B gettemp "error"] + set errFail [$B maketemp "error"] + $B buildin $errorb + $B emit [list extractFail $errFail $errResult] + my debug-varargs { + $B log-last + } + $B emit [list jump [list bb $finalb]] + my debug-varargs { + $B log-last + } + + # Move to the finalization block, and emit phis for the callframe + # and the result + + $B buildin $finalb + $B emit [list phi $cf \ + [list bb $errorb] $cfin [list bb $normb] $normcf] + my debug-varargs { + $B log-last + } + $B emit [list phi $result \ + [list bb $errorb] $errFail [list bb $normb] $normresult] + my debug-varargs { + $B log-last + } + } + + # Put back the instructions that followed the 'invoke' + foreach q $bb { + $B emit $q + my debug-varargs { + $B log-last + } + } + + return } # Local Variables: # mode: tcl # fill-column: 78 # auto-fill-function: nil # buffer-file-coding-system: utf-8-unix # indent-tabs-mode: nil # End: Index: quadcodes.txt ================================================================== --- quadcodes.txt +++ quadcodes.txt @@ -158,10 +158,13 @@ dictIterValue TGT SRC Let TGT be the value from the current step of the interation in SRC. Error-Related Operations List Operations -------------------- +extractFail TGT SRC + Given a Maybe in SRC which contains an exception, let TGT become the + exception. extractMaybe TGT SRC Given a Maybe in SRC which contains a Just X, let TGT become the X. initException TGT SRC1 SRC2 ?SRC3 SRC4? Set up an exception. TGT is a Maybe of the result value. SRC1 is the result value. SRC2 is the options dictionary. SRC3 is the return code @@ -184,32 +187,45 @@ returnOptions TGT SRC Let TGT contain the current interpreter return options, given that SRC contains the exception code, as obtained by 'returnCode'. setReturnCode {} SRC Sets the current return code to SRC. +startCatch CALLFRAME CALLFRAME + Appears shortly after anything in the program that throws an error. + Used to do the bookkeeping needed to track that ::errorInfo and ::errorCode + have been changed 'behind the program's back' and make sure that + any variables that might alias them are synchronized. General/Structural Operations ----------------------- allocObjvForCallees {} {literal N} Preallocates the 'objv' vector for commands that this command invokes. N is the required length of the vector. -confluence - Comes at the start of a block that has execution flowing in from multiple - other blocks. copy TGT SRC Let TGT become SRC entry Marks the entry to the function. exists TGT SRC Sets TGT to 1 if SRC has a value, and 0 otherwise +extractCallFrame TGT SRC + Given a SRC value that is a callframe combined with something else, + extracts the callframe from it. extractExists TGT SRC Given a SRC value that is of type {NEXIST SOMETHING}, let TGT become just the SOMETHING. -invoke TGT SRC1 ... +extractResult TGT SRC + Give a SRC value that is a callframe combined with another type X, extracts + the X from it. (extractExists and extractResult ordinarily follow 'invoke' + to unpack the structure that it returns.) +invoke TGT {} SRC1 SRC2... Let TGT become the invoke of the given command with the given arguments. The command is given by SRC1 and the arguments are given by SRC2... Variadic. +invoke TGT+CALLFRAME CALLFRAME SRC1 ... + This variant is used when the 'invoke' may alter variables. CALLFRAME + is the callframe before the invocation, and TGT+CALLFRAME is the result + combined with the callframe afterward. jump BLK Transfer execution to the block with address BLK. jumpFalse BLK SRC Transfer execution to the block with address BLK if SRC is false, otherwise transfer execution to the "next" block. @@ -254,8 +270,66 @@ math function requiring a pure value as argument #N. Otherwise, simply sets TGT to SRC. This operation is replaced with 'purify' or removed during optimization. It is there to purify the operands of built-in mathfuncs. +# Direct variable manipulation instructions + +directExists VAL CF VAR + Tests whether variable VAR exists (in callframe CF, if the value is + not fully qualified). Returns ZEROONE. +directGet VAL CF VAR + Gets the value of VAR from callframe CF and puts the result in VAL. + Result is of type {FAIL NEXIST STRING}. +directSet TUPLE CF VAR VAL + Sets variable VAR in callframe CF (or in a namespace) to the value VAL. + Returns the result of the set, or an error if the value cannot be set. + TUPLE is of type {CALLFRAME FAIL T} where T is the type of VAL. +directAppend TUPLE CF VAR VAL + Appends value VAL to variable VAR in callframe CF (or in a namespace). + Returns the result of the set, or an error if the value cannot be set. + TUPLE is of type {CALLFRAME FAIL STRING}. +directLappend TUPLE CF VAR VAL + Appends value VAL to variable VAR in callframe CF (or in a namespace). + Returns the result of the set, or an error if the value cannot be set. + TUPLE is of type {CALLFRAME FAIL STRING}. +directLappendList TUPLE CF VAR LISTVAL + Appends the list of values LISTVAL to variable VAR in callframe CF + (or in a namespace). Returns the result of the append, or an error if + the value could not be apppended. TUPLE is of type {CALLFRAME FAIL STRING} +directIsArray VAL CF ARY + Tests [array exists ARY] (in callframe CF, if ARY is not fully qualified). + Returns a Boolean indicating the existence, or an error in the event of + an error in traces. (Note that traces are not implemented in quadcode yet!) + Result is of type {FAIL ZEROONE}. +directMakeArray TUPLE CF ARY + Creates an array ARY (in callframe CF if ARY is not fully qualified). + Returns an ignored result or throws an error. Return type is {ZEROONE FAIL}. +directArrayExists VAL CF ARY ELT + Tests whether element ELT of array ARY exists (in callframe CF, if the + value is not fully qualified). Returns ZEROONE. +directArrayGet VAL CF ARY ELT + Gets the value of element ELT of array ARY in callframe CF and puts + the result in VAL. Result is of type {FAIL NEXIST STRING}. +directArraySet TUPLE CF ARY ELT VAL + Sets element ELT of array ARY in callframe CF (or in a namespace) to the + value VAL. Returns the result of the set, or an error if the value cannot + be set. TUPLE is of type {CALLFRAME FAIL T} where T is the type of VAL. +directArrayAppend TUPLE CF ARY ELT VAL + Appends value VAL to element ELT of array ARY (in callframe CF if ARY + is not fully qualified). + Returns the result of the set, or an error if the value cannot be set. + TUPLE is of type {CALLFRAME FAIL STRING}. +directArrayLappend TUPLE CF ARY ELT VAL + Appends value VAL to element ELT of array ARY (in callframe CF, if + ARY is not fully qualified). Returns the result of the operation, + or an error if the value cannot be set. TUPLE is of type + {CALLFRAME FAIL STRING}. +directArrayLappendList TUPLE CF ARY ELT LISTVAL + Appends the list of values LISTVAL to element ELT of array ARY + (in callframe CF, if ARY is not fully qualified). + Returns the result of the append, or an error if + the value could not be apppended. TUPLE is of type {CALLFRAME FAIL STRING} + For these operations, the data types that must be implemented are INT32, INT, ENTIER, DOUBLE; the same four data types unioned with EMPTY; and the complements of these eight types, so there are sixteen variants in all.