Index: codegen/build.tcl ================================================================== --- codegen/build.tcl +++ codegen/build.tcl @@ -11,10 +11,40 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ oo::define Builder { + + # Builder:Tcl_Alloc -- + # + # Allocate memory using Tcl's system + # + # Parameters: + # size - An LLVM value reference giving the size of the block to allocated + # name - The name to give to the value + # + # Results: + # Returns an LLVM value reference designating the pointer to the allocated + # block + + method Tcl_Alloc {size {name {}}} { + my call ${tcl.alloc} [list $size] $name + } + export Tcl_Alloc + + # Builder:Tcl_Free -- + # + # Free memory using Tcl's system + # + # Parameters: + # block - An LLVM value reference giving the pointer to the block + + method Tcl_Free {block} { + my call ${tcl.free} [list $block] + } + export Tcl_Free + # Builder:isInt32 -- # # Generate code to test if an INT holds an int32. # # Parameters: @@ -533,21 +563,24 @@ # array of arguments, allocated on the function stack. # proc - The LLVM value reference to the procedure's metadata. # localcache - # The LLVM value reference to the procedure's local variable # metadata. + # callframe - The LLVM pointer reference to the callframe to construct + # entryBlock - The entry block of the function, needed for allocating + # the array of local variables. # # Results: # A Tcl list of the LLVM CALLFRAME value reference and the mapping # dictionary from string variable names to the corresponding LLVM Var* # value references. - method frame.create {varlist argc argv proc localcache} { + method frame.create {varlist argc argv proc localcache callframe + entryBlock} { # Construct the call frame itself - set callframe [my alloc CallFrame "callframe"] set length [Const [llength $varlist]] - set locals [my arrayAlloc Var $length] + set locals [my arrayAllocInBlock $entryBlock Var $length] my Call tcl.callframe.init $callframe $length \ $argc [my cast(ptr) $argv STRING] $proc $localcache $locals # Initialise the information about the local variables set idx -1 set varmap {} @@ -917,13 +950,14 @@ # name (optional) - # The LLVM name of the result value. # # Results: # An LLVM bool? value reference. - + method frame.bind.upvar(STRING,STRING,STRING) { - localName level otherName localVar callframe ec {name ""}} { + localName level otherName localVar callframe ec {name ""} + } { set otherVar [my call ${tcl.callframe.lookup.upvar} [list \ $callframe $level $otherName] "otherVar"] set val [my call ${tcl.callframe.bindvar} [list \ $callframe $otherVar $localVar $localName $ec] $name] return [my frame.pack $callframe $val $name] @@ -1230,21 +1264,23 @@ # Builder:allocBitv -- # # Allocate a bit vector of a given length. # # Parameters: + # entryBlock - The block in which the 'alloca' should appear # len - The length of the vector + # name (optional) - Name to give to the resulting LLVM value # # Results: # Returns an LLVM int1* reference designating the start of the vector # # MUST BE CALLED WHILE EMITTING CODE FOR THE ENTRY BLOCK AND AT # NO OTHER TIME - method allocBitv {len {name {}}} { + method allocBitv {entryBlock len {name {}}} { set type [Type array{bool,$len}] - set bits [my alloc $type ${name}.space] + set bits [my allocInBlock $entryBlock $type ${name}.space] set first [my gep $bits 0] SetValueName $first $name return $first } @@ -1251,21 +1287,23 @@ # Builder:allocObjv -- # # Allocate a STRING vector of a given length # # Parameters: + # entryBlock - The block in which the 'alloca' should appear # len - The length of the vector + # name (optional) - Name to give to the resulting LLVM value # # Results: # Returns an LLVM STRING* reference designating the start of the vector # # MUST BE CALLED WHILE EMITTING CODE FOR THE ENTRY BLOCK AND AT # NO OTHER TIME - method allocObjv {len {name {}}} { + method allocObjv {entryBlock len {name {}}} { set type [Type array{STRING,$len}] - set strs [my alloc $type ${name}.space] + set strs [my allocInBlock $entryBlock $type ${name}.space] set first [my gep $strs 0] SetValueName $first $name return $first } @@ -1765,31 +1803,31 @@ # # Parameters: # start - An LLVM STRING* value that designates the start of the vecotr # types - The types of the values used to build the vector, as a Tcl # list of type descriptors. - # values - - # Tcl list of LLVM value references that are the individual + # qvalues - + # Tcl list of quadcode values that are the individual # elements of the vector. - # + # lvalues - Tcl list of LLVM values of the individual elements # Results: # LLVM vector value reference. - method buildVector {start types values} { + method buildVector {start types qvalues lvalues} { # Implementation note: there must be no branches in the issued code. set vectortype [Type struct{int,STRING*}] set idx -1 - foreach src $values t $types { - set s [my stringify($t) $src] + foreach src $qvalues t $types v $lvalues { + set s [my stringify($t) $v] set cell [my gep $start 0 [incr idx]] my store $s $cell if {![my IsVectorItemConstant $src $t]} { my addReference(STRING) $s } } set vector [my undef $vectortype] - set vector [my insert $vector [Const [llength $values]] 0] + set vector [my insert $vector [Const [llength $lvalues]] 0] set vector [my insert $vector [my gep $start 0 0] 1] return $vector } # Builder:ExtractVector -- @@ -2094,19 +2132,30 @@ # Builder:clearVector -- # # Clean up a vector value created with buildVector. # # Parameters: - # vector - - # The LLVM vector value reference. + # objv - The start of the vector to be cleared + # srcs - The quadcode values that the vector elements were built from. + # Used to detect direct literal STRINGs, which don't need + # free-ing. + # types - The types of the values used to build the vector. + # # Results: # None. - method clearVector {vector} { + method clearVector {objv types srcs} { set idx -1 - my ExtractVector $vector objc objv - my call ${tcl.vector.clear} [list $objc $objv] + foreach src $srcs t $types { + + incr idx + if {![my IsVectorItemConstant $src $t]} { + set ptr [my gep $objv 0 $idx] + set toDrop [my load $ptr] + my dropReference [my load [my gep $objv 0 $idx]] + } + } return } # Builder:concat() -- # @@ -4446,11 +4495,11 @@ # Generate code to call a Tcl command. Quadcode implementation # ('invoke'). # # Parameters: # arguments - - # The arguments as an LLVM vector value reference. Note that + # The arguments as an LLVM array value reference. Note that # this includes the function name as the first argument. # havecf - # Tcl boolean indicating if we have a valid callframe. # cf - The reference to the current callframe if 'havecf' is true. # ec - Location to write the Tcl return code into, as an LLVM int* @@ -4466,10 +4515,38 @@ if {!$havecf} { set cf {} } my call ${tcl.invoke.command} [list $len $ary $cf $ec] $resultName } + + # Builder:invokeNRE -- + # + # Generate code to call a Tcl command with non-recursive eval. + # Quadcode implementation ('NRE.invoke'). + # + # Parameters: + # arguments - + # The arguments as an LLVM array value reference. Note that + # this includes the function name as the first argument. + # havecf - + # Tcl boolean indicating if we have a valid callframe. + # cf - The reference to the current callframe if 'havecf' is true. + # ec - Location to write the Tcl return code into, as an LLVM int* + # reference. + # resultName (optional) - + # A name to give to the result value. + # + # Results: + # None. The command's return value is in the coroutine promise. + + method invokeNRE {arguments havecf cf ec {resultName ""}} { + my ExtractVector $arguments + if {!$havecf} { + set cf {} + } + my call ${tcl.invoke.command.nre} [list $len $ary $cf $ec] $resultName + } # Builder:invokeExpanded -- # # Generate code to call a Tcl command while doing argument expansion. # Quadcode implementation ('invokeExpanded'). @@ -4483,16 +4560,50 @@ # reference. # resultName (optional) - # A name to give to the result value. # # Results: - # An LLVM value reference. + # None. The command's return value is in the coroutine promise. method invokeExpanded {arguments flags ec {resultName ""}} { my ExtractVector $arguments my call ${tcl.invoke.expanded} [list $len $ary $flags $ec] $resultName } + + # Builder:invokeExpandedNRE -- + # + # Generate code to call a command with non-recursive eval while doing + # argument expansion. Quadcode implementation ('NRE.invokeExpanded'). + # + # Parameters: + # arguments - + # The arguments as an LLVM vector value reference. Note that + # this includes the function name as the first argument. + # flags - LLVM bit array indicating which arguments to expand. + # havecf - + # Tcl boolean indicating if we have a valid callframe. + # cf - The reference to the current callframe if 'havecf' is true. + # ec - Location to write the Tcl return code into, as an LLVM int* + # reference. + # resultName (optional) - + # A name to give to the result value. + # + # Results: + # None. + + method invokeExpandedNRE {arguments flags havecf cf ec {resultName ""}} { + my ExtractVector $arguments + if {!$havecf} { + set cf {} + } + my call ${tcl.invoke.expanded.nre} [list $len $ary $flags $cf $ec] \ + $resultName + } + + method restoreFrame {frame} { + my call ${tcl.restoreFrame} [list $frame] + } # Builder:isBoolean(INT BOOLEAN) -- # # Test if a value is a boolean. Quadcode implementation ('isBoolean'). # Index: codegen/compile.tcl ================================================================== --- codegen/compile.tcl +++ codegen/compile.tcl @@ -26,10 +26,11 @@ oo::class create TclCompiler { superclass llvmEntity variable bytecode cmd func quads paramTypes returnType vtypes variables variable m b pc errorCode currentline currentprocrelline currentscript variable bytecodeVars namespace objv bitv + variable nreReturnType coro_info constructor {} { next namespace import \ ::quadcode::nameOfType \ @@ -151,26 +152,28 @@ } else { puts $channel [format "%s------>\n%s" $cmd [join $descriptions \n]] } } - # TclCompiler:generateDeclaration -- + # TclCompiler:GenerateDeclaration -- # # Generate the declaration for the function that we are transforming the # Tcl code into. # # Parameters: # module - # The module reference (i.e., instance of Module class) to # generate the function within. + # qs - + # The quadcode sequence # # Results: # The function reference (i.e., instance of Function class) that we have # generated. Note that this will be an unimplemented function at this # stage. - method generateDeclaration {module} { + method GenerateDeclaration {module qs} { set m $module ############################################################## # # Compute the argument types @@ -187,11 +190,23 @@ ############################################################## # # Compute the return type # - set rtype [nameOfType $returnType] + set rtype char* + foreach insn $qs { + switch -exact -- [lindex $insn 0 0] { + "entry" { + set rtype [nameOfType $returnType] + break + } + "NRE.entry" { + set nreReturnType [nameOfType $returnType] + break + } + } + } set returntype [Type $rtype] ############################################################## # # Construct the function signature type and the function object. @@ -240,18 +255,23 @@ lassign [my GenerateBasicBlocks $quads] blockDict ipathDict pred array set block $blockDict array set ipath $ipathDict - # NB: block(-1) is the function entry block. It's supposed to be + # NB: block(-2) contains the alloca's for the function. + # block(-1) is the function entry block. It's supposed to be # almost entirely optimized out. - $block(-1) build-in $b + + $block(-2) build-in $b $b @location 0 set errorCode [$b alloc int "tcl.errorCode"] - set curr_block $block(-1) set 0 [$b int 0] + $block(-1) build-in $b + $b @location 0 + set curr_block $block(-1) + ############################################################## # # Create debug info for variables in LLVM dict for {name typecode} $vtypes { @@ -283,10 +303,24 @@ # local variable. $func localvar $formalname $type } } } + + foreach insn $quads { + switch -exact -- [lindex $insn 0 0] { + "NRE.entry" { + set coro_info \ + [my IssueNREEntrySequence $curr_block $block(0)] + set curr_block $block(0) + break + } + "entry" { + break + } + } + } ############################################################## # # Convert Tcl parse output, one instruction at a time. # @@ -299,10 +333,11 @@ set thevarmap {} set syntheticargs {} set currentline 0 set currentprocrelline 0 set currentscript {} + foreach l $quads { incr pc if {[info exists block($pc)]} { $block($pc) build-in $b set curr_block $block($pc) @@ -317,18 +352,25 @@ try { $b @location $currentline switch -exact -- [lindex $l 0 0] { "entry" { - lassign [my IssueEntry $l] \ + lassign [my IssueEntry $l $pc $block(-2)] \ + theframe thevarmap syntheticargs + } + "NRE.entry" { + lassign [my IssueEntry $l $pc $block(-2)] \ theframe thevarmap syntheticargs } "allocObjvForCallees" { set objc [lindex $l 2 1] if {$objc > 0} { - set objv [$b allocObjv $objc "objv.for.callees"] - set bitv [$b allocBitv $objc "flags.for.invokeExpanded"] + $b @location $currentline + set objv [$b allocObjv $block(-2) \ + $objc "objv.for.callees"] + set bitv [$b allocBitv $block(-2) \ + $objc "flags.for.invokeExpanded"] } } "confluence" - "unset" { # Do nothing; required for SSA computations only } @@ -597,17 +639,18 @@ set res [$b $opcode {*}$srcs $errorCode $name] my StoreResult $tgt $res } else { # Need to construct the variadic path set vectortypes [lmap s $srcs {my ValueTypes $s}] - set vector [$b buildVector $objv $vectortypes \ - [lmap s $srcs {my LoadOrLiteral $s}]] + set vectorValues [lmap s $srcs {my LoadOrLiteral $s}] + set vector [$b buildVector $objv $vectortypes $srcs \ + $vectorValues] append opcode ( [my ValueTypes $srcObj] ) set srcObj [my LoadOrLiteral $srcObj] set res [$b $opcode $srcObj $vector $errorCode $name] my StoreResult $tgt $res - $b clearVector $vector + $b clearVector $objv $vectortypes $srcs } if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } } @@ -622,18 +665,18 @@ set res [$b $opcode {*}$srcs $errorCode $name] my StoreResult $tgt $res } else { # Need to construct the variadic path set vectortypes [lmap s $srcs {my ValueTypes $s}] - set vector [$b buildVector $objv $vectortypes \ + set vector [$b buildVector $objv $vectortypes $srcs \ [lmap s $srcs {my LoadOrLiteral $s}]] set srcs [list $srcObj $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $vector $errorCode $name] my StoreResult $tgt $res - $b clearVector $vector + $b clearVector $objv $vectortypes $srcs } if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } } @@ -758,10 +801,14 @@ $b condBr $test $ipath($pc) $block($tgt) } "jump" { $b br $block([lindex $l 1 1]) } + "NRE.suspend" { + set tgt [lindex $l 1 1] + my CoroSuspend $coro_info $block($tgt) + } "return" { lassign $l opcode -> frame src set val [my LoadOrLiteral $src] if {"CALLFRAME" in [my ValueTypes $src]} { # The CALLFRAME does not leave @@ -777,10 +824,30 @@ if {$theframe ne "" && ![IsNull $theframe]} { $b frame.release $theframe $syntheticargs } $b ret $val } + "NRE.return" { + lassign $l opcode -> frame src + set val [my LoadOrLiteral $src] + if {"CALLFRAME" in [my ValueTypes $src]} { + # The CALLFRAME does not leave + set val [$b frame.value $val] + } + set type [nameOfType $returnType] + if {refType($type)} { + $b printref $val "ret:" + if {literal($src)} { + $b addReference($type) $val + } + } + if {$theframe ne "" && ![IsNull $theframe]} { + $b frame.release $theframe $syntheticargs + } + my CoroReturn $coro_info $val + } + "phi" { set values {} set sources {} foreach {var origin} [lassign $l opcode tgt] { set spc [lindex $origin end] @@ -814,13 +881,38 @@ if {$a ni $arguments && consumed($a, $pc + 1)} { lappend consumed $a } } } + "NRE.invoke" { + my IssueNREInvoke $theframe $l + } "invokeExpanded" { set arguments [my IssueInvokeExpanded $theframe $l] foreach aa $arguments { + set arguments [lassign $arguments a] + if {$a ni $arguments && consumed($a, $pc + 1)} { + lappend consumed $a + } + } + } + "NRE.invokeExpanded" { + my IssueNREInvokeExpanded $theframe $l + } + "NRE.returnFromInvoke" { + set arguments [my IssueNREReturnFromInvoke $theframe $l] + foreach aa $arguments { + set arguments [lassign $arguments a] + if {$a ni $arguments && consumed($a, $pc + 1)} { + lappend consumed $a + } + } + } + "NRE.returnFromInvokeExpanded" { + set arguments \ + [my IssueNREReturnFromInvokeExpanded $theframe $l] + foreach aa $arguments { set arguments [lassign $arguments a] if {$a ni $arguments && consumed($a, $pc + 1)} { lappend consumed $a } } @@ -863,16 +955,17 @@ } "concat" { set srcs [lassign $l opcode tgt] # Need to construct the variadic vector set vectortypes [lmap s $srcs {my ValueTypes $s}] - set vector [$b buildVector $objv $vectortypes \ - [lmap s $srcs {my LoadOrLiteral $s}]] + set vectorValues [lmap s $srcs {my LoadOrLiteral $s}] + set vector [$b buildVector $objv $vectortypes $srcs \ + $vectorValues] set name [my LocalVarName $tgt] set result [$b concat() $vector $name] my StoreResult $tgt $result - $b clearVector $vector + $b clearVector $objv $vectortypes $srcs } "foreachStart" { set srcs [lassign $l opcode tgt assign] set listtypes [lmap s $srcs {my ValueTypes $s}] set lists [lmap s $srcs {my LoadOrLiteral $s}] @@ -1023,27 +1116,31 @@ # blocks are the predecessors of the current block. method GenerateBasicBlocks {quads} { # Instructions that will always jump. set JUMPS { - jump + "jump" "NRE.suspend" } # Instructions that can go to either the next instruction OR the named # instruction. set FORKJUMPS { - jumpFalse jumpTrue - jumpMaybe jumpMaybeNot + "jumpFalse" "jumpTrue" + "jumpMaybe" "jumpMaybeNot" } # Instructions that terminate execution of the function. - set EXITS {return} + set EXITS { + "return" "NRE.return" + } ############################################################## # # Create basic blocks # - set block(-1) [$func block] + set block(-2) [$func block]; # Block(-2) is reserved for alloca's + set block(-1) [$func block]; # Block(-1) is entry code that precedes + ; # any user code in the function set next_is_ipath 1 set pc -1 foreach q $quads { incr pc set opcode [lindex $q 0 0] @@ -1070,11 +1167,11 @@ # # Compute the predecessors of each basic block # set pc -1 - set pred {} + set pred {-1 -2} set cb $block(-1) foreach q $quads { incr pc if {![info exist cb]} { set cb $block($pc) @@ -1113,18 +1210,22 @@ # Generate the code for creating a callframe at the start of a function. # Must only be called from the 'compile' method. # # Parameters: # quad - The 'entry' quadcode, including its parameters. + # pc - The program counter at which the entry appears. + # entryBlock - The Block of the entry to the function, used to make + # sure that any allocations happen early # # Results: # A triple of the callframe, the local variable mapping, and a list # saying which elements in the callframe are synthetic (i.e., have no # existing string representation) and need to be released on function # exit. - method IssueEntry {quad} { + method IssueEntry {quad pc entryBlock} { + lassign $quad opcode tgt vars # When no frame is wanted if {$tgt eq {}} { return [list [$b null CALLFRAME] {} {}] @@ -1141,20 +1242,19 @@ [$b null LocalCache*]] } # Build the argument list. First, we get the Tcl descriptors of the # arguments, their types, etc. - set varmeta [dict get $bytecode variables] - set argtypes {STRING} + set arguments [list [list literal $cmd]] - foreach vinfo $varmeta { - if {"arg" in [lindex $vinfo 0]} { - set vname [list var [lindex $vinfo 1] [llength $arguments]] - lappend arguments $vname - lappend argtypes [my ValueTypes $vname] - } + set argtypes {STRING} + for {incr pc} {[lindex $quads $pc 0] eq "param"} {incr pc} { + set vname [lindex $quads $pc 1] + lappend arguments $vname + lappend argtypes [my ValueTypes $vname] } + set varmeta [dict get $bytecode variables] # Patch in the extra variables discovered during quadcode analysis; # these are never arguments as Tcl always correctly puts those in the # original bytecode descriptor. set stdnames [lmap vinfo $varmeta {lindex $vinfo 1}] @@ -1165,11 +1265,12 @@ } dict set bytecode variables $varmeta # Now we allocate the storage for the argument list set argc [Const [llength $arguments]] - set argv [$b alloc [Type array{Tcl_Obj*,[llength $arguments]}] argv] + set argv [$b allocInBlock $entryBlock \ + [Type array{Tcl_Obj*,[llength $arguments]}] argv] # Store the arguments in the argument list set cell [$b gep $argv 0 0] $b store [Const $cmd STRING] $cell set idx -1 @@ -1183,13 +1284,16 @@ } # Create the stack frame set procmeta [dict get $bytecode procmeta] set localcache [dict get $bytecode localcache] + set callframe [$b allocInBlock $entryBlock CallFrame "callframe"] + lassign [$b frame.create $varmeta $argc $argv \ - [$b load $procmeta "proc.metadata"] \ - [$b load $localcache "proc.localcache"]] \ + [$b load $procmeta "proc.metadata"] \ + [$b load $localcache "proc.localcache"] \ + $callframe $entryBlock] \ theframe thevarmap my StoreResult $tgt $theframe return [list $theframe $thevarmap $drop] } @@ -1209,84 +1313,53 @@ # (for cleanup by the caller of this method). method IssueInvoke {callframe operation} { set arguments [lassign $operation opcode tgt thecallframe origname] set vname [my LocalVarName $tgt] - set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING} - set resolved {} - - # Is this a literal name for a function we already know the signature - # of? If so, we can use a direct call. To work this out, we need to - # resolve the command within the namespace context of the procedure. - - if {literal($origname)} { - # Resolve the name. - set name [my FuncName [lindex $origname 1]] - set fullname [my GenerateFunctionName $name arguments $arguments] - if {[$m function.defined $fullname]} { - set called [[$m function.get $fullname] ref] - set argvals [lmap arg $arguments {my LoadOrLiteral $arg}] - my IssueInvokeFunction $tgt $called $argvals $vname - return {} - } - if {[dict exist $vtypes $tgt]} { - set type [nameOfType [dict get $vtypes $tgt]] - if {"FAIL" ni $type || "STRING" ni $type} { - my Warn "didn't find implementation of '$fullname'" - } - } - # Don't need to pre-resolve command names if there's a callframe - if {!callframe($thecallframe)} { - set resolved [my LoadOrLiteral [list literal $name]] - } - } - - set arguments [list $origname {*}$arguments] - set argvals [lmap s $arguments {my LoadOrLiteral $s}] - - # Dynamic dispatch via direct call is OK, *provided* someone has - # fetched the function reference for us. - - if {[TypeOf [lindex $argvals 0]] ne [Type STRING]} { - set argvals [lassign $argvals called] - my IssueInvokeFunction $tgt $called $argvals $vname - return {} - } - - # Must dispatch via the Tcl command API. This is the slowest option - # with the least type inference possible (everything goes as a - # STRING) but it is a reasonable fallback if nothing else works. - - my IssueInvokeCommand $tgt $resolved $arguments $argvals $vname - return $arguments - } - - 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"} { - $b store $result $errorCode - my SetErrorLine $errorCode - } else { - set ts [lmap t $BASETYPES {Type $t?}] - if {[TypeOf $result] in $ts} { - $b store [$b extract $result 0] $errorCode - } elseif {[Type [TypeOf $result]?] eq [Type [my ValueTypes $tgt]]} { - # Managed to prove non-failure in this case... - set result [$b ok $result] - } - if {"FAIL" in [my ValueTypes $tgt]} { - my SetErrorLine $errorCode [$b maybe $result] - } - } - - if {callframe($thecallframe)} { - set result [$b frame.pack $callframe $result] - } - my StoreResult $tgt $result + set called [my ResolveInvoke \ + [dict get $vtypes $tgt] $origname $arguments] + if {$called ne {}} { + set argvals [lmap arg $arguments {my LoadOrLiteral $arg}] + my IssueInvokeFunction $tgt $called $argvals $vname + return {} + } else { + set arguments [linsert $arguments[set arguments ""] 0 $origname] + set argvals [lmap arg $arguments {my LoadOrLiteral $arg}] + my IssueInvokeCommand $tgt $arguments $argvals $vname + return $arguments + } + } + + # TclCompiler:IssueNREInvoke -- + # + # Generate the code for invoking another Tcl command by NRE. Must only be + # called from the 'compile' method. + # + # Parameters: + # callframe - + # The callframe. + # operation - + # The quadcode descriptor for the instruction. + + method IssueNREInvoke {callframe operation} { + + set arguments [lassign $operation opcode tgt thecallframe origname] + set rettype [lindex $opcode 1] + set vname [my LocalVarName $tgt] + + set called [my ResolveInvoke $rettype $origname $arguments] + if {$called ne {}} { + set argvals [lmap arg $arguments {my LoadOrLiteral $arg}] + set useCallframe [expr {callframe($thecallframe)}] + set handle [my IssueNREInvokeFunction \ + $useCallframe $callframe \ + $rettype $tgt $called $argvals $vname] + } else { + set arguments [linsert $arguments[set arguments ""] 0 $origname] + set argvals [lmap arg $arguments {my LoadOrLiteral $arg}] + my IssueNREInvokeCommand $tgt $called $arguments $argvals $vname + } } method IssueInvokeCommand {tgt resolved arguments argvals vname} { upvar 1 callframe callframe thecallframe thecallframe @@ -1293,17 +1366,40 @@ set types [lmap s $arguments {my ValueTypes $s}] if {$resolved ne ""} { # FIXME: this causes wrong "wrong # args" messages set argvals [lreplace $argvals 0 0 $resolved] } - set vector [$b buildVector $objv $types $argvals] + set vector [$b buildVector $objv $types $arguments $argvals] set result [$b invoke $vector \ [expr {callframe($thecallframe)}] $callframe \ $errorCode $vname] - $b clearVector $vector + $b clearVector $objv $types $arguments # Result type is now FAIL STRING, always. my SetErrorLine $errorCode [$b maybe $result] + if {callframe($thecallframe)} { + set result [$b frame.pack $callframe $result] + } + my StoreResult $tgt $result + } + + method IssueNREInvokeCommand {tgt resolved arguments argvals vname} { + upvar 1 callframe callframe thecallframe thecallframe + + set types [lmap s $arguments {my ValueTypes $s}] + if {$resolved ne ""} { + # FIXME: this causes wrong "wrong # args" messages + set argvals [lreplace $argvals 0 0 $resolved] + } + set vector [$b buildVector $objv $types $arguments $argvals] + $b invokeNRE $vector [expr {callframe($thecallframe)}] \ + $callframe $errorCode $vname + + # For an invoked command, we didn't launch another LLVM coroutine, + # and the Tcl status and command return value will appear + # in the current coroutine's promise. + + set result [dict get $coro_info coro_handle] if {callframe($thecallframe)} { set result [$b frame.pack $callframe $result] } my StoreResult $tgt $result } @@ -1329,21 +1425,252 @@ set expandPositions [lmap s $arguments { expr {"EXPANDED" in [my OperandType $s]} }] set argvals [lmap s $arguments {my LoadOrLiteral $s}] set types [lmap s $arguments {my ValueTypes $s}] - set vector [$b buildVector $objv $types $argvals] + set vector [$b buildVector $objv $types $arguments $argvals] set flags [$b buildBitArray $bitv $expandPositions] set result [$b invokeExpanded $vector $flags $errorCode $vname] my SetErrorLine $errorCode [$b maybe $result] if {callframe($thecallframe)} { set result [$b frame.pack $callframe $result] } my StoreResult $tgt $result - $b clearVector $vector + $b clearVector $objv $types $arguments return $arguments } + + # TclCompiler:IssueNREInvokeExpanded -- + # + # Issues the codeburst needed to handle invocation with argument + # expansion in the NRE environment. + # + # Parameters: + # callframe - LLVM reference to the call frame + # operation - The quadcode operation being compiled + # + # Results: + # None. + + method IssueNREInvokeExpanded {callframe operation} { + set arguments [lassign $operation opcode tgt thecallframe] + set rettype [lindex $opcode 1] + set vname [my LocalVarName $tgt] + set expandPositions [lmap s $arguments { + expr {"EXPANDED" in [my OperandType $s]} + }] + set argvals [lmap arg $arguments {my LoadOrLiteral $arg}] + set types [lmap s $arguments {my ValueTypes $s}] + set vector [$b buildVector $objv $types $arguments $argvals] + set flags [$b buildBitArray $bitv $expandPositions] + + $b invokeExpandedNRE $vector $flags [expr {callframe($thecallframe)}] \ + $callframe $errorCode $vname] + + # For an invoked command, we didn't launch another LLVM coroutine, and + # the Tcl status and command return value will appear in the current + # coroutine's promise. + + set result [dict get $coro_info coro_handle] + if {callframe($thecallframe)} { + set result [$b frame.pack $callframe $result] + } + my StoreResult $tgt $result + } + + # TclCompiler:IssueNREReturnFromInvoke -- + # + # Generates the code to tidy up after an invoked NRE command returns. + # + # Parameters: + # callframe - The current callframe + # operation - The quadcode operation that represents the return point + # + # Results: + # Returns the set of arguments that might have been consumed in the + # call (for cleanup by the caller of this method). + + method IssueNREReturnFromInvoke {callframe operation} { + + set arguments [lassign $operation opcode tgt corohandle origname] + set rettype [dict get $vtypes $tgt] + set vname [my LocalVarName $tgt] + set called [my ResolveInvoke $rettype $origname $arguments] + + # Built-in types that are handled here. + set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING} + set ts [lmap t $BASETYPES {Type $t?}] + set tgttype [my ValueTypes $tgt] + + if {$called ne {}} { + set destroy 1 + } else { + set destroy 0 + } + # Emit the sequence that destroys the LLVM coroutine and returns the + # result as 'retval' + lassign [my returnedIntoCoro $rettype $tgttype $corohandle $destroy] \ + callframe retcode retval + + # Clean up the arguments if needed + + if {$called eq {}} { + set arguments [linsert $arguments[set arguments ""] 0 $origname] + set types [lmap s $arguments {my ValueTypes $s}] + $b clearVector $objv $types $arguments + } + + # Handle the return + + if {$tgttype eq "FAIL"} { + # This procedure only ever fails. + $b store $retval $errorCode + my SetErrorLine $errorCode + } else { + set restype [TypeOf $retval]; # LLVM type ref of the return val + if {$restype in $ts} { + $b store [$b extract $retval 0] $errorCode + } elseif {[Type $restype?] eq [Type $tgttype]} { + set retval [$b ok $retval] + } + if {"FAIL" in $tgttype} { + my SetErrorLine $errorCode [$b maybe $retval] + } + } + # Pack a callframe reference with the return if needed + + if {"CALLFRAME" in $tgttype} { + set retval [$b frame.pack $callframe $retval] + } + + my StoreResult $tgt $retval + if {$called eq {}} { + return $arguments + } else { + return {} + } + } + + # TclCompiler:ResolveInvoke -- + # + # Determines whether an invoked command is known as a compiled + # function, and resolves it if it is. + # + # Parameters: + # type - Type of the result of the invocation + # origname - Quadcode value holding the name of the function + # being invoked + # arguments - Arguments being passed to the function being invoked + # + # Results: + # Returns either an LLVM value reference to the function to call, + # or {} if there is no known function to call and the invocation + # must go through Tcl's evaluator. + + method ResolveInvoke {type origname arguments} { + if {literal($origname)} { + set name [my FuncName [lindex $origname 1]] + set fullname [my GenerateFunctionName $name arguments $arguments] + if {[$m function.defined $fullname]} { + return [[$m function.get $fullname] ref] + } + set type [nameOfType $type] + if {"FAIL" ni $type || "STRING" ni $type} { + my Warn "$fullname is not implemented, but result is not\ + FAIL STRING." + } + } + return {} + } + + # TclCompiler:IssueInvokeFunction -- + # + # Issues the invocation sequence of a builtin function or compiled proc + # + # Parameters: + # tgt - Descriptor of the value where the result is to be stored + # func - LLVM value representing the function to invoke + # arguments - List of descriptors of the arguments to pass + # vname - Name of the result value + # + # Results: + # None + + 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"} { + $b store $result $errorCode + my SetErrorLine $errorCode + } else { + set ts [lmap t $BASETYPES {Type $t?}] + if {[TypeOf $result] in $ts} { + $b store [$b extract $result 0] $errorCode + } elseif {[Type [TypeOf $result]?] eq [Type [my ValueTypes $tgt]]} { + # Managed to prove non-failure in this case... + set result [$b ok $result] + } + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode [$b maybe $result] + } + } + if {callframe($thecallframe)} { + set result [$b frame.pack $callframe $result] + } + my StoreResult $tgt $result + } + + # TclCompiler:IssueNREInvokeFunction -- + # + # Issues the invocation sequence of a builtin function or compiled proc + # + # Parameters: + # rettype - Return type of the function to be invoked. This is + # necessary because the type of $tgt will always be + # 'LLVM coroutine handle' + # tgt - Descriptor of the value where the result is to be stored + # func - LLVM value representing the function to invoke + # arguments - List of descriptors of the arguments to pass + # vname - Name of the result value + # + # Results: + # None + + method IssueNREInvokeFunction {useCallframe callframe \ + rettype tgt func arguments vname} { + set result [$b call $func $arguments $vname] + $b launchCoroRunner $result + if {$useCallframe} { + set result [$b frame.pack $callframe $result] + } + my StoreResult $tgt $result + } + + method IssueInvokeCommand {tgt arguments argvals vname} { + upvar 1 callframe callframe thecallframe thecallframe + + set types [lmap s $arguments {my ValueTypes $s}] + + # FIXME: The front end needs to pass through command info + # prior to resolution as well as after, so as to produce + # proper error messages. This will get complicated in the + # presence of ensembles; we ignore the problem for now. + + set vector [$b buildVector $objv $types $arguments $argvals] + set result [$b invoke $vector \ + [expr {callframe($thecallframe)}] $callframe \ + $errorCode $vname] + $b clearVector $objv $types $arguments + # Result type is now FAIL STRING, always. + my SetErrorLine $errorCode [$b maybe $result] + if {callframe($thecallframe)} { + set result [$b frame.pack $callframe $result] + } + my StoreResult $tgt $result + } # TclCompiler:IssueWiden -- # # Generate the code for widening the type of a value. Must only be # called from the 'compile' method. @@ -1551,17 +1878,17 @@ return } # Need to construct the variadic vector set types [lmap s $srcs {my ValueTypes $s}] - set vector [$b buildVector $objv $types \ - [lmap s $srcs {my LoadOrLiteral $s}]] + set argvals [lmap s $srcs {my LoadOrLiteral $s}] + set vector [$b buildVector $objv $types $srcs $argvals] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes $srcDict] ) set srcDict [my LoadOrLiteral $srcDict] my StoreResult $tgt [$b $opcode $srcDict $vector $name] - $b clearVector $vector + $b clearVector $objv $types $srcs return } # TclCompiler:IssueExtract -- # @@ -1993,12 +2320,15 @@ # Type check the assignment set destType [nameOfType [dict get $vtypes $desc]] if {[Type $destType] ne [TypeOf $value]} { my Warn "Attempt to store the value\ - '[PrintValueToString $value]'\ - into a variable, '$desc', of type '$destType'" + '%s' of type '%s' \ + into a variable, '%s', of type '%s'"\ + [PrintValueToString $value] \ + [PrintTypeToString [TypeOf $value]] \ + $desc $destType } if {[lindex $desc 0] eq "var"} { if {[lindex $opcode 0] eq "phi"} { lappend phiAnnotations [lindex $desc 1] $value @@ -2098,19 +2428,19 @@ # The PC at which the 'free' occurs, or 0 if the value isn't consumed # (there is never a free as the first instruction in a function, so this # may be used as a boolean). method IsConsumed {var search} { - while 1 { - switch [lindex $quads $search 0] { + while {$search < [llength $quads]} { + switch [lindex $quads $search 0 0] { "free" { if {[lindex $quads $search 2] eq $var} { return $search } } "jump" - "jumpFalse" - "jumpTrue" - "return" - - "jumpMaybe" - "jumpMaybeNot" { + "jumpMaybe" - "jumpMaybeNot" - "NRE.return" - "NRE.suspend" { return 0 } default { if {$var in [lindex $quads $search]} { return 0 @@ -2117,10 +2447,11 @@ } } } incr search } + error "IsConsumed ran away!" } # TclCompiler:ConvertIndices -- # # Convert the most common cases of literal end-based indexing into forms @@ -2231,10 +2562,18 @@ lassign $info rt ats tmap quadcode my InitTypeInfo $ats $rt $tmap set ats [lmap t $ats {nameOfType $t}] set readableName ${cmd}([string map {" " .} [join $ats ,]]) } + + # TclInterprocedureCompiler:needsNRE -- + # + # Return 1 if the function we are compiling needs NRE, 0 otherwise. + # + method needsNRE {} { + expr {[lindex $quadcode 0 0] eq "NRE.entry"} + } # TclInterproceduralCompiler:commandName (property) -- # # Get the human-readable name of the function we are compiling/have # compiled. Note that this is not necessarily the same as the name of @@ -2265,10 +2604,28 @@ dict append opts -errorinfo \ "\n (compiling code for \"$cmd\")" return -options $opts $msg } } + + # TclInterproceduralCompiler:generateDeclaration -- + # + # Generate the declaration of the function that we transformed the + # procedure into. + # + # Parameters: + # module - Module that we're compiling into. + + method generateDeclaration {module} { + try { + my GenerateDeclaration $module $quadcode + } on error {msg opts} { + dict append opts -errorinfo \ + "\n (compiling code for \"$cmd\")" + return -options $opts $msg + } + } # TclInterproceduralCompiler:generateThunk -- # # Generate the binding into Tcl of the function that we transformed the # procedure into. @@ -2280,16 +2637,29 @@ # Results: # The function reference (i.e., instance of Function class) for the # binding function. (Not the bound function, which this class made.) method generateThunk {thunkBuilder} { + my variable returnType if {[dict exists $bytecode procmeta]} { $thunkBuilder buildProcedureMetadata $cmd $bytecode \ [dict get $bytecode procmeta] dict unset bytecode procmeta } - $thunkBuilder thunk $cmd $bytecode $func + set isNRE 0 + foreach q $quadcode { + switch -exact [lindex $q 0 0] { + "entry" { + break + } + "NRE.entry" { + set isNRE 1 + break + } + } + } + $thunkBuilder thunk $cmd $bytecode $func $isNRE [nameOfType $returnType] } # TclInterproceduralCompiler:printTypedQuads -- # # Print the sequence of typed quadcodes that the type inference engine Index: codegen/config.tcl ================================================================== --- codegen/config.tcl +++ codegen/config.tcl @@ -9,21 +9,20 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ -package require llvmtcl 3.6.2 +package require llvmtcl 3.9 package require platform namespace eval ::LLVM { namespace path ::llvmtcl variable THIS_SCRIPT [info script] variable counter 0 variable debug 0 - # Turn on debugging metadata from llvmtcl 3.6.3 onwards - variable debugmeta [package vsatisfies [package require llvmtcl] 3.6.3] + variable debugmeta 1 variable time 0 variable optimiseLevel 3 variable quadcode-log {} variable dumpPre {} variable dumpPost {} @@ -87,10 +86,11 @@ include thunk.tcl include tclapi.tcl include macros.tcl include compile.tcl include debug.tcl + include coro.tcl include jit.tcl include ../quadcode/specializer.tcl # LLVM::configure -- # ADDED codegen/coro.tcl Index: codegen/coro.tcl ================================================================== --- /dev/null +++ codegen/coro.tcl @@ -0,0 +1,510 @@ +# coro.tcl -- +# +# Various routines needed for interface to LLVM's coroutines and +# use them to implement Tcl's requirements for non-recursive evaluation. +# +# 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. +# +#----------------------------------------------------------------------------- + +oo::define Builder { + + # Implementation of various support functions needed to support Tcl's + # coroutines + + variable tcl.coro.runner + variable tcl.coro.addCallbackToCoroRunner + variable tcl.nr.add.callback +} + +# Builder method @coroFunctions -- +# +# Defines support functions for LLVM coroutines that need to be in +# LLVM assembly language. +# +# Parameters: +# module - LLVM module handle to the module under construction +# api - Handle of the Tcl API object +# +# Results: +# None. +# +# Side effects: +# Defines the support functions +# +# Called only from '@apiFunctions' + +oo::define Builder method @coroFunctions {api} { + + ##### Function tcl.coro.runner ##### + # + # Type signature: x:char** × Interp* × int32 -> int32 + # + # Parameters: + # ClientData clientDataArray [4] - Client data from the Tcl_NRAddCallback + # Only clientData[0] is used; it is + # the coroutine handle + # Tcl_Interp* interp - Tcl interpreter + # int status - Tcl status code chained from the + # last call + # + # Results: + # Returns TCL_OK. + # + # This function is the main loop of any NRE call. It is the callback + # from a Tcl_AddCallback call, and its client data is the LLVM coroutine + # frame. It also carries the result of the last Tcl callout, and that + # result will be handed off to the next LLVM continuation by storing + # it in the coroutine promise. + + set f [$m local "tcl.coro.runner" int32<-char**,Interp*,int32 noinline] + params clientDataArray interp result + build { + + # Get the coroutine handle from client data + set coro.handle [my load $clientDataArray "coro.handle"] + + # First, has the NRE proc finished execution? If so, we simply + # want to return back to the trampoline and execute the next + # callback. + + set llvm.coro.done [$m intrinsic coro.done] + set done [my call ${llvm.coro.done} [list ${coro.handle}] "doneFlag"] + my condBr $done $finished $needResume + + label needResume: + + # We will need to resume the coroutine. Stack this callback again so + # that the next time it suspends, we'll loop back to here. + + $api Tcl_NRAddCallback $interp ${tcl.coro.runner} ${coro.handle} \ + [my null char*] [my null char*] [my null char*] + + # Transfer the interpreter status into the coroutine promise + # so that the body of the coroutine can see it. + + set alignment [expr {2 * [$m alignof [Type char*]]}] + set llvm.coro.promise [$m intrinsic coro.promise] + set promise.addr.raw \ + [my call ${llvm.coro.promise} \ + [list ${coro.handle} \ + [Const $alignment int32] \ + [Const false bool]] \ + "promise.addr.raw"] + set promise.addr [my cast(ptr) ${promise.addr.raw} int32 "promise.addr"] + my store $result ${promise.addr} + + # Resume the coroutine, and return to the trampoline to await + # further developments + + set llvm.coro.resume [$m intrinsic coro.resume] + my call ${llvm.coro.resume} ${coro.handle} + + my br $finished + + label finished: + + # Either the coro is done, or we've just resumed it and need to + # see what further callbacks it may have stacked. In either case, + # return to the trampoline + + my ret [Const 0 int]; # TCL_OK + + } + + ##### Function: tcl.coro.addCallbackToCoroRunner ##### + # + # Type signature: char* -> void + # + # Parameters: + # coroHandle - Handle of the coroutine to run to the next suspension + # + # Results: + # None. + # + # This function invokes Tcl_NRAddCallback to launch a call to + # coroRunner, with the LLVM coroutine handle given by 'handle'. + + set f [$m local "tcl.coro.addCallbackToCoroRunner" void<-char*] + params coroHandle + build { + + $api Tcl_NRAddCallback [$api tclInterp] ${tcl.coro.runner} $coroHandle \ + [my null char*] [my null char*] [my null char*] + my ret + + } + + ##### Function: tcl.nr.add.callback ##### + # + # Type signature: NRCallback*×char*×char*×char*×char*->void + # + # Adds a callback to the Tcl interpreter + + set f [$m local tcl.nr.add.callback \ + void<-func{int<-ClientData*,Interp*,int}*,char*,char*,char*,char*] + params func d1 d2 d3 d4 + build { + $api Tcl_NRAddCallback [$api tclInterp] $func $d1 $d2 $d3 $d4 + my ret + } +} + +# TclCompiler method IssueNREEntrySequence -- +# +# Issues the sequence of code that begins an LLVM coroutine +# that corresponds to an NRE Tcl procedure. +# +# Parameters: +# currentBlock - The current block being built in +# nextBlock - The block that will follow the current block, which +# is the actual entry to the procedure. +# +# Results: +# Returns a dictionary with values that will be needed for other +# actions within the procedure body. The following keys will be +# included: +# +# cleanup - Block to which control must transfer on final exit +# from this procedure or if the coroutine is killed. +# coro_handle - Handle of this coroutine +# exit - Block to which control must transfer on return from +# this procedure at Tcl level. +# promise - LLVM value containing the address of this coroutine's promise +# suspend - Block to which all returns from this coroutine eventually +# transfer + +oo::define TclCompiler method IssueNREEntrySequence {currentBlock nextBlock} { + + $currentBlock build-in $b + $b @location 0 + + # Basic blocks in the function entry sequence + + set alloc_frame [$func block "coro.alloc.frame"] + set begin [$func block "coro.begin"] + + # Basic blocks in the function exit sequence + + set exit [$func block "coro.exit"] + set trap [$func block "coro.trap"] + set cleanup [$func block "coro.cleanup"] + set free_frame [$func block "coro.free.frame"] + set suspend [$func block "coro.suspend"] + + # Allocate the coroutine promise + + set alignment [$m alignof [Type [my CoroPromiseType]]] + set promise [$b alloc [my CoroPromiseType] "coro,promise"] + $b align $promise $alignment + set clientData [$b cast(ptr) $promise char] + + # Get a coroutine ID + + set llvm.coro.id [$m intrinsic coro.id] + set coro_id [$b call ${llvm.coro.id} \ + [list [Const $alignment int32] $clientData \ + [$b null char*] [$b null char*]] "coro.id"] + + # Determine whether coroutine frame elision has been performed + + set llvm.coro.alloc [$m intrinsic coro.alloc] + set needToAlloc [$b call ${llvm.coro.alloc} [list $coro_id] \ + "coro.need.to.alloc"] + $b condBr $needToAlloc $alloc_frame $begin + + $alloc_frame build-in $b + $b @location 0 + + # Allocate the coroutine frame + + set llvm.coro.size [$m intrinsic coro.size int32] + set coro_size [$b call ${llvm.coro.size} {} "coro.size"] + set coro_alloc [$b Tcl_Alloc $coro_size "coro.frame.alloc"] + $b br ${begin} + + # Start the coroutine with the newly allocated frame + + $begin build-in $b + $b @location 0 + + set coro_frame [$b phi \ + [list [$b null char*] $coro_alloc] \ + [list $currentBlock $alloc_frame] \ + "coro.frame"] + set llvm.coro.begin [$m intrinsic coro.begin] + set coro_handle [$b call ${llvm.coro.begin} [list $coro_id $coro_frame] \ + "coro.handle"] + + # Suspend the coroutine immediately to allow it to be restarted + # from a TclNR calllback. Upon resumption, go to the entry block. + + set llvm.coro.suspend [$m intrinsic coro.suspend] + set result [$b call ${llvm.coro.suspend} \ + [list [ConstNone] [Const false bool]] "coro.suspend.result"] + $b switch $result $suspend 0 $nextBlock 1 $cleanup + + ######################################################################## + + # Now generate the exit sequence. We need to do this in advance, + # because invoke and return operations inside the body of the procedure + # need to reference it. + + $exit build-in $b + $b @location 0 + + set result [$b call ${llvm.coro.suspend} \ + [list [ConstNone] [Const true bool]] "coro.suspend.result"] + $b switch $result $suspend 0 $trap 1 $cleanup + + # Following the final suspend a coro cannot be called again, so invoke + # nasal daemons if this should happen + + $trap build-in $b + $b @location 0 + + set llvm.trap [$m intrinsic trap] + $b call ${llvm.trap} {} + $b unreachable + + # Free the coroutine frame if necessary + + $cleanup build-in $b + $b @location 0 + + set llvm.coro.free [$m intrinsic coro.free] + set coro_frame [$b call ${llvm.coro.free} [list $coro_id $coro_handle] \ + "coro.frame"] + set coro_need_free [$b neq $coro_frame [$b null char*] \ + "coro.frame.need.to.free"] + $b condBr $coro_need_free $free_frame $suspend + + $free_frame build-in $b + $b @location 0 + + $b Tcl_Free $coro_frame + $b br $suspend + + # All exits from the coroutine, whether because it has finished, + # suspended, or been killed, come here to return. + + $suspend build-in $b + $b @location 0 + + set llvm.coro.end [$m intrinsic coro.end] + $b call ${llvm.coro.end} [list $coro_handle [Const false bool]] + $b ret $coro_handle + + return [dict create \ + cleanup $cleanup \ + coro_handle $coro_handle \ + exit $exit \ + promise $promise \ + suspend $suspend] +} + +# TclCompiler method CoroPromiseType -- +# +# Generates the LLVM type that represents the coroutine promise for +# the current NRE function + +oo::define TclCompiler method CoroPromiseType {{rettype {}}} { + namespace upvar ::quadcode::dataType CALLFRAME CALLFRAME + if {$rettype eq {}} { + set rettype $returnType + } + set rettype [expr {$rettype & ~$CALLFRAME}] + set typestr named + append typestr \{ [nameOfType $rettype] .promise + append typestr , status:int32 + append typestr , retval: [nameOfType $rettype] + append typestr \} + return [Type $typestr] +} + +# Builder method launchCoroRunner -- +# +# Generates code to launch the Tcl_NRAddCallback chain that executes +# the LLVM coroutine representing a Tcl command invocation. +# +# Parameters: +# handle - LLVM value reference specifying the LLVM coroutine handle + +oo::define Builder method launchCoroRunner {handle} { + my call ${tcl.coro.addCallbackToCoroRunner} $handle +} + +# Builder method NRAddCallback -- +# +# Add a callback to the current interpreter +# +# Parameters: +# func - LLVM reference to the callback function +# args - LLVM references to up to four client data objects +# +# Results: +# None. + +oo::define Builder method NRAddCallback {func args} { + set argv {} + if {[llength $args] > 4} { + error "at most four client data objects can be passed to a callback" + } + set argv [lmap a $args {my cast(ptr) $a int8}] + while {[llength $argv] < 4} { + lappend argv [my null int8*] + } + my call ${tcl.nr.add.callback} [linsert $argv 0 $func] +} +oo::define Builder export NRAddCallback + +# TclCompiler method returnedIntoCoro -- +# +# Generates code to retrieve the status and return value from +# a coroutine that has done the final suspend or an invoked NRE +# command. +# +# Parameters: +# rettype - The function's return type +# tgttype - The type of the target value +# corohandle - The handle to the coroutine that ran the invoked function +# destroy - Flag == 1 if this was a return from another coroutine +# that must be destroyed, 0 if it's a return from a +# Tcl_NRAddCallback chain in the same coroutine +# +# Results: +# Returns a list of two LLVM value refs: the status code and the +# return value. + +oo::define TclCompiler method returnedIntoCoro {rettype tgttype + corohandle destroy} { + + # Retrieve the coroutine promise from the coroutine handle + + set handle [my LoadOrLiteral $corohandle] + set frame {} + if {"CALLFRAME" in $tgttype} { + set frame [$b frame.frame $handle] + set handle [$b frame.value $handle] + } + set ptype [my CoroPromiseType $rettype] + set alignment [Const [$m alignof $ptype] int32] + set paddr_raw [$b call [$m intrinsic coro.promise] \ + [list $handle $alignment [Const false bool]] \ + "promise.addr.raw"] + set paddr [$b cast(ptr) $paddr_raw $ptype "promise.addr"] + + # Retrieve the return code and return value of the called procedure + + set rcodeaddr [$b gep $paddr 0 0] + set rcode [$b load $rcodeaddr "return.code"] + + # Destroy the coroutine - we're done with it now. + + if {$destroy} { + set rvaladdr [$b gep $paddr 0 1] + set rval [$b load $rvaladdr "return.value"] + $b call [$m intrinsic coro.destroy] [list $handle] + } else { + set rval [$b getNRCommandReturnValue $rcode $errorCode "return.value"] + if {"CALLFRAME" in $tgttype} { + # Return from an invoked function may need to restore the callframe + $b restoreFrame $frame + } + } + + # Return the status and result + + return [list $frame $rcode $rval] +} + +# Builder method getNRCommandReturnValue -- +# +# Retrieves the return value of a noncompiled command invoked by NRE +# +# Parameters: +# rcode - Return code of the invoked command +# ecvar - LLVM variable reference of where to put the return code +# name - (Optional) name to assign to the result +# +# Results: +# Returns an LLVM STRING? value + +oo::define Builder method getNRCommandReturnValue {rcode ecvar {name {}}} { + my call ${tcl.nr.command.result} [list $rcode $ecvar] $name +} + +# TclCompiler method NRReturnToThunk -- +# +# Generates the codeburst to return to a call thunk when a compiled +# NRE procedure returns. +# +# Parameters: +# handle - LLVM value reference to the LLVM coroutine for the +# wrapped function invocation +# restype - Type of the result that is stored in the coroutine promise +# +# Results: +# Returns the LLVM value reference to the result of the wrapped function + +oo::define Builder method NRReturnToThunk {handle resType} { + set promiseType named{$resType.promise,int32,$resType} + set alignment [$m alignof [Type $promiseType]] + set llvm.coro.promise [$m intrinsic coro.promise] + set promiseAddrRaw [my call ${llvm.coro.promise} \ + [list $handle [Const $alignment int32] \ + [Const false bool]] "promise.addr.raw"] + set promiseAddr [my cast(ptr) $promiseAddrRaw $promiseType] + set value [my load [my gep $promiseAddr 0 1] "value"] + set llvm.coro.destroy [$m intrinsic coro.destroy] + my call ${llvm.coro.destroy} $handle + return $value +} +oo::define Builder export NRReturnToThunk + +# TclCompiler method CoroSuspend -- +# +# Generates code to suspend the current coroutine and resume at a +# specified basic block. +# +# Parameters: +# coro_info - Information about the current LLVM coroutine from +# IssueNREEntrySequence +# blk - Basic block at which control resumes +# +# Results: +# None. + +oo::define TclCompiler method CoroSuspend {coro_info blk} { + + set llvm.coro.suspend [$m intrinsic coro.suspend] + set result \ + [$b call ${llvm.coro.suspend} [list [ConstNone] [Const false bool]] \ + "coro.suspend.result"] + $b switch $result [dict get $coro_info suspend] \ + 0 $blk 1 [dict get $coro_info cleanup] + +} + +# TclCompiler method CoroReturn -- +# +# Generates code to return from the current NRE procedure by +# storing result data in the promise and performing the 'final +# suspend' of the LLVM coroutine. +# +# Parameters: +# coro_info - Information about the current LLVM coroutine from +# IssueNREEntrySequence +# retval - Value to return from the procedure + +oo::define TclCompiler method CoroReturn {coro_info retval} { + set promise [dict get $coro_info promise] + set statPtr [$b gep $promise 0 0] + $b store [Const 0 int32] $statPtr + set valPtr [$b gep $promise 0 1] + $b store $retval $valPtr + $b br [dict get $coro_info exit] +} Index: codegen/jit.tcl ================================================================== --- codegen/jit.tcl +++ codegen/jit.tcl @@ -102,10 +102,12 @@ timeit init-module { set ns [uplevel 1 {namespace current}] set name [SelectModuleName $ns] set module [Module new $name] + + $module mcjit # Get an instance of the system that glues things to the Tcl # runtime. set thunkBuilder [ThunkBuilder new $module] set sp [quadcode::specializer new] @@ -157,10 +159,11 @@ # finalise the thunks, which finishes building the module's # init function. foreach c $publicInterface { $c generateThunk $thunkBuilder } + $thunkBuilder finalize } timeit dump-pre { # Save the current IR @@ -171,10 +174,18 @@ # Check that what we have is actually correct! $module verify if {$debug} { parray ::useCount } + set bitcodeFinal [$module bitcode] + set f_ [open test.bc wb] + puts -nonewline $f_ $bitcodeFinal + close $f_ + set dumpFinal [$module dump] + set f_ [open test.ll w] + puts $f_ $dumpFinal + close $f_ timeit optimize { # Run the LLVM IR optimizer. The configuration of this is in # llvmtcl and is due to Jos Decoster. $module optimize $optimiseLevel @@ -182,16 +193,18 @@ timeit dump-post { # Save the current IR variable dumpPost [$module dump] variable bitcodePost [$module bitcode] + set f_ [open opt.ll w] + puts $f_ $dumpPost + close $f_ } timeit assemble { # Call the package init function. This causes native code to # be issued and linked. - $module mcjit $thunkBuilder install } # Return the LLVM handle to the module, just in case. # @@ -252,10 +265,11 @@ set cmds [lsort -unique $cmds] set ns [uplevel 1 {namespace current}] set name [SelectModuleName $ns] set module [Module new $name] + $module prepareToCompile # Get an instance of the system that glues things to the Tcl runtime. set thunkBuilder [ThunkBuilder new $module] set sp [quadcode::specializer new] @@ -429,10 +443,11 @@ # really wants. set cmds [lsort -unique $packageProcedures($p_id)] unset -nocomplain packageProcedures($p_id) set name [SelectModuleName $packageName] set module [Module new $name $pkgfile] + $module prepareToCompile # Get an instance of the system that glues things to the Tcl runtime. set thunkBuilder [ThunkBuilder new $module] set sp [quadcode::specializer new] Index: codegen/llvmbuilder.tcl ================================================================== --- codegen/llvmbuilder.tcl +++ codegen/llvmbuilder.tcl @@ -70,10 +70,28 @@ } elseif {[GetTypeKind [TypeOf $left]] ne "LLVMIntegerTypeKind"} { return -code error "values must be integers" } my Locate [BuildNSWAdd $b $left $right $name] } + + # Builder:align -- + # + # Set the alignment on an LLVM value + # + # Parameters: + # v - Value to set the alignment on + # align - Integer alignment in bytes - must be a power of 2 + + method align {v align} { + if {![string is integer $align] + || $align <= 0 + || ($align & ($align - 1)) != 0} { + return -code error "alignment must be a power of 2" + } + return [SetAlignment $v $align] + } + # Builder:alloc -- # # Generate code to allocate a writable memory location on the stack. # @@ -87,10 +105,32 @@ method alloc {type {name ""}} { my @validToIssue my Locate [BuildAlloca $b [Type $type] $name] } + + # Builder:allocInBlock -- + # + # Generates an 'alloca' instruction, but puts it in a block other than + # the current one. + # + # Parameters: + # block - Block to place the alloc + # type - LLVM type reference of the type to allocate + # name - Name to assign to the result + # + # Results: + # Returns a LLVM value reference to the pointer to the allocated space + + method allocInBlock {block type name} { + set here [my @cur] + my @end $block + my @validToIssue + set ref [my alloc $type $name] + my @end $here + return $ref + } # Builder:and -- # # Generate code to compute the bitwise-and of two integers of the same # bit width. @@ -136,10 +176,38 @@ if {[GetTypeKind [TypeOf $size]] ne "LLVMIntegerTypeKind"} { return -code error "size must be integer" } my Locate [BuildArrayAlloca $b [Type $type] $size $name] } + + # Builder:arrayAllocInBlock -- + # + # Generate code to allocate a contiguous array of memory cells on the + # stack, placing it in a block other than the current one. + # + # Parameters: + # block - The LLVM block reference of the block where the alloc should go + # type - The type of each of the memory cells. + # size - The number of cells to create as an int[X] LLVM value + # reference. (X is the same as for the 'left' parameter.) + # name (optional) - + # A name to give to the result value. + # + # Results: + # A pointer to the first cell in the array. + + method arrayAllocInBlock {block type size {name ""}} { + if {[GetTypeKind [TypeOf $size]] ne "LLVMIntegerTypeKind"} { + return -code error "size must be integer" + } + set here [my @cur] + my @end $block + my @validToIssue + set ref [my Locate [BuildArrayAlloca $b [Type $type] $size $name]] + my @end $here + return $ref + } # Builder:br -- # # Branch unconditionally to another basic block. Widely used, marks the # end of the current basic block. Quadcode implementation ('jump'). @@ -1216,11 +1284,11 @@ # # Results: # LLVM constant int reference. method sizeof {type} { - SizeOf [Type $type] + Const [$m sizeof [Type $type]] int64 } # Builder:store -- # # Generate code to write a value to a memory location. The value MUST be @@ -1352,10 +1420,20 @@ # An undef LLVM value reference of the given type. method undef {type} { GetUndef [Type $type] } + + # Builder:unreachable -- + # + # Indicate that a particular point in the instruction sequence + # is unreachable. + + method unreachable {} { + my @validToIssue + my Locate [BuildUnreachable $b] + } # Builder:xor -- # # Generate code to compute the bitwise-xor of two integers of the same # bit width. Index: codegen/mathlib.tcl ================================================================== --- codegen/mathlib.tcl +++ codegen/mathlib.tcl @@ -936,13 +936,13 @@ set n0 [my getInt64 $y "n.enter"] # These are stand-ins for values that we've not generated yet my br $loop(test) label loop(test) "loop.test" set sources {$entry $loop(double)} - set thisn [PHI [Type int64] {$n0 $nLoop} $sources "n.test"] - set xbody [PHI [Type INT] {$x $xLoop} $sources "x.test"] - set result [PHI [Type INT] {$r0 $rLoop} $sources "result.test"] + set thisn [PHI int64 {$n0 $nLoop} $sources "n.test"] + set xbody [PHI INT {$x $xLoop} $sources "x.test"] + set result [PHI INT {$r0 $rLoop} $sources "result.test"] my condBr [my neq $thisn $0] $loop(bit0) $loop(result) label loop(result) "result" my ret $result label loop(bit0) "loop.bit0" my condBr [my cmpInt [my and $thisn $1] NE $0] \ @@ -1313,11 +1313,10 @@ my br $get label get: set bytes [my phi [list $b1 $b2] [list $entry $generate] "bytes"] my ret [my eq [my dereference $bytes 0] [Const 0 int8]] } - ##### Function tcl.isNumeric ##### # # Type signature: value:STRING -> ZEROONE # Index: codegen/stdlib.tcl ================================================================== --- codegen/stdlib.tcl +++ codegen/stdlib.tcl @@ -57,15 +57,19 @@ # Variables holding implementations of Tcl's exception-handling machinery variable tcl.getresult tcl.getreturnopts tcl.initExceptionOptions variable tcl.initExceptionSimple tcl.processReturn tcl.procedure.return variable tcl.setErrorLine tcl.existsOrError tcl.logCommandInfo - variable tcl.handleExceptionResult tcl.invoke.command tcl.invoke.expanded + variable tcl.handleExceptionResult tcl.invoke.command + variable tcl.invoke.command.nre tcl.nr.command.result tcl.invoke.expanded + variable tcl.invoke.expanded.nre tcl.restoreFrame # Helper functions variable tcl.impl.trimleft tcl.impl.trimright obj.cleanup variable tcl.impl.getIndex tcl.impl.listDupe + variable tcl.alloc tcl.free + variable tcl.vector.clear # Reference to the module object variable m # Builder:ReferenceFunctions -- @@ -418,21 +422,19 @@ nonnull $objv my br $entry label entry: my br $loop label loop: - set count_loop [my phi [list $objc] [list $entry] "count"] + set count_loop [PHI int {$objc $count_freeOne} {$entry $freeOne} "count"] set res [my cmpInt $count_loop SGT [Const 0 int]] my condBr $res $freeOne $done label freeOne: set count_freeOne [my sub $count_loop [Const 1 int] "count"] set obj [my load [my getelementptr $objv $count_freeOne]] my br $loop label done: my ret - - AddIncoming $count_loop $count_freeOne [my LABEL $freeOne] } return } @@ -584,10 +586,11 @@ } if {[TypeOf $source] ne $vt} { set source [my cast(ptr) $source void] } if {[CountParamTypes [GetElementType [TypeOf $memcpy]]] == 5} { + # Alignment parameter only needed before LLVM 7 my Call memcpy $target $source $length \ [Const 0] [Const false bool] } else { my Call memcpy $target $source $length [Const false bool] } @@ -611,10 +614,11 @@ set memset [$m intrinsic memset $vt [TypeOf $length]] if {[TypeOf $target] ne $vt} { set target [my cast(ptr) $target void] } if {[CountParamTypes [GetElementType [TypeOf $memset]]] == 5} { + # Alignment parameter only needed before LLVM 7 my Call memset $target [Const 0 int8] $length \ [Const $alignment] [Const false bool] } else { my Call memset $target [Const 0 int8] $length \ [Const false bool] @@ -743,10 +747,14 @@ set f [$m local "tcl.impl.getBoolean" struct{int1,int1}<-STRING] params valueObj build { nonnull $valueObj set boolVar [my alloc int32 "boolPtr"] +# The following does not work +# set sizeofBool [my castPtr2Int [my gep [my null int32*] 1] \ +# int64 sizeof(int)] + set sizeofBool [Const 4 int64] set str [$api Tcl_GetString $valueObj] set code [$api Tcl_GetBooleanFromObj {} $valueObj $boolVar] set res [my undef struct{int1,int1}] set res [my insert $res [my eq $code [Const 0]] 0] set res \ @@ -755,11 +763,10 @@ } my closure GetBoolean {valueObj} { my call ${tcl.impl.getBoolean} [list $valueObj] "result" } unset -nocomplain valueObj - ##### Function tcl.impl.getDouble ##### ##### MAPPED CALL TO METHOD: Build:GetDouble ##### # # Type signature: valueObj:STRING -> int * int8[] @@ -994,22 +1001,20 @@ my condBr [my eq $numTrim $0] $ret0 $outerLoop label ret0: my ret $0 label outerLoop: set sources {$checkTrim $nextOuter} - set p [PHI [Type char*] {$bytes $pLoop} $sources "p"] - set numBytes2 [PHI [Type int] {$numBytes $nbLoop} $sources \ - "numBytes.2"] + set p [PHI char* {$bytes $pLoop} $sources "p"] + set numBytes2 [PHI int {$numBytes $nbLoop} $sources "numBytes.2"] set pInc [$api Tcl_UtfToUniChar $p $chVar] SetValueName $pInc "pInc" set ch1 [my load $chVar "ch1"] my br $innerLoop label innerLoop: set sources [list $outerLoop $nextInner] - set q [PHI [Type char*] {$trim $qLoop} $sources "q"] - set bytesLeft [PHI [Type int] {$numTrim $blLoop} $sources \ - "bytesLeft"] + set q [PHI char* {$trim $qLoop} $sources "q"] + set bytesLeft [PHI int {$numTrim $blLoop} $sources "bytesLeft"] set qInc [$api Tcl_UtfToUniChar $q $chVar] SetValueName $qInc "qInc" set ch2 [my load $chVar "ch2"] my condBr [my eq $ch1 $ch2] $doneInner $nextInner label nextInner: @@ -1052,24 +1057,22 @@ my condBr [my eq $numTrim $0] $ret0 $outerLoop label ret0: my ret $0 label outerLoop: set sources [list $checkTrim $nextOuter] - set p1 [PHI [Type char*] {$p0 $pLoop} $sources "p.1"] - set numBytes1 [PHI [Type int] {$numBytes $nbLoop} $sources \ - "numBytes.1"] + set p1 [PHI char* {$p0 $pLoop} $sources "p.1"] + set numBytes1 [PHI int {$numBytes $nbLoop} $sources "numBytes.1"] set p2 [$api Tcl_UtfPrev $p1 $bytes] SetValueName $p2 "p.2" set pInc [$api Tcl_UtfToUniChar $p2 $chVar] SetValueName $pInc "pInc" set ch1 [my load $chVar "ch1"] my br $innerLoop label innerLoop: set sources [list $outerLoop $nextInner] - set q [PHI [Type char*] {$trim $qLoop} $sources "q"] - set bytesLeft [PHI [Type int] {$numTrim $blLoop} $sources \ - "bytesLeft"] + set q [PHI char* {$trim $qLoop} $sources "q"] + set bytesLeft [PHI int {$numTrim $blLoop} $sources "bytesLeft"] set qInc [$api Tcl_UtfToUniChar $q $chVar] SetValueName $qInc "qInc" set ch2 [my load $chVar "ch2"] my condBr [my eq $ch1 $ch2] $doneInner $nextInner label doneInner: @@ -1152,95 +1155,95 @@ 0 $alnum 1 $alpha 2 $ascii 3 $control \ 4 $digit 5 $graph 6 $lower 7 $print \ 8 $punct 9 $space 10 $upper 11 $word set n [list $1] label alnum: - set p [PHI [Type int16*] {$string $p0} {$test $alnumNext} "p"] + set p [PHI int16* {$string $p0} {$test $alnumNext} "p"] my condBr [my neq [$api Tcl_UniCharIsAlnum [my load $p]] $0] \ $alnumNext $fail label alnumNext "alnum.next" set p0 [my getelementptr $p $n "p.0"] my condBr [my lt $p0 $end] $alnum $match label alpha: - set p [PHI [Type int16*] {$string $p1} {$test $alphaNext} "p"] + set p [PHI int16* {$string $p1} {$test $alphaNext} "p"] my condBr [my neq [$api Tcl_UniCharIsAlpha [my load $p]] $0] \ $alphaNext $fail label alphaNext "alpha.next" set p1 [my getelementptr $p $n "p.1"] my condBr [my lt $p1 $end] $alpha $match label ascii: - set p [PHI [Type int16*] {$string $p2} {$test $asciiNext} "p"] + set p [PHI int16* {$string $p2} {$test $asciiNext} "p"] my condBr [my Call tcl.impl.isAscii [my load $p]] \ $asciiNext $fail label asciiNext "ascii.next" set p2 [my getelementptr $p $n "p.2"] my condBr [my lt $p2 $end] $ascii $match label control: - set p [PHI [Type int16*] {$string $p3} {$test $controlNext} "p"] + set p [PHI int16* {$string $p3} {$test $controlNext} "p"] my condBr [my neq [$api Tcl_UniCharIsControl [my load $p]] $0] \ $controlNext $fail label controlNext "control.next" set p3 [my getelementptr $p $n "p.3"] my condBr [my lt $p3 $end] $control $match label digit: - set p [PHI [Type int16*] {$string $p4} {$test $digitNext} "p"] + set p [PHI int16* {$string $p4} {$test $digitNext} "p"] my condBr [my neq [$api Tcl_UniCharIsDigit [my load $p]] $0] \ $digitNext $fail label digitNext "digit.next" set p4 [my getelementptr $p $n "p.4"] my condBr [my lt $p4 $end] $digit $match label graph: - set p [PHI [Type int16*] {$string $p5} {$test $graphNext} "p"] + set p [PHI int16* {$string $p5} {$test $graphNext} "p"] my condBr [my neq [$api Tcl_UniCharIsGraph [my load $p]] $0] \ $graphNext $fail label graphNext "graph.next" set p5 [my getelementptr $p $n "p.5"] my condBr [my lt $p5 $end] $graph $match label lower: - set p [PHI [Type int16*] {$string $p6} {$test $lowerNext} "p"] + set p [PHI int16* {$string $p6} {$test $lowerNext} "p"] my condBr [my neq [$api Tcl_UniCharIsLower [my load $p]] $0] \ $lowerNext $fail label lowerNext "lower.next" set p6 [my getelementptr $p $n "p.6"] my condBr [my lt $p6 $end] $lower $match label print: - set p [PHI [Type int16*] {$string $p7} {$test $printNext} "p"] + set p [PHI int16* {$string $p7} {$test $printNext} "p"] my condBr [my neq [$api Tcl_UniCharIsPrint [my load $p]] $0] \ $printNext $fail label printNext "print.next" set p7 [my getelementptr $p $n "p.7"] my condBr [my lt $p7 $end] $print $match label punct: - set p [PHI [Type int16*] {$string $p8} {$test $punctNext} "p"] + set p [PHI int16* {$string $p8} {$test $punctNext} "p"] my condBr [my neq [$api Tcl_UniCharIsPunct [my load $p]] $0] \ $punctNext $fail label punctNext "punct.next" set p8 [my getelementptr $p $n "p.8"] my condBr [my lt $p8 $end] $punct $match label space: - set p [PHI [Type int16*] {$string $p9} {$test $spaceNext} "p"] + set p [PHI int16* {$string $p9} {$test $spaceNext} "p"] my condBr [my neq [$api Tcl_UniCharIsSpace [my load $p]] $0] \ $spaceNext $fail label spaceNext "space.next" set p9 [my getelementptr $p $n "p.9"] my condBr [my lt $p9 $end] $space $match label upper: - set p [PHI [Type int16*] {$string $p10} {$test $upperNext} "p"] + set p [PHI int16* {$string $p10} {$test $upperNext} "p"] my condBr [my neq [$api Tcl_UniCharIsUpper [my load $p]] $0] \ $upperNext $fail label upperNext "upper.next" set p10 [my getelementptr $p $n "p.10"] my condBr [my lt $p10 $end] $upper $match label word: - set p [PHI [Type int16*] {$string $p11} {$test $wordNext} "p"] + set p [PHI int16* {$string $p11} {$test $wordNext} "p"] my condBr [my neq [$api Tcl_UniCharIsWordChar [my load $p]] $0] \ $wordNext $fail label wordNext "word.next" set p11 [my getelementptr $p $n "p.11"] my condBr [my lt $p11 $end] $word $match label xdigit: - set p [PHI [Type int16*] {$string $p12} {$test $xdigitNext} "p"] + set p [PHI int16* {$string $p12} {$test $xdigitNext} "p"] my condBr [my Call tcl.impl.isXdigit [my load $p]] \ $xdigitNext $fail label xdigitNext "xdigit.next" set p12 [my getelementptr $p $n "p.12"] my condBr [my lt $p12 $end] $xdigit $match @@ -2422,11 +2425,11 @@ label sublistInplace "sublist.inPlace" set onePast [my add $to $1 "onePast"] my br $sublistInplaceFreeTest label sublistInplaceFreeTest "sublist.inPlace.loop.test" set sources {$sublistInplace $sublistInplaceFree} - set index [PHI [Type int32] {$onePast $loopIndex} $sources "index"] + set index [PHI int32 {$onePast $loopIndex} $sources "index"] my condBr [my lt $index $objc] \ $sublistInplaceFree $sublistInplaceDone label sublistInplaceFree "sublist.inPlace.loop.body" set loopIndex [my add $index $1 "index"] set obj [my load [my getelementptr $objv [list $index]] "objPtr"] @@ -2509,11 +2512,11 @@ label sublistInplace "sublist.inPlace" set onePast [my add $to $1 "onePast"] my br $sublistInplaceFreeTest label sublistInplaceFreeTest "sublist.inPlace.free.test" set sources {$sublistInplace $sublistInplaceFree} - set index [PHI [Type int32] {$onePast $loopIndex} $sources "index"] + set index [PHI int32 {$onePast $loopIndex} $sources "index"] my condBr [my lt $index $objc] \ $sublistInplaceFree $sublistInplaceDone label sublistInplaceFree "sublist.inPlace.free" set loopIndex [my add $index $1 "index"] set obj [my load [my getelementptr $objv [list $index]] "objPtr"] @@ -2758,11 +2761,12 @@ noalias $ecvar nonnull $list $idxArg $elem $ecvar set ary [my alloc STRING] set argc [my alloc int] set argv [my alloc STRING*] - my condBr [my eq [my dereference $idxArg 0 Tcl_Obj.typePtr] [$api tclListType]] \ + my condBr [my eq [my dereference $idxArg 0 Tcl_Obj.typePtr] \ + [$api tclListType]] \ $doCopy $checkIndex label checkIndex "check.index" my condBr [my GetIndex {} $idxArg $0] $doFlat $doCopy label doFlat "flat" my store $idxArg $ary @@ -2802,11 +2806,11 @@ label realCheck: set objc [my load $lenVar "objc"] set objv [my load $objvVar "objv"] my condBr [my gt $objc $0] $loop $done label loop: - set i [PHI [Type int32] {$0 $iLoop} {$realCheck $loopNext} "i"] + set i [PHI int32 {$0 $iLoop} {$realCheck $loopNext} "i"] set obj [my load [my getelementptr $objv [list $i]] "obj"] lassign [my GetString $obj "element"] len2 bytes2 my condBr [my eq $len1 $len2] $loopCompare $loopNext label loopCompare: my condBr [my eq [my memcmp $bytes1 $bytes2 $len1] $0] \ @@ -2816,11 +2820,11 @@ my condBr [my lt $i $objc] $loop $done label fail: my store $1 $ecVar my ret [my fail ZEROONE] label done: - set flag [my phi [list [Const false bool] [Const false bool] [Const true bool]] \ + set flag [my phi [lmap flag {false false true} {Const $flag bool}] \ [list $realCheck $loopNext $loopCompare] "flag"] my ret [my ok $flag] } ##### Function tcl.list.unshare ##### @@ -2907,11 +2911,10 @@ set pair [my undef FOREACH] set pair [my insert $pair $0 FOREACH.val] set pair [my insert $pair [my unmaybe $steps] FOREACH.max] my ret [my ok $pair] } - ##### Function tcl.list.foreach.getStep ##### # # Type signature: pair:FOREACH -> INT # @@ -4325,11 +4328,10 @@ nonnull $objPtr set NULL [my null Interp*] set code [my setFromAny [$api tclBooleanType] $NULL $objPtr] my ret [my eq $code $0] } - ##### Function tcl.invoke.command ##### # # Type signature: objc:int * objv:STRING* * ecvar:int* -> STRING? # @@ -4357,14 +4359,64 @@ label ok: set result [$api Tcl_GetObjResult $interp] my addReference(STRING) $result my ret [my ok $result] label fail: - set code [my phi [list $code1 $code2] [list $stdInvoke $frameInvoke] "code"] + set code [PHI int {$code1 $code2} {$stdInvoke $frameInvoke} "code"] my store $code $ecvar my ret [my fail STRING $code] } + + ##### Function tcl.invoke.command.nre ##### + # + # Type signature: objc:int × objv:STRING* × frame:CALLFRAME × ecvar:int* + # -> CALLFRAME + # + # Calls the Tcl interpreter to invoke a Tcl command by means of + # Tcl_NREvalObjv. Returns the callframe before the invocation if the + # callframe was swizzled to do the invoke, NULL otherwise. + + set f [$module local "tcl.invoke.command.nre" \ + CALLFRAME<-int,STRING*,CALLFRAME,int*] + params objc objv frame ecvar + build { + noalias $objv $frame $ecvar + nonnull $objv $ecvar + set interp [$api tclInterp] + my condBr [my nonnull $frame] $frameInvoke $stdInvoke + label stdInvoke "invoke.standard" + $api Tcl_NREvalObjv $interp $objc $objv $0 + my ret [my null CALLFRAME] + label frameInvoke "invoke.with.callframe" + set vfp [my gep $interp 0 Interp.varFramePtr] + set vf [my load $vfp] + my store $frame $vfp + $api Tcl_NREvalObjv $interp $objc $objv $0 + my ret $vf + } + + ##### Function tcl.nr.command.result ##### + # + # Type signature: ecode:int × ecvar:int* -> STRING? + # + # Retrieves the value of a command invoked by tcl.invoke.command.nre + # after the command has returned. + + set f [$module local "tcl.nr.command.result" STRING?<-int,int*] + params ecode ecvar + build { + noalias $ecvar + nonnull $ecvar + my condBr [my eq $ecode $0] $ok $fail + label ok: + set result [$api Tcl_GetObjResult [$api tclInterp]] + my addReference(STRING) $result + my ret [my ok $result] + label fail: + my store $ecode $ecvar + my ret [my fail STRING $ecode] + } ##### Function tcl.invoke.expanded ##### # # Type signature: objc:int * objv:STRING* * flags:bool* * ecvar:int* # -> STRING? @@ -4450,10 +4502,118 @@ my ret [my ok $result] label fail: my store $code $ecvar my ret [my fail STRING $code] } + + ##### Function tcl.invoke.expanded.nre ##### + # + # Type signature: objc:int * objv:STRING* * flags:bool* + # * frame:CALLFRAME * ecvar:int* -> CALLFRAME + # + # Calls the Tcl interpreter to invoke a Tcl command by means of + # Tcl_NREvalObjv, first expanding the arguments indicate by the flags + # array (which will have objc elements in it). Returns the callframe + # before the invocation if the callframe was swizzled to do the + # invoke, NULL otherwise. + + set f [$module local "tcl.invoke.expanded.nre" \ + CALLFRAME<-int,STRING*,bool*,CALLFRAME,int*] + params objc objv flags frame ecvar + build { + noalias $objv $flags $frame $ecvar + nonnull $objv $flags $ecvar + set iPtr [my alloc int "i"] + set jPtr [my alloc int "j"] + set lenPtr [my alloc int "len"] + set objcPtr [my alloc int "objcPtr"] + set objvPtr [my alloc STRING* "objvPtr"] + set tclobjSize [my cast(int) [my sizeof STRING]] + set interp [$api tclInterp] + my store $0 $iPtr + my store $0 $lenPtr + my br $findLenTest + label findLenTest "test.findLength" + set i [my load $iPtr "i"] + my condBr [my lt $i $objc] $findLenBody $setupExpansion + label findLenBody "body.findLength" + set flag [my load [my getelementptr $flags $i] "flag"] + set len [my load $lenPtr "len"] + my condBr $flag $findLenExpand $findLenSimple + label findLenExpand "body.findLength.expand" + set obj [my load [my getelementptr $objv $i] "objPtr"] + $api Tcl_ListObjLength {} $obj $objcPtr + set lenstep1 [my load $objcPtr "lenStep"] + my br $findLenNext + label findLenSimple "body.findLength.simple" + set lenstep2 $1 + my br $findLenNext + label findLenNext "next.findLength" + set lenstep [my phi [list $lenstep1 $lenstep2] \ + [list $findLenExpand $findLenSimple] "lenStep"] + my store [my add $len $lenstep] $lenPtr + my store [my add $i $1] $iPtr + my br $findLenTest + label setupExpansion "setup.expansion" + set len [my load $lenPtr "len"] + # Do not allocate on stack; might be large + set ary [$api ckalloc [my mult $len $tclobjSize] STRING "array"] + my store $0 $iPtr + my store $0 $jPtr + my br $expansionTest + label expansionTest "test.expansion" + set i [my load $iPtr "i"] + my condBr [my lt $i $objc] $expansionBody $invoke + label expansionBody "body.expansion" + set j [my load $jPtr "j"] + set flag [my load [my getelementptr $flags $i] "flag"] + set obj [my load [my getelementptr $objv $i] "objPtr"] + set target [my getelementptr $ary $j] + my condBr $flag $expansionExpand $expansionSimple + label expansionExpand "body.expansion.expand" + $api Tcl_ListObjGetElements {} $obj $objcPtr $objvPtr + set srclen [my load $objcPtr "objc"] + set source [my load $objvPtr "objv"] + my memcpy $target $source [my mult $srclen $tclobjSize] + my store [my add $j $srclen] $jPtr + my br $expansionNext + label expansionSimple "body.expansion.simple" + my store $obj $target + my store [my add $j $1] $jPtr + my br $expansionNext + label expansionNext "next.expansion" + my store [my add $i $1] $iPtr + my br $expansionTest + label invoke: + my condBr [my nonnull $frame] $frameInvoke $stdInvoke + label stdInvoke "invoke.standard" + $api Tcl_NREvalObjv $interp $len $ary $0 + my ret [my null CALLFRAME] + label frameInvoke "invoke.with.callframe" + set vfp [my gep $interp 0 Interp.varFramePtr] + set vf [my load $vfp] + my store $frame $vfp + $api Tcl_NREvalObjv $interp $len $ary $0 + my ret $vf + } + + ##### Function tcl.restoreFrame ##### + # + # Type signature: frame:CALLFRAME -> void + # + # Restores the callframe pointer when returning from a Tcl_NRAddCallback + # chain. + + set f [$module local "tcl.restoreFrame" void<-CALLFRAME] + params frame + build { + nonnull $frame + set interp [$api tclInterp] + set vfp [my gep $interp 0 Interp.varFramePtr] + my store $frame $vfp + my ret + } ##### Function tcl.existsOrError ##### # # Type signature: exists:int1 * message:STRING * ecvar:int* -> int1 # @@ -4570,10 +4730,65 @@ my store $1 $ecvar my ret [my fail STRING] } my CallFrameFunctions $api + + my @coroFunctions $api + + ##### Function: tcl.alloc ##### + # + # Type signature: size:int32->char* + # + # Returns a pointer to allocated memory + + set f [$module local tcl.alloc char*<-int32] + params size + build { + my ret [$api Tcl_Alloc $size] + } + + ##### Function: tcl.free ##### + # + # Type signature: char*->void + # + # Frees a block of memory allocated by Tcl_Alloc + + set f [$module local tcl.free void<-char*] + params p + build { + $api Tcl_Free $p + my ret + } + + ##### Function: tcl.vector.clear + # + # Type signature: int,STRING**->void + # + # Frees the strings in a vector. Used to free the strings in + # objc/objv combinations. + + set f [$module local tcl.vector.clear void<-int,STRING*] + params objc objv + build { + my br $entry + label entry: + my br $loop + label loop: + set objc.loop [PHI int {$objc ${objc.decr}} {$entry $freeOne} "objc.loop"] + set ok [my cmpInt ${objc.loop} SGT [Const 0 int] "objc.gt.0"] + my condBr $ok $freeOne $done + label freeOne: + set objc.decr [my sub ${objc.loop} [Const 1 int] "objc.decr"] + set toDropPtr [my getelementptr $objv ${objc.decr} "objv.at.ind"] + set toDrop [my load $toDropPtr "element.to.drop"] + my dropReference $toDrop + my br $loop + label done: + my ret + } + } export @apiFunctions } Index: codegen/struct.tcl ================================================================== --- codegen/struct.tcl +++ codegen/struct.tcl @@ -35,15 +35,20 @@ # 'mcjit', 'interpreter') has been called. oo::class create Module { superclass llvmEntity variable module counter funcs builder myname globals externs engine + variable machine layout variable dbty mainNS thunkNS initFunction dbbuild constructor {name {filename "/dev/null"}} { next variable ::LLVM::debugmeta +# set status [ParseCommandLineOptions -print-before-all -time-passes] +# Had also tried: -debug-pass=Structure +# puts "status = $status" + set myname $name set module [ModuleCreateWithName $name] SetTarget $module [GetHostTriple] if {$debugmeta} { @@ -141,10 +146,46 @@ [PrintTypeToString $type] [lindex [info level -1] 2] return $dbty([Type void*]) } } + # Module:sizeof -- + # + # Returns the ABI size of the given type + # + # Parameters: + # type - The LLVM type handle + # + # Results: + # An integer giving the size of the given type + + method sizeof {type} { + if {![info exists layout]} { + return -code error "No data layout has been set for this module." + } else { + return [ABISizeOfType $layout $type] + } + } + + # Module:alignof -- + # + # Returns the ABI alignment of the given type + # + # Parameters: + # type - The LLVM type handle + # + # Results: + # An integer giving the alignment of the given type + + method alignof {type} { + if {![info exists layout]} { + return -code error "No data layout has been set for this module." + } else { + return [ABIAlignmentOfType $layout $type] + } + } + # Module:function.create -- # # Create an instance of the Function class. # # Parameters: @@ -196,11 +237,11 @@ method local {name signature args} { set oldfile [my debug file] my debug file [dict get [info frame -1] file] set f [my function.create $name [Type func{$signature}]] - if {"noinline" ni $args} { + if {"noinline" ni $args && "inlinehint" ni $args} { lappend args alwaysinline } $f private $f attribute {*}$args upvar 1 $name ref @@ -439,29 +480,49 @@ # Results: # None. method optimize {{level 3}} { set level [expr {max(0, min(3, int($level)))}] - + if {![info exists machine] || ![info exists layout]} { + return -code error "Target machine has not been set." + } set bld [PassManagerBuilderCreate] - set pm [CreatePassManager] - catch {set td [CreateTargetData ""]} + AddCoroutinePassesToExtensionPoints $bld + set pm [CreatePassManager] ; # Module pass manager + set fpm [CreateFunctionPassManagerForModule $module] + my verify my FinalizeDebuggingMetadata try { - if {[info exist td]} { - SetDataLayout $module [CopyStringRepOfTargetData $td] - AddTargetData $td $pm - } + # SetDataLayout $module $layout + # AddTargetData $td $pm + # AddTargetData $td $fpm + PassManagerBuilderSetOptLevel $bld $level PassManagerBuilderSetDisableUnrollLoops $bld [expr {!$level}] if {$level > 1} { PassManagerBuilderUseInlinerWithThreshold $bld \ [expr {$level > 2 ? 275 : 225 }] } PassManagerBuilderPopulateModulePassManager $bld $pm + PassManagerBuilderPopulateFunctionPassManager $bld $fpm + + AddAnalysisPasses $machine $fpm + InitializeFunctionPassManager $fpm + for {set fn [GetFirstFunction $module]} \ + {$fn ne ""} \ + {set fn [GetNextFunction $fn]} { + VerifyFunction $fn LLVMPrintMessageAction +# DumpValue $fn + RunFunctionPassManager $fpm $fn + } + FinalizeFunctionPassManager $fpm + + AddAnalysisPasses $machine $pm RunPassManager $pm $module + } finally { + DisposePassManager $fpm DisposePassManager $pm PassManagerBuilderDispose $bld } } @@ -491,10 +552,31 @@ method mcjit {{optimisationLevel 2}} { if {[info exists engine]} { return -code error "an engine has already been initialised" } set engine [CreateMCJITCompilerForModule $module $optimisationLevel] + set machine [GetExecutionEngineTargetMachine $engine] + set layout [GetExecutionEngineTargetData $engine] + puts "Compiling for [GetTarget $module]" + puts "Data Layout = [GetDataLayout $module]" + } + + # Module:prepareToCompile -- + # + # Set the machine and layout to the current target triple, or the + # target triple passed as a parameter + # + # Parameters: + # triple - Target triple + + method prepareToCompile {{triple {}}} { + set machine [MakeTargetMachine $triple] + set triple [GetTargetMachineTriple $machine] + set layout [CreateTargetDataLayout $machine] + puts "prepareToCompile: Target data layout: [CopyStringRepOfTargetData $layout]" + SetTarget $module $triple + SetDataLayout $module [CopyStringRepOfTargetData $layout] } # Module:simple -- # # Set the execution engine for the module to be the simple execution @@ -688,10 +770,11 @@ # Debug-world delegates for the basic types DBTY void <- void void "void" DBTY ptr <- ClientData pointer "ClientData" $void DBTY chr <- char int "char" 8 DBTY chrs <- char* pointer "char*" $chr + DBTY chpp <- char** pointer "char**" $chrs DBTY i16 <- int16 int "Tcl_UniChar" 16 DBTY ustr <- int16* pointer "Tcl_UniString" $i16 DBTY i32 <- int int "int" 32 DBTY i32* <- int* pointer "int*" $i32 DBTY i64 <- int64 int "int64" 64 @@ -1605,10 +1688,16 @@ struct "" { STRING bool } + DBTY ptrs <- ClientData* pointer "" $ptr + set nrecbtype [Type func{int<-ClientData*,Interp*,int}*] + DBTY NreCb <- [Type func{int<-ClientData*,Interp*,int}] \ + function $i32 $ptrs $Interp $i32 + DBTY NreCbPtr <- $nrecbtype pointer "NreCallbackPtr" $NreCb + return } } # Class Function -- @@ -2368,11 +2457,11 @@ # Stores data regarding the fixup in the variable '@phis@' # in the caller proc PHI {type values sources {name {}}} { upvar 1 @phis@ phis - set phi [uplevel 1 [list my phiStub $type $name]] + set phi [uplevel 1 [list my phiStub [Type $type] $name]] lappend phis $phi $sources $values return $phi } # FixupPhis -- Index: codegen/thunk.tcl ================================================================== --- codegen/thunk.tcl +++ codegen/thunk.tcl @@ -28,10 +28,11 @@ superclass BuildSupport variable m b metathunk metathunkblock metathunkerror metathunkref variable makingThunks thunkprocmeta variable 0 1 OK ERROR variable Tcl_UniChar mp_int Tcl_ObjCmdType Tcl_ObjCmdPtr + variable Tcl_NRPostProcType Tcl_NRPostProcPtr variable Tcl_CmdDeleteProc Tcl_CmdDeletePtr variable tcl.obj.constant constructor {module} { next [set b [$module builder]] @@ -45,10 +46,12 @@ set Tcl_CmdDeleteProc [Type func{void<-ClientData}] set Tcl_CmdDeletePtr [Type $Tcl_CmdDeleteProc*] set Tcl_UniChar [Int16Type] set Tcl_ObjCmdType [Type func{int<-ClientData,Interp*,int,Tcl_Obj**}] set Tcl_ObjCmdPtr [Type $Tcl_ObjCmdType*] + set Tcl_NRPostProcType [Type func{int<-char**,Interp*,int}] + set Tcl_NRPostProcPTr [Type $Tcl_NRPostProcType] oo::objdefine $b export Call my InitTclMathfuncs set name "[$module name]_Init" set metathunk [$module function.create $name func{int<-Interp*}] @@ -74,11 +77,11 @@ } } method buildInSection {id script} { set line [dict get { - preface 1 + preface 1 API 2 APIvar 3 initConstant 4 commands 5 packageProvide 6 } $id] $m debug scope "" { @@ -124,15 +127,17 @@ # name - The name of the command to create. # func - The LLVM value reference to the function that implements the # command. NOTE that this function has to follow the # Tcl_ObjCmdProc type signature; this does not bind the output # of the code generator directly. + # wrapper - If non-empty, 'func' is an NR command proc, and 'wrapper' + # is the wrapper function for non-NRE evaluation. # # Results: # None. - method InstallCommand {name func} { + method InstallCommand {name func wrapper} { my variable interp my buildInSection commands { $metathunkblock build-in $b if {!$makingThunks} { set metathunkblock [$metathunk block createCommands] @@ -139,12 +144,17 @@ $b br $metathunkblock set makingThunks 1 $metathunkblock build-in $b } set namestr [$b constString $name "name.thunk$name"] - set result [my Tcl_CreateObjCommand $interp $namestr [$func ref] \ - {} {}] + if {$wrapper ne ""} { + set result [my Tcl_NRCreateCommand $interp $namestr \ + [$wrapper ref] [$func ref] {} {}] + } else { + set result [my Tcl_CreateObjCommand $interp $namestr \ + [$func ref] {} {}] + } if {[dict exists $thunkprocmeta $name]} { set proc [dict get $thunkprocmeta $name] $b storeInStruct $proc Proc.cmdPtr $result } set metathunkblock [$metathunk block createCommands] @@ -184,10 +194,15 @@ set block [$metathunk block leave] $metathunkblock build $b { $b br $block } $block build $b { + if 0 { + # ^^^ change to if 1 to stop right after loading the package + set llvm.debugtrap [$m intrinsic debugtrap] + $b call ${llvm.debugtrap} {} + } if {$version ne ""} { set pkgname tclquadcoded::[string trimleft [$m name] ":"] $b ret [my Tcl_PkgProvideEx $interp \ [$b constString $pkgname "pkg.name"] \ [$b constString $version "pkg.version"] {}] @@ -287,38 +302,59 @@ # bytecode - # The bytecode description dictionary that describes the # original command. This is an augmented output of the # [tcl::unsupported::getbytecode] command. # func - The TclOO handle to the function we are binding to. + # nre - Flag that is true iff the function requires NRE + # returnType - LLVM type reference for the return type of the function # # Results: # The function object for the wrapping function. - method thunk {name bytecode func} { + method thunk {name bytecode func nre returnType} { + + # Make the thunk function set thunk [$m function.create cmd.thunk$name $Tcl_ObjCmdType] $thunk private - $thunk setAsCurrentDebuggingScope + + # If the command requires NRE, make the post-processing function + # and the Obj command proc + if {$nre} { + set thunk2 [$m function.create cmd.thunk2$name \ + $Tcl_NRPostProcType] + $thunk2 private + set thunk3 [$m function.create cmd.thunk3$name \ + $Tcl_ObjCmdType] + + my MakeObjCmdForNR $b $thunk3 [$thunk ref] + } else { + set thunk3 {} + } + + # Start building the thunk function + set idx -1 set block [$thunk block] - + $thunk setAsCurrentDebuggingScope $block build-in $b - $b @location 1 + # Make code to declare parameters and handle variable args + $b @location 1 foreach paramName {clientData interp argc argv} { set $paramName [$thunk param [incr idx] $paramName] } lassign [dict get $bytecode signature] restype argtypes set defaults [dict get $bytecode argumentDefaults] set argsIdx -1 if {"args" eq [lindex $defaults end 0]} { set argsIdx [llength $defaults] } - my CheckArgcInRange $name $interp $argc $argv $defaults $argsIdx + # Make code to set argument values and apply defaults for + # varargs $b @location 2 - set realargs {} set idx 0 foreach arginfo $defaults { lassign $arginfo argName argDefaulted argDefault incr idx @@ -346,27 +382,77 @@ if {[info exists argsToClear]} { break } } - $b @location 3 + # Make code to invoke the actual procedure + $b @location 3 set value [$b call [$func ref] $realargs "value"] SetTailCall $value 0 + if {$nre} { + $b NRAddCallback [$thunk2 ref] $value + $b launchCoroRunner $value + } $b @location 4 if {[info exists argsToClear]} { my Tcl_DecrRefCount $argsToClear } - my MapResultToTcl $interp $value $restype + if {$nre} { + $b ret [Const 0 int] + $b @loc {} + set block [$thunk2 block] + $thunk2 setAsCurrentDebuggingScope + $block build-in $b + $b @location 4 + set data_ [$thunk2 param 0 "data"] + set interp_ [$thunk2 param 1 "interp"] + set result_ [$thunk2 param 2 "result"] + set handle [$b load [$b gep $data_ 0]] + set value [$b NRReturnToThunk $handle $returnType] + my MapResultToTcl $thunk2 $interp_ $value $returnType + } else { + my MapResultToTcl $thunk $interp $value $returnType + } $b @loc {} + if {$nre} { + $thunk2 verify + $thunk3 verify + } $thunk verify - my InstallCommand $name $thunk + my InstallCommand $name $thunk $thunk3 + return $thunk } + + # ThunkBuilder:MakeObjCmdForNR -- + # + # Makes the 'objProc' for a command with an NRE implementation + # + # Parameters: + # b - Builder that is building LLVM-IR + # thunk - Wrapper function under construction + # nrProc - LLVM Tcl_ObjCmdProc reference for the NRE version to be wrapped + # + # Results: + # None. + + method MakeObjCmdForNR {b thunk nrProc} { + set block [$thunk block] + $thunk setAsCurrentDebuggingScope + $block build-in $b + $b @location 1 + set clientData [$thunk param 0 "clientData"] + set interp [$thunk param 1 "interp"] + set objc [$thunk param 2 "objc"] + set objv [$thunk param 3 "objv"] + my Tcl_NRCallObjProc $interp $nrProc $clientData $objc $objv + $b ret [Const 0 int] + } # ThunkBuilder:CheckArgcInRange -- # # Generate code to test whether the argument count to a command # implementation matches that which is required for calling the @@ -438,10 +524,12 @@ # # Generate code to create a Tcl value that represents the output of a # function. # # Parameters: + # thunk - + # The thunk under cosntruction # interp - # The LLVM value reference to the Interp*. # result - # The LLVM value reference to the result of the wrapped # function. @@ -452,12 +540,12 @@ # mapped at the LLVM level. # # Results: # None. - method MapResultToTcl {interp result resultType} { - upvar 1 thunk thunk + method MapResultToTcl {thunk interp result resultType} { + # This only happens when all paths are failing paths if {$resultType in {"VOID FAIL" FAIL}} { $b ret $result return } Index: codegen/tycon.tcl ================================================================== --- codegen/tycon.tcl +++ codegen/tycon.tcl @@ -213,10 +213,13 @@ return [DoubleType] } ^float$ - ^FLOAT$ { return [FloatType] } + ^COROHANDLE$ { + return [Type char*] + } ^CALLFRAME$ { return [Type named{CallFrame}*] } ^CALLFRAME { set packaged [Type [lrange $t 1 end]] Index: demos/perftest/tester.tcl ================================================================== --- demos/perftest/tester.tcl +++ demos/perftest/tester.tcl @@ -1215,11 +1215,20 @@ } proc test12 {} { list [catch {fixed {*}[joinsp w x y z]} result] \ [regsub -all ::expandtest:: $result {}] + } + proc test13 {a b c} { + list $c $b $a + } + proc test14 {pqr} { + test13 {*}$pqr + } + proc test15 {cmd} { + {*}$cmd y z } } namespace eval bug-0616bcf08e { proc mulsum {x y z} { @@ -1290,10 +1299,57 @@ dict for {p c} $primes { set lcm [expr {$lcm * $p ** $c}] } return $lcm } + +proc rectest1 {{n 3}} { + if {$n == 0} { + return {} + } else { + return .[rectest1 [expr {$n-1}]] + } +} + +proc rectest2 {{n 3}} { + if {$n == 0} { + return -code error "Error thrown from recursive proc" + } else { + return .[rectest2 [expr {$n-1}]] + } +} + +proc rectest3 {nv} { + upvar 1 $nv nn + if {[incr nn -1] <= 0} { + return | + } else { + return .[rectest3 nn] + } +} + +proc openclose {} { + close [open /dev/null w] +} + +proc openclose2 {lst} { + close [open {*}$lst] +} + + +proc treecollect {t} { + set l {} + treewalk l $t + return $l +} +proc treewalk {lvar t} { + upvar 1 $lvar l + lappend l [lindex $t 0] + foreach item [lrange $t 1 end] { + treewalk l $item + } +} proc qsort {L {left 0} {right -1}} { set left [expr {int($left)}] set right [expr {int($right)}] if {$right < 0} {set right [expr {[llength $L] - 1}]} @@ -2216,20 +2272,29 @@ {expandtest::test3} # {expandtest::test5} Needs support for loop exception ranges {expandtest::test6 {a b c d e} {2 2} x} {expandtest::test7} {expandtest::test8} - {cleanopt {expandtest::test9}} - {cleanopt {expandtest::test10}} - {cleanopt {expandtest::test11}} - {cleanopt {expandtest::test12}} + {expandtest::test9} + {expandtest::test10} + {expandtest::test11} + {expandtest::test12} + {expandtest::test14 {i j k}} + {expandtest::test15 {::expandtest::test13 x}} + {expandtest::test15 {test13 x}} {bug-0616bcf08e::msrange 0 10} {bug-0616bcf08e::msrange2 0 10} {singleton::lforeach} {singleton::llindex} {singleton::srange} + {rectest1} + {treecollect {a {b {d {h i}} {e {j k}}} {c {f {l m}} {g {n o}}}}} + {list [catch rectest2 result] $result} + {set x 3; rectest3 x} + {openclose} + {openclose2 {/dev/null w}} {qsort {3 6 8 7 0 1 4 2 9 5}} {impure 0x0 0 0} {impure 0x3 0 0} {impure 0 1 1} {impure 10 10000 10} @@ -2422,14 +2487,25 @@ expandtest::test8 expandtest::test9 expandtest::test10 expandtest::test11 expandtest::test12 + # test13 is the *target* of expansion tests + expandtest::test13 + expandtest::test14 + expandtest::test15 # Combined feature tests lcmRange bug-0616bcf08e::* + rectest1 + rectest2 + rectest3 + openclose + openclose2 + treecollect + treewalk qsort impure impure-caller impure-typecheck-int impure2 Index: quadcode/bb.tcl ================================================================== --- quadcode/bb.tcl +++ quadcode/bb.tcl @@ -70,11 +70,11 @@ } switch -exact -- [lindex $q 0 0] { "entry" - "param" { set lastEntryPC $pc } - "jump" { + "jump" - "NRE.suspend" { set starter 1 set target [lindex $q 1 1] dict set starters $target {} } "jumpTrue" - "jumpFalse" - @@ -138,11 +138,11 @@ set content [lrange $quads $startpc [expr {$endpc - 1}]] if {$endpc > $startpc} { set q [lindex $quads [expr {$endpc - 1}]] switch -exact -- [lindex $q 0 0] { - "jump" { + "jump" - "NRE.suspend" { set target [my bbindex [lindex $q 1 1]] my bblink $bbindex $target lset content end 1 [list bb $target] } "jumpTrue" - "jumpFalse" - Index: quadcode/builtin_specials.tcl ================================================================== --- quadcode/builtin_specials.tcl +++ quadcode/builtin_specials.tcl @@ -29,11 +29,10 @@ error "lsort with argument expansion is not supported yet" } } # Only [lsort -command] has an interesting frame effect - # Only [lsort -command] might use callframe data lassign [my parse___lsort $q] usesCommand command if {!$usesCommand} { return {killable Inf noCallFrame {} pure {}} @@ -42,13 +41,14 @@ # TODO: We can't analyze [lsort -command] yet, but we could. What it would # take is to generate bytecode for the command prefix with two dummy # arguments, and then determine the effect of the bytecode on the # callframe. + # error "lsort -command is not supported yet" return { - reads 0 writes 0 readsNonLocal {} writesNonLocal {} error "lsort -command is not supported yet" + nre {} reads 0 writes 0 readsNonLocal {} writesNonLocal {} } } # quadcode::specializer method frameEffect___regexp -- Index: quadcode/builtins.tcl ================================================================== --- quadcode/builtins.tcl +++ quadcode/builtins.tcl @@ -85,38 +85,40 @@ dict set cmdAttr ::cd \ [dict get $cmdAttr ::after] dict set cmdAttr ::clock \ {special {}} dict set cmdAttr ::close \ - [dict get $cmdAttr ::after] + {nre {} noCallFrame {}} dict set cmdAttr ::encoding \ [dict get $cmdAttr ::clock] dict set cmdAttr ::eof \ - {killable Inf noCallFrame {}} + {nre {} killable Inf noCallFrame {}} dict set cmdAttr ::error \ [dict get $cmdAttr ::after] dict set cmdAttr ::exit \ [dict get $cmdAttr ::after] dict set cmdAttr ::fblocked \ [dict get $cmdAttr ::eof] dict set cmdAttr ::fconfigure \ - {killable 3 noCallFrame {}} + {nre {} killable 3 noCallFrame {}} dict set cmdAttr ::fcopy \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::fileevent \ [dict get $cmdAttr ::after] dict set cmdAttr ::flush \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::format \ {pure {} killable Inf noCallFrame {}} dict set cmdAttr ::gets \ - {writes 2} + {nre {} writes 2} dict set cmdAttr ::glob \ - [dict get $cmdAttr ::eof] + {killable Inf noCallFrame {}} dict set cmdAttr ::interp \ [dict get $cmdAttr ::clock] dict set cmdAttr ::join \ + [dict get $cmdAttr ::format] + dict set cmdAttr ::lrange \ [dict get $cmdAttr ::format] dict set cmdAttr ::lrepeat \ [dict get $cmdAttr ::format] dict set cmdAttr ::lreplace \ [dict get $cmdAttr ::format] @@ -125,75 +127,81 @@ dict set cmdAttr ::lsearch \ [dict get $cmdAttr ::format] dict set cmdAttr ::lsort \ [dict get $cmdAttr ::clock] dict set cmdAttr ::oo::InfoClass::call \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::constructor \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::definition \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::destructor \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::filters \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::forward \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::instances \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::methods \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::methodtype \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::mixins \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::subclasses \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::superclasses \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoClass::variables \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::call \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::definition \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::filters \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::forward \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::isa \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::methods \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::methodtype \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::mixins \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::variables \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::oo::InfoObject::vars \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::open \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::pid \ [dict get $cmdAttr ::format] + dict set cmdAttr ::platform::generic \ + [dict get $cmdAttr ::format] + dict set cmdAttr ::platform::identify \ + [dict get $cmdAttr ::format] + dict set cmdAttr ::platform::patterns \ + [dict get $cmdAttr ::format] dict set cmdAttr ::puts \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::pwd \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::read \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::regexp \ [dict get $cmdAttr ::clock] dict set cmdAttr ::regsub \ [dict get $cmdAttr ::clock] dict set cmdAttr ::scan \ {writes -3} dict set cmdAttr ::seek \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::socket \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::split \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::binary::decode::base64 \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::binary::decode::hex \ @@ -211,155 +219,159 @@ dict set cmdAttr ::tcl::binary::scan \ [dict get $cmdAttr ::scan] dict set cmdAttr ::tcl::chan::blocked \ [dict get $cmdAttr ::eof] dict set cmdAttr ::tcl::chan::close \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::copy \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::create \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::eof \ [dict get $cmdAttr ::eof] dict set cmdAttr ::tcl::chan::event \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::flush \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::gets \ [dict get $cmdAttr ::gets] dict set cmdAttr ::tcl::chan::names \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::chan::pending \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::chan::pipe \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::pop \ [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::chan::postevent \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::push \ [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::chan::puts \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::read \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::seek \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::chan::tell \ [dict get $cmdAttr ::eof] dict set cmdAttr ::tcl::chan::truncate \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] + dict set cmdAttr ::tcl::clock::clicks \ + [dict get $cmdAttr ::glob] + dict set cmdAttr ::tcl::clock::microseconds \ + [dict get $cmdAttr ::glob] + dict set cmdAttr ::tcl::clock::milliseconds \ + [dict get $cmdAttr ::glob] + dict set cmdAttr ::tcl::clock::seconds \ + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::dict::keys \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::dict::values \ [dict get $cmdAttr ::format] - dict set cmdAttr ::tcl::encoding::convertfrom \ - [dict get $cmdAttr ::format] - dict set cmdAttr ::tcl::encoding::convertto \ - [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::atime \ - [dict get $cmdAttr ::fconfigure] + {killable 3 noCallFrame {}} dict set cmdAttr ::tcl::file::attributes \ {killable 4 noCallFrame {}} dict set cmdAttr ::tcl::file::channels \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::copy \ - [dict get $cmdAttr ::after] + [dict get $cmdAttr ::close] dict set cmdAttr ::tcl::file::delete \ [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::file::dirname \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::executable \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::exists \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::extension \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::isdirectory \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::file::isfile \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::join \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::link \ [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::file::lstat \ {writes 3} dict set cmdAttr ::tcl::file::mkdir \ [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::file::mtime \ - [dict get $cmdAttr ::fconfigure] + [dict get $cmdAttr ::tcl::file::atime] dict set cmdAttr ::tcl::file::nativename \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::normalize \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::owned \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::pathtype \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::readable \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::readlink \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::rename \ [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::file::rootname \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::separator \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::size \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::split \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::stat \ [dict get $cmdAttr ::tcl::file::lstat] dict set cmdAttr ::tcl::file::system \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::tail \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::file::tempfile \ [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::file::type \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::volumes \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::file::writable \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::args \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::body \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::cmdcount \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::commands \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::complete \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::info::default \ [dict get $cmdAttr ::tcl::file::lstat] dict set cmdAttr ::tcl::info::errorstack \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::frame \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::functions \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::globals \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::hostname \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::info::library \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::info::loaded \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::locals \ {killable Inf reads -1} dict set cmdAttr ::tcl::info::nameofexecutable \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::info::patchlevel \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::info::procs \ - [dict get $cmdAttr ::eof] + [dict get $cmdAttr ::glob] dict set cmdAttr ::tcl::info::script \ {killable 2 noCallFrame {}} dict set cmdAttr ::tcl::info::sharedlibextension \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::info::tclversion \ @@ -425,10 +437,12 @@ dict set cmdAttr ::tcl::mathfunc::tan \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::mathfunc::tanh \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::mathfunc::wide \ + [dict get $cmdAttr ::format] + dict set cmdAttr ::tcl::string::bytelength \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::string::equal \ [dict get $cmdAttr ::format] dict set cmdAttr ::tcl::string::first \ [dict get $cmdAttr ::format] Index: quadcode/builtins.txt ================================================================== --- quadcode/builtins.txt +++ quadcode/builtins.txt @@ -1,13 +1,22 @@ # In the following, the columns are to be interpreted as: # idem - The command is idempotent in the sense that invoking it multiple # times with the same args in the same interp will always return the # same result +# # kill - The command is killable in that nothing depends on its side effects, # so if its result is not used, the call may be eliminated entirely. # This is 0, 1, or 'objc<=N' +# +# nre - This command, and all commads that call it, must be invoked +# with non-recursive eval, This includes the core 'yield', +# 'yieldm' and 'yieldTo' commands, coroutine creation and +# invocation, and any Core command that requires evaluating +# unknown Tcl code, expressions, substitutions, or assembly language. +# It also includes any command that cannot be fully analyzed +# at compile time # # reads - What variables does the command read from the callframe? For # the builtins in this table, the result is either 'all' or # empty. # @@ -18,302 +27,318 @@ # variables). #GLOBAL NAMESPACE -#name idem kill reads writes notes - -after 0 0 -cd 0 0 -clock SPECIAL <4> -close 0 0 -encoding SPECIAL <4> - -eof 0 1 -error 0 0 -exit 0 0 -fblocked 0 1 -fconfigure 0 objc<=3 -fcopy 0 0 - -fileevent 0 0 -flush 0 0 -format 1 1 -gets 0 0 objv[2] -glob 0 1 -interp SPECIAL - -join 1 1 -lrange 1 1 -lrepeat 1 1 -lreplace 1 1 -lreverse 1 1 -lsearch 1 1 -lsort SPECIAL <1> - -open 0 0 -pid 1 1 -puts 0 0 -pwd 0 1 -read 0 0 - -regexp SPECIAL <2> -regsub SPECIAL <3> -scan 0 0 objv[3+] -seek 0 0 -socket 0 0 - -split 1 1 -tell 0 1 +#name idem kill nre reads writes notes + +after 0 0 0 +cd 0 0 0 +clock SPECIAL <4> +close 0 0 1 +encoding SPECIAL <4> + +eof 0 1 1 +error 0 0 0 +exit 0 0 0 +fblocked 0 1 1 +fconfigure 0 objc<=3 1 +fcopy 0 0 1 + +fileevent 0 0 0 +flush 0 0 1 +format 1 1 0 +gets 0 0 1 objv[2] +glob 0 1 0 +interp SPECIAL + +join 1 1 0 +lrange 1 1 0 +lrepeat 1 1 0 +lreplace 1 1 0 +lreverse 1 1 0 +lsearch 1 1 0 +lsort SPECIAL <1> + +open 0 0 1 +pid 1 1 0 +puts 0 0 1 +pwd 0 1 0 +read 0 0 1 + +regexp SPECIAL <2> +regsub SPECIAL <3> +scan 0 0 0 objv[3+] +seek 0 0 1 +socket 0 0 1 + +split 1 1 0 +tell 0 1 1 #<1> lsort needs the callframe if -command is used, and needs whatever # variable access that the command needs. It's unkillable if the # command is unkillable. Without -command (the common case!) it doesn't # touch the callframe. Even most of the -commands will wind up being # killable and not need the callframe, but it's probably best to # ignore the case initially and simply announce that [lsort -# -command] is not compilable. +# -command] is not compilable. [lsort -command] also must be recorded +# as depending on the given command, and requires NRE if the command +# does. # #<2> 'regexp' needs to parse out the switches in order to decide what # position on the command line is the 'exp'. The following position # is the 'string', and after that are the match variables. 'regexp' # reads nothing from the callframe and writes the match variables. # For nonconstant args, it's safe to assume it writes everything. # If there are no match variables (or if no match variables are -# live), 'regexp' is killable. +# live), 'regexp' is killable. It does not require NRE # #<3> 'regsub' needs to parse out the switches in order to decide # whether a 'varName' arg is present. It reads nothing from the # callframe and writes only the 'varName'. For nonconstant args, # it's safe to assume that it writes everything. If there is no # match variable (or if the match variable is not live), 'regsub' is -# killable. +# killable. It does not require NRE. # #<4> 'clock' and 'encoding' are not yet compilable ensembles. They # probably ought to get made into such before attempting to analyze # them in the quadcode compiler. #THE [platform] NAMESPACE -# name idem kill reads writes notes -platform::generic 1 1 -platform::identify 1 1 -platform::patterns 1 1 - +# name idem kill nre reads writes notes +platform::generic 1 1 0 +platform::identify 1 1 0 +platform::patterns 1 1 0 #THE [binary] ENSEMBLE -# name idem kill reads writes notes -tcl::binary::decode::* 1 1 -tcl::binary::encode::* 1 1 -tcl::binary::format 1 1 -tcl::binary::scan 0 0 objv[3+] - +# name idem kill nre reads writes notes +tcl::binary::decode::* 1 1 0 +tcl::binary::encode::* 1 1 0 +tcl::binary::format 1 1 0 +tcl::binary::scan 0 0 0 objv[3+] #THE [chan] ENSEMBLE -# name idem kill reads writes notes -tcl::chan::blocked 0 1 -tcl::chan::close 0 0 -tcl::chan::copy 0 0 -tcl::chan::create 0 0 -tcl::chan::eof 0 1 - -tcl::chan::event 0 0 -tcl::chan::flush 0 0 -tcl::chan::gets 0 0 objv[2] -tcl::chan::names 0 1 -tcl::chan::pending 0 1 - -tcl::chan::pipe 0 0 -tcl::chan::pop 0 0 -tcl::chan::postevent 0 0 -tcl::chan::push 0 0 -tcl::chan::read 0 0 - -tcl::chan::puts 0 0 -tcl::chan::seek 0 0 -tcl::chan::tell 0 1 -tcl::chan::truncate 0 0 +# name idem kill nre reads writes notes +tcl::chan::blocked 0 1 1 +tcl::chan::close 0 0 1 +tcl::chan::copy 0 0 1 +tcl::chan::create 0 0 1 +tcl::chan::eof 0 1 1 + +tcl::chan::event 0 0 1 +tcl::chan::flush 0 0 1 +tcl::chan::gets 0 0 1 objv[2] +tcl::chan::names 0 1 0 +tcl::chan::pending 0 1 0 + +tcl::chan::pipe 0 0 1 +tcl::chan::pop 0 0 0 +tcl::chan::postevent 0 0 1 +tcl::chan::push 0 0 0 +tcl::chan::read 0 0 1 + +tcl::chan::puts 0 0 1 +tcl::chan::seek 0 0 1 +tcl::chan::tell 0 1 1 +tcl::chan::truncate 0 0 1 + +# THE [clock] ENSEMBLE + +# name idem kill nre reads writes notes +tcl::clock::add 0 1 0 +tcl::clock::clicks 0 1 0 +tcl::clock::format 0 1 0 +tcl::clock::microseconds 0 1 0 +tcl::clock::milliseconds 0 1 0 + +tcl::clock::scan 0 1 0 +tcl::clock::seconds 0 1 0 # THE [dict] ENSEMBLE # Not all the subcommands of [dict] are compiled in all circumstances -#name idem kill reads writes -tcl::dict::keys 1 1 -tcl::dict::values 1 1 +#name idem kill nre reads writes +tcl::dict::keys 1 1 0 +tcl::dict::values 1 1 0 # THE [encoding] ENSEMBLE -#name idem kill reads writes -tcl::encoding::convertfrom 1 1 -tcl::encoding::convertto 1 1 +#name idem kill nre reads writes +tcl::encoding::convertfrom 1 1 0 +tcl::encoding::convertto 1 1 0 +tcl::encoding::dirs 0 objc<=1 0 +tcl::encoding::names 0 1 0 +tcl::encoding::system 0 objc<=1 0 #THE [file] ENSEMBLE -#name idem kill reads writes notes -tcl::file::atime 0 objc<=3 -tcl::file::attributes 0 objc<=4 -tcl::file::channels 0 1 -tcl::file::copy 0 0 -tcl::file::delete 0 0 - -tcl::file::dirname 1 1 -tcl::file::executable 0 1 -tcl::file::exists 0 1 -tcl::file::extension 1 1 -tcl::file::isdirectory 0 1 - -tcl::file::isfile 0 1 -tcl::file::join 1 1 -tcl::file::link 0 0 -tcl::file::lstat 0 0 objv[3] <5> -tcl::file::mkdir 0 0 - -tcl::file::mtime 0 objc<=3 -tcl::file::nativename 0 1 -tcl::file::normalize 0 1 -tcl::file::owned 0 1 -tcl::file::pathtype 1 1 - -tcl::file::readable 0 1 -tcl::file::readlink 0 1 -tcl::file::rename 0 0 -tcl::file::rootname 1 1 -tcl::file::separator 1 1 - -tcl::file::size 0 1 -tcl::file::split 1 1 -tcl::file::stat 0 0 objv[3] <5> -tcl::file::system 0 1 -tcl::file::tail 1 1 - -tcl::file::tempfile 0 0 -tcl::file::type 0 1 -tcl::file::volumes 0 1 -tcl::file::writable 0 1 +#name idem kill nre reads writes notes +tcl::file::atime 0 objc<=3 0 +tcl::file::attributes 0 objc<=4 0 +tcl::file::channels 0 1 0 +tcl::file::copy 0 0 1 +tcl::file::delete 0 0 0 + +tcl::file::dirname 1 1 0 +tcl::file::executable 0 1 0 +tcl::file::exists 0 1 0 +tcl::file::extension 1 1 0 +tcl::file::isdirectory 0 1 0 + +tcl::file::isfile 0 1 0 +tcl::file::join 1 1 0 +tcl::file::link 0 0 0 +tcl::file::lstat 0 0 0 objv[3] <5> +tcl::file::mkdir 0 0 0 + +tcl::file::mtime 0 objc<=3 0 +tcl::file::nativename 0 1 0 +tcl::file::normalize 0 1 0 +tcl::file::owned 0 1 0 +tcl::file::pathtype 1 1 0 + +tcl::file::readable 0 1 0 +tcl::file::readlink 0 1 0 +tcl::file::rename 0 0 0 +tcl::file::rootname 1 1 0 +tcl::file::separator 1 1 0 + +tcl::file::size 0 1 0 +tcl::file::split 1 1 0 +tcl::file::stat 0 0 0 objv[3] <5> +tcl::file::system 0 1 0 +tcl::file::tail 1 1 0 + +tcl::file::tempfile 0 0 0 +tcl::file::type 0 1 0 +tcl::file::volumes 0 1 0 +tcl::file::writable 0 1 0 # <5> For tcl::file::lstat and tcl::file::stat, objv[3] is an array, not a # scalar variable #THE [info] ENSEMBLE -#name idem kill reads writes notes -tcl::info::args 0 1 -tcl::info::body 0 1 -tcl::info::cmdcount 0 1 -tcl::info::commands 0 1 -tcl::info::complete 1 1 - -tcl::info::default 0 0 objv[3] -tcl::info::errorstack 0 1 -tcl::info::frame 0 1 -tcl::info::functions 0 1 -tcl::info::globals 0 1 - -tcl::info::hostname 1 1 -tcl::info::library 1 1 -tcl::info::loaded 0 1 -tcl::info::locals 0 1 all -tcl::info::nameofexecutable 1 1 - -tcl::info::patchlevel 1 1 -tcl::info::procs 0 1 -tcl::info::script 0 objc<=2 -tcl::info::sharedlibextension 1 1 -tcl::info::tclversion 1 1 - -tcl::info::vars 0 1 all +#name idem kill nre reads writes notes +tcl::info::args 0 1 0 +tcl::info::body 0 1 0 +tcl::info::cmdcount 0 1 0 +tcl::info::commands 0 1 0 +tcl::info::complete 1 1 0 + +tcl::info::default 0 0 0 objv[3] +tcl::info::errorstack 0 1 0 +tcl::info::frame 0 1 0 +tcl::info::functions 0 1 0 +tcl::info::globals 0 1 0 + +tcl::info::hostname 1 1 0 +tcl::info::library 1 1 0 +tcl::info::loaded 0 1 0 +tcl::info::locals 0 1 0 all +tcl::info::nameofexecutable 1 1 0 + +tcl::info::patchlevel 1 1 0 +tcl::info::procs 0 1 0 +tcl::info::script 0 objc<=2 0 +tcl::info::sharedlibextension 1 1 0 +tcl::info::tclversion 1 1 0 + +tcl::info::vars 0 1 0 all # tcl::info::vars and tcl::info::locals need only the variable names to # be correct in the callframe. The variable values can be anything. # THE [info class] SUBENSEMBLE -#name idem kill reads writes notes -oo::InfoClass::call 0 1 -oo::InfoClass::constructor 0 1 -oo::InfoClass::definition 0 1 -oo::InfoClass::destructor 0 1 -oo::InfoClass::filters 0 1 - -oo::InfoClass::forward 0 1 -oo::InfoClass::instances 0 1 -oo::InfoClass::methods 0 1 -oo::InfoClass::methodtype 0 1 -oo::InfoClass::mixins 0 1 - -oo::InfoClass::subclasses 0 1 -oo::InfoClass::superclasses 0 1 -oo::InfoClass::variables 0 1 +#name idem kill nre reads writes notes +oo::InfoClass::call 0 1 0 +oo::InfoClass::constructor 0 1 0 +oo::InfoClass::definition 0 1 0 +oo::InfoClass::destructor 0 1 0 +oo::InfoClass::filters 0 1 0 + +oo::InfoClass::forward 0 1 0 +oo::InfoClass::instances 0 1 0 +oo::InfoClass::methods 0 1 0 +oo::InfoClass::methodtype 0 1 0 +oo::InfoClass::mixins 0 1 0 + +oo::InfoClass::subclasses 0 1 0 +oo::InfoClass::superclasses 0 1 0 +oo::InfoClass::variables 0 1 0 # The [info object] SUBENSEMBLE -#name idem kill reads writes notes -oo::InfoObject::call 0 1 -oo::InfoObject::definition 0 1 -oo::InfoObject::filters 0 1 -oo::InfoObject::forward 0 1 -oo::InfoObject::isa 0 1 - -oo::InfoObject::methods 0 1 -oo::InfoObject::methodtype 0 1 -oo::InfoObject::mixins 0 1 -oo::InfoObject::variables 0 1 -oo::InfoObject::vars 0 1 +#name idem kill nre reads writes notes +oo::InfoObject::call 0 1 0 +oo::InfoObject::definition 0 1 0 +oo::InfoObject::filters 0 1 0 +oo::InfoObject::forward 0 1 0 +oo::InfoObject::isa 0 1 0 + +oo::InfoObject::methods 0 1 0 +oo::InfoObject::methodtype 0 1 0 +oo::InfoObject::mixins 0 1 0 +oo::InfoObject::variables 0 1 0 +oo::InfoObject::vars 0 1 0 # THE MATHFUNCS -#name idem kill reads writes notes -tcl::mathfunc::abs 1 1 -tcl::mathfunc::acos 1 1 -tcl::mathfunc::asin 1 1 -tcl::mathfunc::atan 1 1 -tcl::mathfunc::atan2 1 1 - -tcl::mathfunc::bool 1 1 -tcl::mathfunc::ceil 1 1 -tcl::mathfunc::cos 1 1 -tcl::mathfunc::cosh 1 1 -tcl::mathfunc::double 1 1 - -tcl::mathfunc::entier 1 1 -tcl::mathfunc::exp 1 1 -tcl::mathfunc::floor 1 1 -tcl::mathfunc::fmod 1 1 -tcl::mathfunc::hypot 1 1 - -tcl::mathfunc::int 1 1 -tcl::mathfunc::isqrt 1 1 -tcl::mathfunc::log 1 1 -tcl::mathfunc::log10 1 1 -tcl::mathfunc::max 1 1 - -tcl::mathfunc::min 1 1 -tcl::mathfunc::pow 1 1 -tcl::mathfunc::rand 0 0 -tcl::mathfunc::round 1 1 -tcl::mathfunc::srand 0 0 - -tcl::mathfunc::sin 1 1 -tcl::mathfunc::sinh 1 1 -tcl::mathfunc::sqrt 1 1 -tcl::mathfunc::tan 1 1 -tcl::mathfunc::tanh 1 1 - -tcl::mathfunc::wide 1 1 +#name idem kill nre reads writes notes +tcl::mathfunc::abs 1 1 0 +tcl::mathfunc::acos 1 1 0 +tcl::mathfunc::asin 1 1 0 +tcl::mathfunc::atan 1 1 0 +tcl::mathfunc::atan2 1 1 0 + +tcl::mathfunc::bool 1 1 0 +tcl::mathfunc::ceil 1 1 0 +tcl::mathfunc::cos 1 1 0 +tcl::mathfunc::cosh 1 1 0 +tcl::mathfunc::double 1 1 0 + +tcl::mathfunc::entier 1 1 0 +tcl::mathfunc::exp 1 1 0 +tcl::mathfunc::floor 1 1 0 +tcl::mathfunc::fmod 1 1 0 +tcl::mathfunc::hypot 1 1 0 + +tcl::mathfunc::int 1 1 0 +tcl::mathfunc::isqrt 1 1 0 +tcl::mathfunc::log 1 1 0 +tcl::mathfunc::log10 1 1 0 +tcl::mathfunc::max 1 1 0 + +tcl::mathfunc::min 1 1 0 +tcl::mathfunc::pow 1 1 0 +tcl::mathfunc::rand 0 0 0 +tcl::mathfunc::round 1 1 0 +tcl::mathfunc::srand 0 0 0 + +tcl::mathfunc::sin 1 1 0 +tcl::mathfunc::sinh 1 1 0 +tcl::mathfunc::sqrt 1 1 0 +tcl::mathfunc::tan 1 1 0 +tcl::mathfunc::tanh 1 1 0 + +tcl::mathfunc::wide 1 1 0 # THE [string] ENSEMBLE -#name idem kill reads writes notes -tcl::string::bytelength 1 1 -tcl::string::equal 1 1 -tcl::string::first 1 1 -tcl::string::last 1 1 -tcl::string::repeat 1 1 -tcl::string::reverse 1 1 +#name idem kill nre reads writes notes +tcl::string::bytelength 1 1 0 +tcl::string::equal 1 1 0 +tcl::string::first 1 1 0 +tcl::string::last 1 1 0 +tcl::string::repeat 1 1 0 + +tcl::string::reverse 1 1 0 Index: quadcode/constfold.tcl ================================================================== --- quadcode/constfold.tcl +++ quadcode/constfold.tcl @@ -59,15 +59,16 @@ "directArrayLappend" - "directArrayLappendList" - "directArraySet" - "directArrayUnset" - "directExists" - "directGet" - "directLappend" - "directLappendList" - "directSet" - "directUnset" - "directIsArray" - "directMakeArray" - "foreachStart" - "entry" - - "extractExists" - "extractFail" - - "extractMaybe" - "initException" - - "jump" - "jumpFalse" - "jumpMaybe" - "jumpTrue" - "purify" - - "split" - "unshareList" - - "initArray" - "setReturnCode" - "resolveCmd" - "originCmd" { + "extractExists" - "extractFail" - "extractMaybe" - + "initArray" - "initException" - + "jump" - "jumpFalse" - "jumpMaybe" - "jumpTrue" - + "NRE.suspend" - "originCmd" - + "purify" - "resolveCmd" - "setReturnCode" - + "split" - "unshareList" { # do nothing - these insns are not killable # this case goes away once I have a better handle # on what's killable. # Note that the "direct..." operations are probably # never killable due to the potential for global Index: quadcode/dbginfo.tcl ================================================================== --- quadcode/dbginfo.tcl +++ quadcode/dbginfo.tcl @@ -25,11 +25,12 @@ # b - Basic block # pc - Program counter within the basic block # # Results: # Returns a list comprising the source file, -# the line number and the active script fragment, followed by +# the line number, the active script fragment, and +# the current context. oo::define quadcode::transformer method sourceInfo {b pc} { while {![info exists debugLines] || ![info exists debugScript] Index: quadcode/deadcode.tcl ================================================================== --- quadcode/deadcode.tcl +++ quadcode/deadcode.tcl @@ -187,11 +187,21 @@ set changed 0 # Number the blocks depth-first. Blocks that precede the entry are # unreachable. set prevb -1 - foreach b [my bborder] { + set neworder [my bborder] + my debug-deadbb { + puts "New basic block order: $neworder" + } + set pb -1 + foreach b $neworder { + if {$b < $pb} { + set changed 1 + } else { + set pb $b + } if {$b > 0 && !$seenEntry} { # block b is unreachable and will be deleted. It is no longer # the predecessor of any other block. Removing the link allows # for more aggressive coalescence of the remaining blocks. foreach s [my bbsucc $b] { Index: quadcode/liveranges.tcl ================================================================== --- quadcode/liveranges.tcl +++ quadcode/liveranges.tcl @@ -193,11 +193,11 @@ if {[lindex $src 0] in {"temp" "var"}} { dict set uses $src $b 1 } } - "return" { + "return" - "NRE.return" { # Record that the return value is live on exit from # the block that returns foreach src [lrange $q 2 end] { ADDED quadcode/nre.tcl Index: quadcode/nre.tcl ================================================================== --- /dev/null +++ quadcode/nre.tcl @@ -0,0 +1,200 @@ +# nre.tcl -- +# +# Code to check, locally, whether a particular quadcode sequence +# does anything locally to require non-recursive evaluation (NRE). +# +# 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::transformer method needsNRE -- +# +# Computes whether a given quadcode sequence requires +# non-recursive evaluation. +# +# Results: +# Returns 1 if NRE is required, 0 otherwise. +# +# NRE is needed if the sequence invokes any command that requires NRE, +# or if it does anything that might switch coroutine, or if it tailcalls +# or evaluates uncontrolled code. + +oo::define quadcode::transformer method needsNRE {} { + + # If the answer is already known, just return it + + if {[info exists nre]} { + return $nre + } + + # Walk the quads to determine whether NRE is needed. + + set b -1 + foreach bb $bbcontent { + incr b + set pc -1 + foreach q $bb { + incr pc + switch -exact [lindex $q 0] { + "invoke" - "invokeExpanded" { + + # If we're invoking an unknown callee, we have to be NRE + + set callee [lindex $q 3] + if {[lindex $callee 0] ne "literal"} { + return [set nre 1] + } + + # Find the argument types for this invoke + + set alist [lrange $q 4 end] + set atypes [lmap a $alist { + ::quadcode::typeOfOperand $types $a + }] + + if {[$specializer needsNRE $q $atypes]} { + return [set nre 1] + } + } + } + } + } + return [set nre 0] +} + +# quadcode::transformer method promoteNREOperations -- +# +# Promote 'entry', 'return' and 'invoke' operations that refer to +# procedures that need non-recursive eval. +# +# Results: +# None. +# +# Side effects: +# 'entry' is replaced with 'entryNRE'. 'return' is replaced with +# 'returnNRE'. 'invoke' is more complex. It causes the basic block +# to be split with an unconditional jump immediately following the +# 'invoke', and the 'invoke' to be replaced with 'invokeNRE'. + +oo::define quadcode::transformer method promoteNREOperations {} { + + namespace upvar ::quadcode::dataType \ + COROHANDLE COROHANDLE CALLFRAME CALLFRAME + + my debug-nre { + puts "Before NRE promotion: " + my dump-bb + } + + set bbcount [llength $bbcontent] + for {set bbno 0} {$bbno < $bbcount} {incr bbno} { + my debug-nre { + puts "Basic block $bbno" + } + set b $bbno + lassign [my bbUnlinkTail $b 0] - bb + set newbb {} + + set pc -1 + foreach q $bb { + incr pcq + + lassign $q opcode + switch -exact -- $opcode { + + "entry" { + if {[my needsNRE]} { + lset q 0 "NRE.entry" + } + my debug-nre { + puts "$b:[llength $newbb]: $q" + } + my bbEmitAndTrack $b newbb $q + } + + "return" { + if {[my needsNRE]} { + lset q 0 "NRE.return" + } + my debug-nre { + puts "$b:[llength $newbb]: $q" + } + my bbEmitAndTrack $b newbb $q + } + + "invoke" - "invokeExpanded" { + + set args [lassign $q opcode result cfin command] + if {[lindex $command 0] ne "literal"} { + set usenre 1 + } else { + set atypes [lmap a $args { + typeOfOperand $types $a + }] + set usenre [$specializer nreRequired $q $atypes] + } + + if {$usenre} { + set resultv [lindex $q 1] + set inty [typeOfOperand $types $cfin] + lset q 0 [list NRE.$opcode [dict get $types $resultv]] + set coroHandle [my newVarInstance $resultv] + lset q 1 $coroHandle + dict set types $coroHandle \ + [expr {$COROHANDLE | ($inty & $CALLFRAME)}] + my debug-nre { + puts "$b:[llength $newbb]: $q" + } + my bbEmitAndTrack $b newbb $q + set continuation [my bbCreate] + my debug-nre { + puts "$b:[llength $newbb]: \ + [list NRE.suspend [list bb $continuation] \ + $coroHandle]" + } + my bbEmitAndTrack $b newbb \ + [list "NRE.suspend" [list bb $continuation] \ + $coroHandle] + lset bbcontent $b $newbb + set newbb {} + set b $continuation + lset q 0 "NRE.returnFromInvoke" + lset q 1 $resultv + lset q 2 $coroHandle + } + my debug-nre { + puts "$b:[llength $newbb]: $q" + } + my bbEmitAndTrack $b newbb $q + } + + default { + my debug-nre { + if {$b != $bbno} { + puts "$b:[llength $newbb]: $q" + } + } + my bbEmitAndTrack $b newbb $q + + } + } + } + + lset bbcontent $b $newbb + } + + my bbidom + my bblevel + +} + +# 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/parseBuiltinsTxt.tcl ================================================================== --- quadcode/parseBuiltinsTxt.tcl +++ quadcode/parseBuiltinsTxt.tcl @@ -13,11 +13,11 @@ # Writes an edited version of 'builtins.tcl.in' to the file, # 'builtins.tcl', substituting %DICT% with the dictionary. proc main {} { - set keys {idem kill reads writes notes} + set keys {idem kill nre reads writes notes} set haveAttr {} set f [open builtins.txt r] set data [split [read $f] \n] close $f @@ -84,10 +84,20 @@ default { error "what does idem [dict get $attrs idem] mean?" } } if {![dict exists $att special]} { + switch -exact -- [dict get $attrs nre] { + 0 - {} { + } + 1 { + lappend att nre {} + } + default { + error "what does nre [dict get $attrs nre] mean?" + } + } switch -regexp -matchvar m -- [dict get $attrs kill] { 0 { } 1 { lappend att killable Inf Index: quadcode/specializer.tcl ================================================================== --- quadcode/specializer.tcl +++ quadcode/specializer.tcl @@ -70,10 +70,19 @@ # values are dictionaries describing the procedure # instances' effect on the caller's callframe. # instanceBeingAnalyzed - Holds the instance name of the current procedure # during a call to type analysis in the quadcode # database. + # nreActive - Dictionary whose keys are instance names of procedures + # being analyzed for NRE requirement, and whose values + # are immaterial. A procedure is present if it is currently + # being analyzed; this flag is used to check whether the + # procedure is recursive. + # nreRequired - Dictonary whose types are instance names of procedures + # and whose values are immaterial. If an instance is present + # in 'nreRequired', then NRE code generation must be + # performed for it. # onWorklist - Dictionary whose keys are the instance names of the # procedures on the worklist for analysis and whose values # are their positions in the heap. # precedence - Dictionary whose keys are fully qualified procedure names # (without types) and whose values are the positions of @@ -89,11 +98,12 @@ # are the return types of those procedure instances. # typeInf - Dictionary whose keys are instance names and whose values # are quadcode databases for the instances variable canInline cmdAttr database dependencies dependents \ - diagnostics diagnosticSeq failed frameEffect \ + diagnostics diagnosticSeq failed frameEffect nreActive \ + nreRequired \ instanceBeingAnalyzed onWorklist precedence requiredInstances \ returnType typeInf # Local commands: # worklist - List of procedures awaiting type analysis. This list is @@ -148,10 +158,14 @@ # The procedure's name is resolve in the caller's scope to a fully # qualified name. The procedure is converted to quadcode and its # quadcode database is added to the 'database' dictionary. oo::define quadcode::specializer method register {procName} { + + my debug-specializer { + puts "REGISTER: procName" + } # Fully qualify the procedure names and resolve imports. set realProc [uplevel 1 [list namespace which $procName]] if {$realProc eq {}} { @@ -225,10 +239,14 @@ # # Side effects: # Procedure instance is added to 'requiredInstances'. oo::define quadcode::specializer method require {procName argTypes} { + + my debug-specializer { + puts "REQUIRE: $procName ([lmap t $argTypes {nameOfType $t}])" + } # Resolve the procedure name and handle namespace imports set realProc [uplevel 1 [list namespace which $procName]] set origin [uplevel 1 [list namespace origin $realProc]] @@ -364,10 +382,19 @@ } } } } } + + # Once all the procedures are fully typed, there's a final pass needed + # to determine which ones can be called directly, and which ones must + # be NRE. + + my debug-specializer { + puts "Analyze NRE requirements" + } + my calcNRERequired } # quadcode::specializer method searchForInlines -- # # Try to find opportunities to inline procedure instances into their @@ -484,10 +511,194 @@ my debug-inline { puts "Can $inst be inlined? [dict get $canInline $inst]" } return [dict get $canInline $inst] } + +# quadcode::specializer calcNRERequired -- +# +# Determines which procedure instances in the call graph require +# non-recursive evaluation. +# +# Results: +# None. +# +# Side effects: +# Calls the translator instance to set the 'NRE' flag on any procedure +# requiring non-recursive evaluation +# +# A procedure requires NRE for any of the following reasons: +# +# 1. It does anything that might change the active coroutine. +# 2. It invokes unknown, non-compiled commands. +# 3. It invokes any Core command that requires NRE. +# 4. It is directly or indirectly recursive. +# 5. It invokes, directly or indirectly, any other command that +# might require NRE. +# +# We perform a depth-first traversal of the call graph to analyze NRE. +# This is done with the help of the quadcode::transformer object. We call +# the transformer's 'needsNRE' method for each required instance, and it +# calls back to the specializer's 'needsNRE' method for each invoked command. + +oo::define quadcode::specializer method calcNRERequired {} { + + set nreActive {} + set nreRequired {} + + dict for {instance db} $typeInf { + my debug-specializer { + puts "NRE: $instance" + } + dict set nreActive $instance {} + set needs [$db needsNRE] + my debug-specializer { + puts [format {NRE: %s %s NRE} $instance \ + [expr {$needs ? "needs" : "does not need"}]] + } + if {$needs} { + dict set nreRequired $instance {} + } + dict unset nreActive $instance + + } +} + +# quadcode::specializer method needsNRE -- +# +# Tests whether an individual procedure instance requires NRE. +# +# Parameters: +# name - Name of the command to analyze +# alist - List of quadcode values for the command's arguments +# atypes - List of typecodes of the types of the arguments. +# +# Results: +# Returns 1 if the command needs NRE, 0 otherwise. + +oo::define quadcode::specializer method needsNRE {q atypes} { + + set name [lindex $q 3 1] + my debug-specializer { + puts [format "%*s Does %s(%s) need NRE?" [dict size $nreActive] {} \ + $name $atypes] + } + set instance [list $name $atypes] + if {[dict exists $nreActive $instance]} { + my debug-specializer { + puts [format "%*s %s needs NRE, it is recursive" \ + [dict size $nreActive] {} $instance] + } + dict set nreRequired $instance {} + return 1; # The procedure is recursive. + } + + if {[dict exists $typeInf $instance]} { + # The instance is a compiled command that we have not + # visited. Find out whether it needs NRE + set db [dict get $typeInf $instance] + dict set nreActive $instance {} + set result [$db needsNRE] + dict unset nreActive $instance + my debug-specializer { + puts [format "%*s %s %s NRE. Translator says so." \ + [dict size $nreActive] {} \ + $instance \ + [expr {$result ? "needs" : "does not need"}]] + } + if {$result} { + dict set nreRequired $instance {} + } + return $result + } + + # The instance is not a compiled command. It may be a builtin. + + tailcall my nonCompiledNeedsNRE $q $atypes +} + +# quadcode::specializer method nonCompiledNeedsNRE -- +# +# Tests whether a non-compiled command invocation needs non-recursive +# eval. +# +# Parameters: +# q - Quadcode instruction that invokes a non-compiled command +# argTypes - List of types of the arguments of the command +# +# Results: +# Returns 1 if NRE must be used, 0 otherwise + +oo::define quadcode::specializer method nonCompiledNeedsNRE {q argTypes} { + + if {[lindex $q 3 0] ne "literal"} { + return 1; # Unknown command invocation is always NRE + } + set name [lindex $q 3 1] + set instance [list $name $argTypes] + my debug-specializer { + puts "Does $name ([lmap x $argTypes {nameOfType $x}]) need NRE?" + } + if {[dict exists $cmdAttr $name]} { + set attrs [dict get $cmdAttr $name] + if {[dict exists $attrs special]} { + set method frameEffect_[string map {:: __} $name] + set attrs [my $method $q] + } + if {! [dict exists $attrs nre]} { + my debug-specializer { + puts [format "%*s %s does not need NRE,\ + it's a simple builtin" \ + [dict size $nreActive] {} $instance] + } + return 0 + } + } + + # We don't know what the instance is, so require NRE + + my debug-specializer { + puts [format "%*s %s needs NRE, it is not compiled, \ + and not asserted to be safe." \ + [dict size $nreActive] {} $instance] + } + return 1 +} + +# quadcode::specializer method nreRequired -- +# +# Tests whether a procedure must be processed with non-recursive +# evaluation. +# +# Parameters: +# procName - Name of the procedure being examined +# argTypes - List of argument types +# +# Preconditions: +# calcNRERequired must already have run +# +# Results: +# Returns 1 if the procedure needs non-recursive eval, 0 otherwise + +oo::define quadcode::specializer method nreRequired {q argTypes} { + if {[lindex $q 3 0] ne "literal"} { + return 1; # Invocation of unknown command + } + set procName [lindex $q 3 1] + set inst [list $procName $argTypes] + if {![dict exists $typeInf $inst]} { + my debug-specializer { + puts "$inst is not compiled; need to test its NRE requirement" + } + tailcall my nonCompiledNeedsNRE $q $argTypes + } else { + my debug-specializer { + puts "Test NRE requirement for $inst : [dict exists $nreRequired $inst]" + } + tailcall dict exists $nreRequired $inst + } +} # quadcode::specializer method frameEffect -- # # Looks up what the effect of a command is on the callframe. # @@ -684,11 +895,11 @@ # If the severity is 'fatal', the procedure is marked 'failed' # and further attempts to compile it are abandoned. If the # severity is 'error' or 'fatal', it will not be included # when 'instancesNeeded' gets the list of procedures to compile. -oo::define quadcode::specializer method diagnostic {procName argTypes +oo::define quadcode::specializer method diagnostic {ctx argTypes file line script severity message args} { namespace upvar ::quadcode severities severities @@ -697,18 +908,21 @@ } if {![string is integer $severity]} { error "Unknown severity: $severity" } if {$severity <= 1} { - dict set failed $procName $argTypes $severity + if {[lindex $ctx 0] eq "proc"} { + set pname [lindex $ctx 1] + dict set failed $pname $argTypes $severity + } } if {[string length $script] > 50} { set script [string range $script 0 46]... } - set tuple [list $file $line $script $severity $procName $message $args] + set tuple [list $file $line $script $severity $ctx $message $args] if {![dict exists $diagnostics $tuple]} { dict set diagnostics $tuple [incr diagnosticSeq] } } @@ -730,23 +944,23 @@ namespace upvar ::quadcode severities severities set messages {} dict for {tuple seq} $diagnostics { - lassign $tuple file line script severity procName message arglist + lassign $tuple file line script severity ctx message arglist lappend messages $file $line $seq $script $severity \ - $procName $message $arglist + $ctx $message $arglist } set messages [lsort -stride 8 -index 2 -integer $messages] set messages [lsort -stride 8 -index 1 -integer $messages] set messages [lsort -stride 8 -index 0 $messages] set lastScript {} set lastCtx {} foreach {file line seq script severity ctx message arglist} $messages { - if {$procName ne $lastCtx} { + if {$ctx ne $lastCtx} { # TODO - l10n would need to go here! puts $ch "In $ctx:" set lastCtx $ctx } if {$script ne $lastScript} { @@ -785,16 +999,16 @@ dict for {proc d} $failed { dict for {arglist -} $d { lappend todo [list $proc $arglist] } } + while {[llength $todo] > 0} { set instance [lindex $todo end] set todo [lrange $todo 0 end-1] lassign $instance procn argl set fullname $procn\([lmap x $argl {nameOfType $x}]\) - puts stderr "Skipping $fullname because of above errors" if {[dict exists $dependents $instance]} { dict for {dep -} [dict get $dependents $instance] { lassign $dep dprocn dargl if {![dict exists $failed $dprocn $dargl]} { dict set failed $dprocn $dargl 0 @@ -810,10 +1024,11 @@ set todo {} set examined {} # Begin by adding explicitly required procedure instances to the work list # and setting them as needed. + dict for {proc d} $requiredInstances { dict for {arglist -} $d { if {![dict exists $failed $proc $arglist]} { lappend todo [list $proc $arglist] dict set examined [list $proc $arglist] {} Index: quadcode/transformer.tcl ================================================================== --- quadcode/transformer.tcl +++ quadcode/transformer.tcl @@ -7,11 +7,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ -namespace eval quadcode { +if {[info exists quadcode::sourced]} { return } + +namespace eval ::quadcode { + + variable sourced 1 + variable libdir [file dirname [info script]] namespace export \ builtinCommandType \ nameOfType \ @@ -123,19 +128,23 @@ # # TYPE INFERENCE # # types - Dictionary whose keys are variable names and whose values # are the numeric codes for the variable types. + # + # nre - Flag that is 1 if this procedure requires non-recursive + # evaluation, and 0 otherwise variable bytecode quadindex fixup variable debugged specializer originProc sourcefile ns variable quads vars links bbstart variable bbcontent bbpred variable bbidom bbkids bblevel bbnlevels varcount variable duchain udchain variable varExists variable types + variable nre variable ptype ns_counters # Constructor - # # Keyword arguments (following the positional arguments): @@ -369,10 +378,18 @@ # Results: # Returns a four-element list: return type, list of parameter types, # list of variable types, list of quadcode instructions. method getFlattenedQuads {} { + + # Promote entry to, return from, and invocation of procedures + # and commands that require non-recursive evaluation. + my promoteNREOperations + + # Promoting NRE operations will have put basic blocks out of + # topologic order, so fix that. + my deadbb # Make sure basic block begin with debug info my propDebugInfo @@ -629,11 +646,10 @@ # args - Arguments to subsitute into the message oo::define quadcode::transformer method diagnostic {severity b pc message args} { lassign [my sourceInfo $b $pc] file lines script ctx - $specializer diagnostic $ctx $ptype $file [lindex $lines 0] $script \ $severity $message {*}$args } # quadcode::transformer method audit-phis -- @@ -682,16 +698,18 @@ source [file join $quadcode::libdir inline.tcl] source [file join $quadcode::libdir invoke.tcl] source [file join $quadcode::libdir liveranges.tcl] source [file join $quadcode::libdir narrow.tcl] source [file join $quadcode::libdir nodesplit.tcl] +source [file join $quadcode::libdir nre.tcl] source [file join $quadcode::libdir renameTemps.tcl] source [file join $quadcode::libdir ssa.tcl] source [file join $quadcode::libdir translate.tcl] source [file join $quadcode::libdir typecheck.tcl] source [file join $quadcode::libdir types.tcl] source [file join $quadcode::libdir upvar.tcl] +source [file join $quadcode::libdir utils.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/types.tcl ================================================================== --- quadcode/types.tcl +++ quadcode/types.tcl @@ -141,10 +141,15 @@ # ARRAY - the value is an array and not an actual value, a failure or a # missing value. This type is always pure as it has no string # representation; there are no constants of this type. variable ARRAY [expr 0x40000] + + # COROHANDLE - the value is the handle returned from an LLVM coroutine + # operation + + variable COROHANDLE [expr 0x1000000] # EXPANDED - the value must go through argument expansion in # 'invokeExpanded' variable EXPANDED [expr 0x2000000] @@ -177,13 +182,13 @@ # STRING - the value is an actual value, not a failure nor a missing value # This type is always impure, and its internal representation # may be void because the string representation is the # only representation. - variable STRING [expr { - ~($CALLFRAME | $FAIL | $NEXIST | $DICTITER | $FOREACH | $EXPANDED | $ARRAY) - }] + variable STRING [expr {~($CALLFRAME | $FAIL | $NEXIST + | $DICTITER | $FOREACH | $EXPANDED + | $ARRAY | $COROHANDLE)}] # TOP - means no information. We do not know whether a value exists; # we do not know its type; we do not know whether it resulted from # an error in a computation. Also should not happen except possibly # as an initial value in an iterative calculation of types. @@ -339,10 +344,11 @@ foreach {name wname} { CALLFRAME CALLFRAME NEXIST NEXIST FAIL FAIL + COROHANDLE COROHANDLE ARRAY ARRAY DICTITER DICTITER FOREACH FOREACH EXPANDED EXPANDED OTHERSTRING STRING @@ -493,11 +499,11 @@ DOUBLE DOUBLE INT INT STRING STRING FAIL FAIL EMPTY EMPTY ZEROONE ZEROONE BOOL_INT BOOL BOOLWORD BOOLWORD ENTIER ENTIER NUMERIC NUMERIC IMPURE IMPURE VOID VOID CALLFRAME CALLFRAME DICTITER DICTITER FOREACH FOREACH - ARRAY ARRAY NEXIST NEXIST EXPANDED EXPANDED + ARRAY ARRAY NEXIST NEXIST EXPANDED EXPANDED COROHANDLE COROHANDLE } switch -exact -- [lindex $q 0 0] { debug-value { return [typeOfOperand $types [lindex $q 3]] @@ -673,11 +679,11 @@ return [expr {$EXPANDED | $t1}] } verifyList { return [expr {$FAIL | [typeOfOperand $types [lindex $q 2]]}] } - invoke { + "invoke" - "NRE.returnFromInvoke" { # We know the result type of a handful of the things # that might be invoked if {[lindex $q 3 0] eq "literal"} { set rtype [my typeOfInvoke [lindex $q 3 1] [lrange $q 4 end]] } else { @@ -684,10 +690,14 @@ set rtype [expr {$FAIL | $STRING}] } set inty [typeOfOperand $types [lindex $q 2]] return [expr {($inty & $CALLFRAME) | $rtype}] } + "NRE.invoke" { + set inty [typeOfOperand $types [lindex $q 2]] + return [expr {$COROHANDLE | ($inty & $CALLFRAME)}] + } invokeExpanded { # 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}] Index: quadcode/upvar.tcl ================================================================== --- quadcode/upvar.tcl +++ quadcode/upvar.tcl @@ -268,11 +268,12 @@ my diagnostic error $b $pc \ "double dereference is not implemented" set localVar [list literal \ufffderror] } set localVarName [lindex $localVar 1] - if {![dict exists $resFrame $localVarName]} { + if {![dict exists $resFrame $localVarName] + && ($source ne "Nothing")} { dict set resFrame $localVarName local } } } ADDED quadcode/utils.tcl Index: quadcode/utils.tcl ================================================================== --- /dev/null +++ quadcode/utils.tcl @@ -0,0 +1,158 @@ +# utils.tcl -- +# +# Code that supports various quadcode transformations and is +# shared among multiple different transformations. +# +# 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::transformer method bbUnlinkTail -- +# +# Unlinks all the quadruples from a given instruction through +# the end of its basic block from du- and ud-chains, and basic +# block predecessor and successor relations. +# +# Parameters: +# b - Number of the basic block +# pc - Program counter of the first instruction being deleted +# bb - Content of the basic block being edited, or {} if the +# content should be retrieved from 'bbcontent' +# +# Results: +# Returns a two-element list comprising the head and tail of +# the split block. +# +# Side effects: +# Linkages are destroyed. +# +# This call is used when carrying out a transformation that will involve +# splitting one basic block into two or more. The 'pc' argument will be the +# point after the last instruction in the basic block that will be preserved +# unchanged, and the remaining instructions will be isolated and returned +# as a list. Presumably they, or functional equivalents, will be inserted +# elsewhere in the program. + +oo::define quadcode::transformer method bbUnlinkTail {b pc {bb {}}} { + + # Get the basic block content, and split it into head (preserved) + # and tail (unlinked and returned). + + if {[llength $bb] == 0} { + set bb [lindex $bbcontent $b] + } + + set head [lrange $bb 0 [expr {$pc-1}]] + set tail [lrange $bb $pc end] + + # Unlink the operands of quads in the tail from ud- and du-chains, one + # by one. + + 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 + } + } + } + + + # Unlink the block from its successors + + foreach b2 [my bbsucc $b] { + my removePred $b2 $b + } + + # Store the head of the block that remains, back into bbcontent + + lset bbcontent $b $head + + return [list $head $tail] +} + +# quadcode::transformer method bbEmitAndTrack -- +# +# Emits a quadcode instruction to a basic block under construction +# and tracks its effects +# +# Parameters: +# b - Basic block number +# bbVar - Variable containing the content of the basic block under +# construction. +# q - Quadcode instruction to emit +# +# 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. +# +# This call is intended for use of transformations that perform extensive +# rewriting on quadcode, possibly giving rise to new basic blocks. It +# allows all the bookkeeping of ud- and du-chains, and of basic block +# predecessor and successor, to be maintained in one place. + +oo::define quadcode::transformer method bbEmitAndTrack {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 + } + } + } + + puts "--> $b:[llength $bb]: $q" + + lappend bb $q + + return +} + +# quadcode::transformer method bbCreate -- +# +# Creates a new basic block when rewriting a code sequence. +# +# Parameters: +# None +# +# Results: +# Returns the index of the new basic block, which will be empty +# and have no predecessors. + +oo::define quadcode::transformer method bbCreate {} { + + set b [llength $bbcontent] + + lappend bbcontent {} + lappend bbpred {} + + return $b +} + +# 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/varargs.tcl ================================================================== --- quadcode/varargs.tcl +++ quadcode/varargs.tcl @@ -205,32 +205,24 @@ # 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]] + lassign [my bbUnlinkTail $b [$call pc0]] bb # 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 norm0b [my bbCreate] + set err0b [my bbCreate] + set notokb [my bbCreate] + set norm1b [my bbCreate] + set err1b [my bbCreate] + set normb [my bbCreate] + set errorb [my bbCreate] set errorphis {} # Create the first part of the 'invoke' instruction set invokeres [my newVarInstance $cfin] set newq [list invoke $invokeres $cfin $calleeLit] @@ -237,26 +229,26 @@ # 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 + my bbEmitAndTrack $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 \ + my bbEmitAndTrack $notokb notokbb \ [list jumpMaybe [list bb $err1b] $invexpres] - my varargsEmitAndTrack $notokb notokbb [list jump [list bb $norm1b]] + my bbEmitAndTrack $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]] + my bbEmitAndTrack $edge splitbb [list jump [list bb $target]] lset bbcontent $edge $splitbb } # Now start the parameter checking logic @@ -288,12 +280,12 @@ # 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] + my bbEmitAndTrack $b bb [list listLength $lenLoc1 $listLoc] + my bbEmitAndTrack $b bb [list extractMaybe $lenLoc $lenLoc1] # Count the mandatory args set firstMandatory $pos while {$pos < $nPlainParams} { @@ -326,13 +318,11 @@ 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 finishB [my bbCreate] set i $firstOptional while {$i < $nPlainParams} { info default $callee [lindex $arginfo $i] defaultVal lassign [my varargsUnpackOptional tempIndex b bb \ $finishB $compTemp $listLoc $lenLoc $j] \ @@ -365,45 +355,45 @@ 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 + my bbEmitAndTrack $b bb $q2 set cfin $cf2 lset newq 2 $cfin } # 2. Emit the call as rewritten - my varargsEmitAndTrack $b bb $newq + my bbEmitAndTrack $b bb $newq # 3. Make the 'retrieveResult' set okresult [my newVarInstance [$call retval]] - my varargsEmitAndTrack $b bb [list retrieveResult $okresult $invokeres] + my bbEmitAndTrack $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] + my bbEmitAndTrack $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 \ + my bbEmitAndTrack $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]] + my bbEmitAndTrack $b bb [list jumpMaybe [list bb $err0b] $okresult] + my bbEmitAndTrack $b bb [list jump [list bb $norm0b]] # Emit the final basic block rewrite lset bbcontent $b $bb @@ -418,13 +408,13 @@ 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 bbEmitAndTrack $normb normbb [list phi $v {*}$sources] } - my varargsEmitAndTrack $normb normbb [list jump [list bb [$call normexit]]] + my bbEmitAndTrack $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 { @@ -432,13 +422,13 @@ 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 bbEmitAndTrack $errorb errorbb [list phi $v {*}$sources] } - my varargsEmitAndTrack $errorb errorbb [list jump [list bb [$call errexit]]] + my bbEmitAndTrack $errorb errorbb [list jump [list bb [$call errexit]]] lset bbcontent $errorb $errorbb # Restore dominance relationships my bbidom; my bblevel @@ -463,49 +453,10 @@ 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 -- # # Transfer a leading non-expanded argument into a quad # under construction when rewriting 'invokeExpanded' @@ -579,19 +530,19 @@ } 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] + my bbEmitAndTrack $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] + my bbEmitAndTrack $b bb [list list $listLoc $arg] } } } } @@ -617,15 +568,15 @@ # 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] + my bbEmitAndTrack $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] + my bbEmitAndTrack $b bb [list extractMaybe $listLoc $nloc] } return $listLoc } @@ -646,31 +597,27 @@ oo::define quadcode::transformer method varargsCheckEnough {b bb lenLoc compTemp nMandatory errorB} { # Emit {$nMandatory > $lenLoc} set compLoc [my newVarInstance $compTemp] - my varargsEmitAndTrack $b bb \ + my bbEmitAndTrack $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]] + set intb [my bbCreate] + set newb [my bbCreate] + + my bbEmitAndTrack $b bb [list jumpTrue [list bb $intb] $compLoc] + my bbEmitAndTrack $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]] + my bbEmitAndTrack $intb bb [list jump [list bb $errorB]] lset bbcontent $intb $bb set bb {} return $newb } @@ -707,17 +654,17 @@ # 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 \ + my bbEmitAndTrack $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] + my bbEmitAndTrack $b bb [list extractMaybe $argLoc2 $argLoc] # Put the extracted arg on the 'invoke' instruction lappend newq $argLoc2 } } @@ -757,42 +704,38 @@ 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] + my bbEmitAndTrack $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] + set intb [my bbCreate] + my bbEmitAndTrack $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]] + set newb [my bbCreate] + my bbEmitAndTrack $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]] + my bbEmitAndTrack $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] + my bbEmitAndTrack $b bb [list listIndex $argLoc1 $listLoc $pos] # Emit the 'extractMaybe' on the 'listIndex' result - my varargsEmitAndTrack $b bb [list extractMaybe $argLoc2 $argLoc1] + my bbEmitAndTrack $b bb [list extractMaybe $argLoc2 $argLoc1] # Return the place where we stored the arg return [list $intb $argLoc2] } @@ -826,11 +769,11 @@ 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]] + my bbEmitAndTrack $b bb [list jump [list bb $finishB]] lset bbcontent $b $bb set bb {} set fromb $b set b $finishB @@ -853,11 +796,11 @@ } else { lappend q $defaultLit } } lappend q [list bb $fromb] $tempLoc - my varargsEmitAndTrack $b bb $q + my bbEmitAndTrack $b bb $q lappend newq $newTemp } } # quadcode::transformer method varargsDoArgs -- @@ -889,14 +832,14 @@ 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 \ + my bbEmitAndTrack $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] + my bbEmitAndTrack $b bb [list extractMaybe $argsLoc2 $argsLoc1] lappend newq $argsLoc2 } } # quadcode::transformer method varargsCheckTooMany -- @@ -924,26 +867,22 @@ 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]] + my bbEmitAndTrack $b bb [list gt $compLoc $lenLoc [list literal $i]] + + set intb [my bbCreate] + my bbEmitAndTrack $b bb [list jumpTrue [list bb $intb] $compLoc] + + set newb [my bbCreate] + my bbEmitAndTrack $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]] + my bbEmitAndTrack $b bb [list jump [list bb $errorB]] lset bbcontent $b $bb set b $newb set bb {} @@ -1000,11 +939,11 @@ lappend burst $q return $burst } -# quadcode::transformer method varargsEmitAndTrack -- +# quadcode::transformer method bbEmitAndTrack -- # # Emits a quadcode instruction and tracks its effects # # Parameters: # b - Basic block number @@ -1016,11 +955,11 @@ # # 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} { +oo::define quadcode::transformer method bbEmitAndTrack {b bbVar q} { upvar 1 $bbVar bb set res [lindex $q 1] switch -exact -- [lindex $res 0] { Index: quadcode/widen.tcl ================================================================== --- quadcode/widen.tcl +++ quadcode/widen.tcl @@ -86,11 +86,11 @@ # Also widen the operand of any 'return' instruction # Make sure we have the current content of the basic block set content [lindex $bbcontent $b] set q [lindex $content end] - if {[lindex $q 0] eq "return"} { + if {[lindex $q 0] in {"return" "NRE.return"}} { set source [lindex $q 3] set desttype [dict get $types "return"] if {[typeOfOperand $types $source] != $desttype} { @@ -99,11 +99,11 @@ lset bbcontent $b {} set content \ [lreplace $content[set content {}] end end \ [list [list widenTo $desttype [nameOfType $desttype]] \ $newvar $source] \ - [list return {} [lindex $q 2] $newvar]] + [list [lindex $q 0] {} [lindex $q 2] $newvar]] lset bbcontent $b $content dict set udchain $newvar $b my addUse $newvar $b my removeUse $source $b dict set types $newvar $desttype