Index: codegen.tcl ================================================================== --- codegen.tcl +++ codegen.tcl @@ -51,10 +51,11 @@ include codegen/struct.tcl include codegen/llvmbuilder.tcl include codegen/build.tcl include codegen/mathlib.tcl include codegen/stdlib.tcl + include codegen/varframe.tcl include codegen/thunk.tcl include codegen/tclapi.tcl include codegen/macros.tcl include codegen/compile.tcl include codegen/debug.tcl Index: codegen/build.tcl ================================================================== --- codegen/build.tcl +++ codegen/build.tcl @@ -224,35 +224,117 @@ method in32range {int {name ""}} { my and [my ge $int [Const -0x80000000 int64]] \ [my le $int [Const 0x7fffffff int64]] $name } + # Builder:fieldtostruct -- + # + # Given a pointer to a field in a structure and a specification of which + # type and field it is, return a pointer to the overall structure + # containing that field. Note that this does not require dereferencing + # the field pointer. + # + # Parameters: + # fieldPtr - + # The pointer LLVM value reference to the field. + # type - The LLVM type of the structure. + # fieldname - + # The name of the field within the structure. + # name (optional) - + # A name to give to the result value. + # + # Results: + # A pointer LLVM value reference to the structure. + method fieldtostruct {fieldPtr type fieldname {name ""}} { set off [my neg [my offsetof $type $fieldname]] set ptr [my cast(ptr) $fieldPtr char] return [my cast(ptr) [my getelementptr $ptr $off] $type $name] } + + # Builder:frame.pack -- + # + # Combine a callframe with another value. + # + # Parameters: + # callframe - + # The CALLFRAME LLVM value reference. + # value - The INT LLVM value reference for the non-callframe value. + # name (optional) - + # A name to give to the result value. + # + # Results: + # A CALLFRAME-value tuple LLVM value reference. method frame.pack {callframe value {name ""}} { set type [Type struct{CALLFRAME,[TypeOf $value]}] my insert [my insert [my undef $type] $callframe 0] $value 1 $name } + + # Builder:frame.frame -- + # + # Extract the callframe from a tupled value. + # + # Parameters: + # callframetuple - + # The CALLFRAME-tuple LLVM value reference. + # name (optional) - + # A name to give to the result value. + # + # Results: + # A CALLFRAME LLVM value reference. + method frame.frame {callframetuple {name ""}} { my extract $callframetuple 0 $name } + + # Builder:frame.value -- + # + # Extract the non-callframe value from a tuple. + # + # Parameters: + # callframetuple - + # The CALLFRAME-tuple LLVM value reference. + # name (optional) - + # A name to give to the result value. + # + # Results: + # An LLVM value reference. + method frame.value {callframetuple {name ""}} { my extract $callframetuple 1 $name } + + # Builder:frame.create -- + # + # Create and initialise a callframe. + # + # Parameters: + # varlist - + # The Tcl list of information about the callframe's variables + # extracted from the bytecode. + # argc - The int LLVM value reference for the number of arguments. + # argv - The STRING* LLVM value reference (or equivalent type) for the + # 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. + # + # 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} { + # Construct the call frame itself set callframe [my alloc CallFrame "callframe"] - set length [Const [llength $varlist]] - set locals [my arrayAlloc 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 {} foreach varinfo $varlist { lassign $varinfo flags var set flagbits 0 @@ -268,42 +350,238 @@ [Const [incr idx] int] [Const $flagbits int]] dict set varmap $var $v } return [list $callframe $varmap] } + + # Builder:frame.release -- + # + # Delete the contents of a call frame. + # + # Parameters: + # callframe - + # The CALLFRAME LLVM value reference. + # synthetics - + # A Tcl list of booleans saying which values in the callframe's + # argv array need to have their reference counts decremented + # because they are synthetic. + # + # Results: + # None. + method frame.release {callframe synthetics} { set idx -1 foreach drop $synthetics { incr idx if {$drop} { - if {![info exist argv]} { - set argv [my dereference $callframe 0 CallFrame.argv] + if {![info exist objv]} { + set objv [my dereference $callframe 0 CallFrame.objv] } - set obj [my dereference $argv 0 $idx] + set obj [my dereference $objv $idx] my dropReference(STRING) $obj } } my Call tcl.callframe.clear $callframe + return } + + # Builder:frame.store(STRING) -- + # + # Transfer a value into a call frame variable. + # + # Parameters: + # value - The LLVM value reference to go into the call frame's var. + # callframe - + # The CALLFRAME LLVM value reference. + # var - The Var* LLVM reference for the variable to write to. + # varName - + # The Tcl string of the name of the variable. + # + # Results: + # None. + method frame.store(STRING) {value callframe var varName} { my frame.store(NEXIST\040STRING) [my just $value] \ $callframe $var $varName } + + # Builder:frame.store(NEXIST STRING) -- + # + # Transfer a value into a call frame variable. A non-existing value will + # convert into an unsetting of the variable. + # + # Parameters: + # value - The LLVM value reference to go into the call frame's var. + # callframe - + # The CALLFRAME LLVM value reference. + # var - The Var* LLVM reference for the variable to write to. + # varName - + # The Tcl string of the name of the variable. + # + # Results: + # None. + method frame.store(NEXIST\040STRING) {value callframe var varName} { my Call tcl.callframe.store $var [Const $varName STRING] $value + return } + + # Builder:frame.store(NEXIST) -- + # + # Unset a variable in a call frame. + # + # Parameters: + # value - The non-existing value to put in the variable. + # callframe - + # The CALLFRAME LLVM value reference. + # var - The Var* LLVM reference for the variable to unset. + # varName - + # The Tcl string of the name of the variable. + # + # Results: + # None. + method frame.store(NEXIST) {value callframe var varName} { my frame.unset $callframe $var $varName } + + # Builder:frame.unset -- + # + # Unset a variable in a call frame. + # + # Parameters: + # callframe - + # The CALLFRAME LLVM value reference. + # var - The Var* LLVM reference for the variable to unset. + # varName - + # The Tcl string of the name of the variable. + # + # Results: + # None. + method frame.unset {callframe var varName} { my frame.store(NEXIST\040STRING) [my nothing STRING] \ $callframe $var $varName } + + # Builder:frame.load -- + # + # Read a value from a variable in a call frame. Only variables in the + # call frame may be read or writen with this method call. + # + # Parameters: + # callframe - + # The CALLFRAME LLVM value reference. + # var - The Var* LLVM reference for the variable to read. + # varName - + # The Tcl string of the name of the variable. + # name (optional) - + # The LLVM name of the result value. + # + # Results: + # An LLVM STRING? value reference. + method frame.load {callframe var varName {name ""}} { my call ${tcl.callframe.load} [list $var [Const $varName STRING]] \ $name } + + # Builder:frame.bind.nsvar(STRING,STRING,STRING) -- + # + # Link a variable in the local call frame to a variable looked up in a + # given named namespace. + # + # Parameters: + # localName - + # An LLVM STRING reference to the local variable name. + # nsName - + # An LLVM STRING reference to the namespace name. + # otherName - + # An LLVM STRING reference to the name of the variable in the + # namespace to link to. + # localVar - + # An LLVM Var* reference to the local variable. + # callframe - + # The CALLFRAME LLVM value reference. + # ec - An int* LLVM reference for where to write error codes into. + # name (optional) - + # The LLVM name of the result value. + # + # Results: + # An LLVM bool? value reference. + + method frame.bind.nsvar(STRING,STRING,STRING) { + localName nsName otherName localVar callframe ec {name ""}} { + set otherVar [my call ${tcl.callframe.lookup.varns} [list \ + $callframe $nsName $otherName] "otherVar"] + set val [my Call tcl.callframe.bindvar $callframe \ + $otherVar $localVar $localName $ec] + return [my frame.pack $callframe $val $name] + } + + # Builder:frame.bind.var(STRING,STRING) -- + # + # Link a variable in the local call frame to a variable looked up with + # general respect to the call frame's context. + # + # Parameters: + # localName - + # An LLVM STRING reference to the local variable name. + # otherName - + # An LLVM STRING reference to the name of the variable to link + # to. + # localVar - + # An LLVM Var* reference to the local variable. + # callframe - + # The CALLFRAME LLVM value reference. + # ec - An int* LLVM reference for where to write error codes into. + # name (optional) - + # The LLVM name of the result value. + # + # Results: + # An LLVM bool? value reference. + + method frame.bind.var(STRING,STRING) { + localName otherName localVar callframe ec {name ""}} { + set otherVar [my call ${tcl.callframe.lookup.var} [list \ + $callframe $otherName] "otherVar"] + set val [my call ${tcl.callframe.bindvar} [list \ + $callframe $otherVar $localVar $localName $ec] $name] + return [my frame.pack $callframe $val $name] + } + + # Builder:frame.bind.nsvar(STRING,STRING,STRING) -- + # + # Link a variable in the local call frame to a variable looked up in an + # indicated call frame. + # + # Parameters: + # localName - + # An LLVM STRING reference to the local variable name. + # level - An LLVM STRING reference to the level descriptor. + # otherName - + # An LLVM STRING reference to the name of the variable in the + # namespace to link to. + # localVar - + # An LLVM Var* reference to the local variable. + # callframe - + # The CALLFRAME LLVM value reference. + # ec - An int* LLVM reference for where to write error codes into. + # 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 ""}} { + 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] + } # Builder:add(INT,INT) -- # # Generate code to add two INTs. Quadcode implementation ('add'). # @@ -465,11 +743,11 @@ # # Results: # None. method addReference(NEXIST\040STRING) {value} { - my Call tcl.addMaybeReference $value + my Call tcl.addNExistReference $value return } # Builder:addReference(FAIL STRING) -- # @@ -480,11 +758,11 @@ # # Results: # None. method addReference(FAIL\040STRING) {value} { - my Call tcl.addMaybeReference $value + my Call tcl.addFailReference $value return } # Builder:addReference(NEXIST EMPTY) -- # @@ -495,11 +773,11 @@ # # Results: # None. method addReference(NEXIST\040EMPTY) {value} { - my Call tcl.addMaybeReference $value + my Call tcl.addNExistReference $value return } # Builder:addReference(FAIL EMPTY) -- # @@ -510,11 +788,11 @@ # # Results: # None. method addReference(FAIL\040EMPTY) {value} { - my Call tcl.addMaybeReference $value + my Call tcl.addFailReference $value return } # Builder:addReference(DICTITER) -- # @@ -528,10 +806,24 @@ method addReference(DICTITER) {value} { my call ${tcl.dict.addIterReference} [list $value] "" return } + + # Builder:addReference(FAIL DICTITER) -- + # + # Generate code to increment the reference count of a FAIL DICTITER value. + # + # Parameters: + # value - The DICTITER LLVM value reference for the operand. + # + # Results: + # None. + + method addReference(FAIL\040DICTITER) {value} { + my Call tcl.dict.addIterFailReference $value + } # Builder:appendString -- # # Append a string value to a working buffer. The working buffer is # assumed to be an UNSHARED Tcl_Obj reference; caller must ensure this, @@ -947,11 +1239,11 @@ if {[TypeOf $value] eq [Type int32]} { set packer packInt32 } else { set packer packInt64 } - my just [my $packer $value] $name + my ok [my $packer $value] $name } # Builder:cast(NUMERIC?) -- # # Generate code to cast an INT, DOUBLE, INT? or DOUBLE? to a NUMERIC?. @@ -966,20 +1258,20 @@ # A NUMERIC FAIL LLVM value reference. method cast(NUMERIC?) {value {name ""}} { set t [TypeOf $value] if {$t eq [Type DOUBLE]} { - return [my just [my packNumericDouble $value]] + return [my ok [my packNumericDouble $value]] } elseif {$t eq [Type INT]} { - return [my just [my packNumericInt $value]] + return [my ok [my packNumericInt $value]] } elseif {$t eq [Type DOUBLE?]} { set packer packNumericDouble } else { set packer packNumericInt } - my select [my maybe $value] [my nothing NUMERIC] \ - [my just [my $packer [my unmaybe $value]]] $name + my select [my maybe $value] [my fail NUMERIC] \ + [my ok [my $packer [my unmaybe $value]]] $name } # Builder:cast(bool) -- # # Generate code to cast an INT to an int1. @@ -1559,10 +1851,135 @@ # The new dictionary value. method dictUnset(STRING,STRING) {dict key ec {name ""}} { my call ${tcl.dict.unset1} [list $dict $key $ec] $name } + + # Builder:directAppend(STRING,STRING) -- + # + # Append a value to a variable, which should be referred to by a + # fully-qualified name. NOTE: this operation can fail because of traces + # so it produces a STRING FAIL. Quadcode implementation + # ('directAppend'). + # + # Parameters: + # varname - + # The variable name as an LLVM value reference. + # value - The value to append as an LLVM value reference. + # ec - Where to write the error code if an error happens. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The new contents of the variable. + + method directAppend(STRING,STRING) {varname value ec {name ""}} { + my call ${tcl.direct.append} [list $varname $value $ec] $name + } + + # Builder:directExists(STRING) -- + # + # Test if a variable exists; the variable should be referred to by a + # fully-qualified name. Quadcode implementation ('directExists'). + # + # Parameters: + # varname - + # The variable name as an LLVM value reference. + # name (optional) - + # A name to give to the result value. + # + # Results: + # A ZEROONE that indicates whether the variable is set. + + method directExists(STRING) {varname {name ""}} { + my call ${tcl.direct.exists} [list $varname] $name + } + + # Builder:directGet(STRING) -- + # + # Read the value of a variable, which should be referred to by a + # fully-qualified name. NOTE: this operation can fail because of traces + # so it produces a STRING FAIL. Quadcode implementation ('directGet'). + # + # Parameters: + # varname - + # The variable name as an LLVM value reference. + # ec - Where to write the error code if an error happens. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The contents of the variable. + + method directGet(STRING) {varname ec {name ""}} { + my call ${tcl.direct.get} [list $varname $ec] $name + } + + # Builder:directLappend(STRING,STRING) -- + # + # Append a value to a list in a variable, which should be referred to by + # a fully-qualified name. NOTE: this operation can fail because of + # traces so it produces a STRING FAIL. Quadcode implementation + # ('directLappend'). + # + # Parameters: + # varname - + # The variable name as an LLVM value reference. + # value - The value to append as an LLVM value reference. + # ec - Where to write the error code if an error happens. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The new contents of the variable. + + method directLappend(STRING,STRING) {varname value ec {name ""}} { + my call ${tcl.direct.lappend} [list $varname $value $ec] $name + } + + # Builder:directSet(STRING,STRING) -- + # + # Set the value of a variable, which should be referred to by a + # fully-qualified name. NOTE: this operation can fail because of traces + # so it produces a STRING FAIL. Quadcode implementation ('directSet'). + # + # Parameters: + # varname - + # The variable name as an LLVM value reference. + # value - The value to append as an LLVM value reference. + # ec - Where to write the error code if an error happens. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The new contents of the variable. + + method directSet(STRING,STRING) {varname value ec {name ""}} { + my call ${tcl.direct.set} [list $varname $value $ec] $name + } + + # Builder:directUnset(STRING,INT) -- + # + # Unset a variable, which should be referred to by a fully-qualified + # name. NOTE: this operation can fail because of traces so it produces a + # ZEROONE FAIL (with meaningless value when not failing). Quadcode + # implementation ('directUnset'). + # + # Parameters: + # varname - + # The variable name as an LLVM value reference. + # flag - Whether failures are allowed, as an LLVM value reference. + # ec - Where to write the error code if an error happens. + # name (optional) - + # A name to give to the result value. + # + # Results: + # Whether the unset was successful. + + method directUnset(STRING,INT) {varname flag ec {name ""}} { + my call ${tcl.direct.unset} [list $varname $flag $ec] $name + } # Builder:div(INT,INT) -- # # Generate code to divide two INTs. Quadcode implementation ('div'). # @@ -1722,11 +2139,11 @@ method dropReference(STRING) {value} { my Call tcl.dropReference $value return } - # Builder:dropReference(STRING FAIL) -- + # Builder:dropReference(FAIL EMPTY) -- # # Generate code to decrement the reference count of a value and delete # the value if it has ceased to be used. # # Parameters: @@ -1733,12 +2150,12 @@ # value - The STRING FAIL LLVM value reference for the operand. # # Results: # None. - method dropReference(STRING\040FAIL) {value} { - my Call tcl.dropMaybeReference $value + method dropReference(FAIL\040EMPTY) {value} { + my Call tcl.dropFailReference $value return } # Builder:dropReference(FAIL STRING) -- # @@ -1750,11 +2167,11 @@ # # Results: # None. method dropReference(FAIL\040STRING) {value} { - my Call tcl.dropMaybeReference $value + my Call tcl.dropFailReference $value return } # Builder:dropReference(NEXIST STRING) -- # @@ -1766,11 +2183,11 @@ # # Results: # None. method dropReference(NEXIST\040STRING) {value} { - my Call tcl.dropMaybeReference $value + my Call tcl.dropNExistReference $value return } # Builder:dropReference(NEXIST EMPTY) -- # @@ -1782,11 +2199,11 @@ # # Results: # None. method dropReference(NEXIST\040EMPTY) {value} { - my Call tcl.dropMaybeReference $value + my Call tcl.dropNExistReference $value return } # Builder:dropReference(DICTITER) -- # @@ -2169,10 +2586,37 @@ # A NUMERIC? LLVM value reference. method expon(NUMERIC,NUMERIC) {left right ec {name ""}} { my call ${tcl.pow.numeric} [list $left $right $ec] $name } + + # Builder:fail -- + # + # Create a Nothing FAIL of the given type. + # + # Parameters: + # type - The type of the FAIL. + # code (optional) - + # The error code in the failure (LLVM int32 reference), or the + # empty string to use the default. + # name (optional) - + # A name to give to the result value. + # + # Results: + # An LLVM FAIL value reference containing nothing. + + method fail {type {code ""} {name ""}} { + if {[string match "* FAIL" $type]} { + set type [string range $type 0 end-5] + } elseif {[string match "FAIL *" $type]} { + set type [string range $type 5 end] + } + if {$code eq ""} { + set code [Const 1] + } + my insert [my undef $type?] $code 0 $name + } # Builder:ge -- # # Generate code to compare two integers of the same bit width *or* two # pointers to see if the first is greater or equal to the second. @@ -2579,11 +3023,11 @@ # FIXME? # my dropReference $stringed } my store $code $errVar my select [my eq $code [Const 0]] \ - [my just $value] [my nothing $type] $name + [my ok $value] [my fail $type $code] $name } # Builder:initException(STRING,INT,INT) -- # # Generate/set up an exception, returning a FAIL derived from the @@ -2602,11 +3046,11 @@ # # Results: # An LLVM value reference. method initException(STRING,INT,INT) {dict code level value type errVar {name ""}} { - if {$type eq "STRING"} { + if {$type in {STRING EMPTY}} { set newcode [my Call tcl.processReturn \ $value [my getInt32 $code] [my getInt32 $level] $dict] } else { set stringed [my stringify($type) $value] set newcode [my Call tcl.processReturn \ @@ -2615,11 +3059,11 @@ my dropReference $stringed } SetValueName $newcode "code" my store $newcode $errVar my select [my eq $newcode [Const 0]] \ - [my just $value] [my nothing $type] $name + [my ok $value] [my fail $type $newcode] $name } # Builder:instanceOf.DOUBLE(STRING) -- # # Generate code to check if the given STRING contains something that can @@ -3497,22 +3941,22 @@ my lt [my Call tcl.cmp.strstr $left $right] [Const 0] $name } # Builder:just -- # - # Package a value as a Just FAIL. + # Package a value as a Just NEXIST. # # Parameters: - # value - The value to put inside the FAIL. + # value - The value to put inside the NEXIST. # name (optional) - # A name to give to the result value. # # Results: - # An LLVM FAIL value reference containing the other value. + # An LLVM NEXIST value reference containing the other value. method just {value {name ""}} { - my insert [my insert [my undef [TypeOf $value]?] \ + my insert [my insert [my undef [TypeOf $value]!] \ [Const false bool] 0] $value 1 $name } # Builder:narrowToType.DOUBLE(STRING) -- # @@ -3554,11 +3998,11 @@ } # Builder:narrowToType.IMPURE_BOOLEAN(IMPURE ZEROONE BOOLEAN) -- # # Generate code to extract IMPURE BOOLEAN from IMPURE ZEROONE BOOLEAN. - # The extracton does nothing except bump the reference count, the two + # The extraction does nothing except bump the reference count, the two # types have the same internal representation # # Parameters: # value - The STRING LLVM value reference to parse. # name (optional) - @@ -3709,33 +4153,34 @@ return [my impure NUMERIC $value $nval $name] } # Builder:nothing -- # - # Create a Nothing FAIL of the given type. + # Create a Nothing NEXIST of the given type. # # Parameters: - # type - The type of the FAIL. + # type - The type of the NEXIST. # name (optional) - # A name to give to the result value. # # Results: - # An LLVM FAIL value reference containing nothing. + # An LLVM NEXIST value reference containing nothing. method nothing {type {name ""}} { - if {[string match "* FAIL" $type]} { - set type [string range $type 0 end-5] - } elseif {[string match "FAIL *" $type]} { - set type [string range $type 5 end] + if {[string match "* NEXIST" $type]} { + set type [string range $type 0 end-7] + } elseif {[string match "NEXIST *" $type]} { + set type [string range $type 7 end] } - my insert [my undef $type?] [Const true bool] 0 $name + my insert [my undef $type!] [Const true bool] 0 $name } # Builder:unmaybe -- # - # Get the value out of a FAIL. NOTE: The FAIL must be a Just or the - # result will be an 'undef'; test with the 'maybe' method first! + # Get the value out of a FAIL or NEXIST. NOTE: The FAIL/NEXIST must be a + # Just or the result will be an 'undef'; test with the 'maybe' method + # first! # # Parameters: # value - The FAIL to get the value from. # name (optional) - # A name to give to the result value. @@ -3770,23 +4215,28 @@ my call ${tcl.maptoint} [list $value $mapping $notThere] $name } # Builder:maybe -- # - # Test if the FAIL value is a Nothing. + # Test if the FAIL or NEXIST value is a Nothing. # # Parameters: - # type - The FAIL to examine. + # type - The FAIL or NEXIST to examine. # name (optional) - # A name to give to the result value. # # Results: # An LLVM int1 value reference that is true when the FAIL is a Nothing # and false when the FAIL is a Just. method maybe {value {name ""}} { - my extract $value 0 $name + set flag [my extract $value 0 $name] + if {[TypeOf $flag] eq [Type bool]} { + my neq [Const false bool] $flag + } else { + my neq [Const 0] $flag + } } # Builder:max -- # # Determines the maximum of two LLVM int[x] values. @@ -4179,10 +4629,27 @@ # A ZEROONE LLVM value reference. method not(ZEROONE) {value errVar {name ""}} { my not $value $name } + + # Builder:ok -- + # + # Package a value as a Just FAIL. + # + # Parameters: + # value - The value to put inside the FAIL. + # name (optional) - + # A name to give to the result value. + # + # Results: + # An LLVM FAIL value reference containing the other value. + + method ok {value {name ""}} { + my insert [my insert [my undef [TypeOf $value]?] \ + [Const 0] 0] $value 1 $name + } # Builder:packImpure(DOUBLE) -- # # Convert a DOUBLE to an IMPURE DOUBLE # @@ -4251,10 +4718,27 @@ method {packImpure(ZEROONE BOOLEAN)} {value {name ""}} { set sval [my stringify(NUMERIC) $value] my addReference(STRING) $sval return [my impure ZEROONE $sval $value $name] } + + # Builder:proc.return -- + # + # Convert a return code in the way the end of a procedure does. + # + # Parameters: + # value - LLVM Value to pack into the 'impure' structure + # name (optional) - + # A name to give to the result value. + # + # Results: + # Returns an LLVM IMPURE NUMERIC value + + method proc.return {value procName} { + set name [Const $procName STRING] + return [my call ${tcl.procedure.return} [list $value $name] "code"] + } # Builder:regexp(INT,STRING,STRING) -- # # Match a string against a regular expression. NOTE: this operation can # fail (e.g., because it can be given an invalid regexp) so it produces @@ -4360,10 +4844,64 @@ # An INT LLVM value reference. method rshift(INT,INT) {left right {name ""}} { my call ${tcl.shr} [list $left $right] $name } + + # Builder:logCommandInfo -- + # + # Generate code to log information about a command in the exception + # trace. + # + # Parameters: + # errorCode - + # The int32 LLVM value reference for the Tcl error code. + # command - + # The Tcl string containing the text of the command script + # (i.e., sourced before substitutions are performed). + # + # Results: + # None. + + method logCommandInfo {errorCode command} { + set limit 150 + set overflow [expr {[string length $command] > $limit}] + set length [Const [expr {$overflow ? $limit : [string length $command]}]] + set cmd [my constString $command] + set ellipsis [my constString [if {$overflow} {string cat "..."}]] + my Call tcl.logCommandInfo $errorCode $length $cmd $ellipsis + return + } + + # Builder:setErrorLine -- + # + # Generate code to log information about a command in the exception + # trace if that command happens to have generated an error. + # + # Parameters: + # test - The bool LLVM value reference that says whether the command + # this is talking about generated a non-TCL_OK result. + # errorCode - + # The int32 LLVM value reference for the Tcl error code. + # line - The int32 LLVM value reference for the source line number for + # the (start of) the command. + # command - + # The Tcl string containing the text of the command script + # (i.e., sourced before substitutions are performed). + # + # Results: + # None. + + method setErrorLine {test errorCode line command} { + set limit 150 + set overflow [expr {[string length $command] > $limit}] + set length [Const [expr {$overflow ? $limit : [string length $command]}]] + set cmd [my constString $command] + set ellipsis [my constString [if {$overflow} {string cat "..."}]] + my Call tcl.setErrorLine $test $errorCode $line $length $cmd $ellipsis + return + } method storeInStruct {structPointer fieldOffset value} { set field [my gep $structPointer 0 $fieldOffset] set fieldName [regsub {.*\.} $fieldOffset ""] SetValueName $field [GetValueName $structPointer].$fieldName @@ -4643,11 +5181,11 @@ # Results: # A STRING FAIL LLVM value reference (never a nothing). This will have a # non-zero reference count. method strindex(STRING,INT) {str idx ecvar {name ""}} { - my just [my Call tcl.stridx $str $idx] $name + my ok [my Call tcl.stridx $str $idx] $name } # Builder:strindex(STRING,STRING) -- # # Generate a STRING (of length 1) that describes the character in the @@ -4760,11 +5298,11 @@ # Results: # A STRING FAIL LLVM value reference (never a nothing). This will have a # non-zero reference count. method strrange(STRING,INT,INT) {str from to ecvar {name ""}} { - my just [my Call tcl.strrange $str $from $to] $name + my ok [my Call tcl.strrange $str $from $to] $name } # Builder:strrange(STRING,STRING,STRING) -- # # Generate a STRING that describes the substring of the input STRING @@ -4812,11 +5350,11 @@ # Results: # A STRING FAIL LLVM value reference (never a nothing). This will have a # non-zero reference count. method strreplace(STRING,INT,INT,STRING) {str from to substr ecvar {name ""}} { - my just [my Call tcl.strreplace $str $from $to $substr] $name + my ok [my Call tcl.strreplace $str $from $to $substr] $name } # Builder:strreplace(STRING,STRING,STRING,STRING) -- # # Generate a STRING that is the input STRING 'str' with the substring Index: codegen/compile.tcl ================================================================== --- codegen/compile.tcl +++ codegen/compile.tcl @@ -24,11 +24,11 @@ # none oo::class create TclCompiler { superclass llvmEntity variable bytecode cmd func quads paramTypes returnType vtypes variables - variable m b pc errorCode + variable m b pc errorCode currentline currentscript variable bytecodeVars namespace constructor {} { next namespace import \ @@ -195,11 +195,11 @@ ############################################################## # # Construct the function signature type and the function object. # - set ft [llvmtcl FunctionType $returntype $argl 0] + set ft [FunctionType $returntype $argl 0] dict set bytecode signature [list $rtype $argn] set realname [my GenerateFunctionName $cmd typecodes $paramTypes] # Check if the function already exists; that indicates serious # problems in the caller. if {[$m function.defined $realname]} { @@ -316,10 +316,11 @@ set phiAnnotations {} set theframe {} set thevarmap {} set syntheticargs {} set currentline 0 + set currentscript {} foreach l $quads { incr pc if {[info exists block($pc)]} { $block($pc) build-in $b set curr_block $block($pc) @@ -341,12 +342,16 @@ } "confluence" - "unset" { # Do nothing; required for SSA computations only } "@debug-line" { - lassign $l opcode - src - set currentline [lindex $src 1] + lassign $l opcode - srcfrom + set currentline [lindex $srcfrom 1] + } + "@debug-script" { + lassign $l opcode - srcscript + set currentscript [lindex $srcscript 1] } "@debug-value" { # Debugging directive mapping value in quadcode to Tcl # source variable; except we don't do that any more. # Instead, a general "assign to something that looks like @@ -434,23 +439,45 @@ } "returnOptions" - "result" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srctype [my ValueTypes [lindex $srcs 0]] - if {"CALLFRAME" in $srctype} { + if {"CALLFRAME" in $srctype || $srctype eq "NEXIST"} { set srcs [lrange $srcs 1 end] } append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] my StoreResult $tgt [$b $opcode {*}$srcs $name] + } + "nsupvar" - "upvar" - "variable" { + set srcs [lassign $l opcode tgt src] + set localvar [lindex $srcs 0] + if {[lindex $localvar 0] ne "literal"} { + error "local variable must be literal" + } + set name [my LocalVarName $tgt] + set var [dict get $thevarmap [lindex $localvar 1]] + set op [dict get { + nsupvar frame.bind.nsvar + upvar frame.bind.upvar + variable frame.bind.var + } $opcode] + append op ( [my ValueTypes {*}$srcs] ) + set srcs [lmap s $srcs {my LoadOrLiteral $s}] + set res [$b $op {*}$srcs $var $theframe $errorCode $name] + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode \ + [$b maybe [$b frame.value $res]] + } + my StoreResult $tgt $res } "bitor" - "bitxor" - "bitand" - "lshift" - "rshift" - "add" - "sub" - "mult" - "uminus" - "uplus" - "land" - "lor" - "isBoolean" - "eq" - "neq" - "lt" - "gt" - "le" - "ge" - "streq" - "bitnot" - "strcase" - "strclass" - "strcmp" - "strfind" - "strlen" - "strmap" - "strmatch" - "strrfind" - - "strtrim" - "resolveCmd" { + "strtrim" - "resolveCmd" - "directExists" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] my StoreResult $tgt [$b $opcode {*}$srcs $name] @@ -458,11 +485,15 @@ "originCmd" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] - my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name] + set res [$b $opcode {*}$srcs $errorCode $name] + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode [$b maybe $res] + } + my StoreResult $tgt $res } "list" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set types [split [my ValueTypes {*}$srcs] ,] @@ -471,27 +502,41 @@ } "strindex" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srcs [my ConvertIndices 0 strlen 1] - my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name] + set res [$b $opcode {*}$srcs $errorCode $name] + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode [$b maybe $res] + } + my StoreResult $tgt $res } "strrange" - "strreplace" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srcs [my ConvertIndices 0 strlen 1 2] - my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name] + set res [$b $opcode {*}$srcs $errorCode $name] + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode [$b maybe $res] + } + my StoreResult $tgt $res } + "directGet" - "directSet" - "directAppend" - "directLappend" - + "directUnset" - "regexp" - "listAppend" - "listConcat" - "listLength" - "listRange" - "listIn" - "listNotIn" - "dictIterStart" - "dictAppend" - "dictIncr" - "dictLappend" - "dictSize" - "div" - "expon" - "mod" - "not" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] - my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name] + set res [$b $opcode {*}$srcs $errorCode $name] + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode [$b maybe $res] + } + my StoreResult $tgt $res } "returnCode" { lassign $l opcode tgt set name [my LocalVarName $tgt] my StoreResult $tgt [$b packInt32 [$b load $errorCode] $name] @@ -512,42 +557,52 @@ if {[llength $srcs] == 1} { # Simple case set srcs [list $srcObj {*}$srcs] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] - my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name] + 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 $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] append opcode ( [my ValueTypes $srcObj] ) set srcObj [my LoadOrLiteral $srcObj] - my StoreResult $tgt [$b $opcode $srcObj $vector $errorCode $name] + set res [$b $opcode $srcObj $vector $errorCode $name] + my StoreResult $tgt $res $b clearVector $srcs $vector $vectortypes } + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode [$b maybe $res] + } } "dictSet" - "listSet" { set srcs [lassign $l opcode tgt srcObj srcValue] set name [my LocalVarName $tgt] if {[llength $srcs] == 1} { # Simple case set srcs [list $srcObj {*}$srcs $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] - my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name] + 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 $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set srcs [list $srcObj $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] - my StoreResult $tgt [$b $opcode {*}$srcs $vector $errorCode $name] + set res [$b $opcode {*}$srcs $vector $errorCode $name] + my StoreResult $tgt $res $b clearVector $srcs $vector $vectortypes } + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode [$b maybe $res] + } } "copy" { lassign $l opcode tgt src set value [my LoadOrLiteral $src] set type [my OperandType $tgt] @@ -602,12 +657,14 @@ } "exists" { lassign $l opcode tgt src set type [my OperandType $src] if {$type eq "NEXIST"} { + my Warn "in exists with NEXIST type" set value [Const false bool] } elseif {!failType($type)} { + my Warn "in exists with definitely existing type" set value [Const true bool] } else { set value [$b exists [my LoadOrLiteral $src]] } my StoreResult $tgt $value @@ -618,10 +675,11 @@ if {failType(operandType($src))} { set test [my Unlikely maybe [my LoadOrLiteral $src]] $b condBr $test $block($tgt) $ipath($pc) } else { # Non-FAIL types never take the branch + my Warn "in jumpMaybe with non-fail type" $b br $ipath($pc) } } "jumpMaybeNot" { lassign $l opcode tgt src @@ -629,10 +687,11 @@ if {failType(operandType($src))} { set test [my Unlikely maybe [my LoadOrLiteral $src]] $b condBr $test $ipath($pc) $block($tgt) } else { # Non-FAIL types always take the branch + my Warn "in jumpMaybeNot with non-fail type" $b br $block($tgt) } } "jumpTrue" { lassign $l opcode tgt src @@ -672,20 +731,22 @@ } $b ret $val } "returnException" { lassign $l opcode -> frame code + set code [my LoadOrLiteral $code] if {$theframe ne "" && ![IsNull $theframe]} { $b frame.release $theframe $syntheticargs } + set code [$b proc.return $code [namespace tail $cmd]] # A VOID, a FAIL, a NEXIST, are all things that are not # strings. + # TODO: Reconsider how to process return codes for these if {![mightbea $returnType $STRING]} { $b ret [Const true bool] } else { - set type [nameOfType $returnType] - $b ret [$b nothing $type] + $b ret [$b fail [nameOfType $returnType] $code] } } "phi" { set values {} set sources {} @@ -756,10 +817,13 @@ set srcs [lassign $l opcode tgt assign] set listtypes [lmap s $srcs {my ValueTypes $s}] set lists [$b buildVector $listtypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set result [$b foreachStart [lindex $assign 1] $lists $errorCode] + if {"FAIL" in [my ValueTypes $tgt]} { + my SetErrorLine $errorCode [$b maybe $result] + } my StoreResult $tgt $result } "unshareList" - "foreachIter" - "foreachAdvance" - "foreachMayStep" - "dictIterKey" - "dictIterValue" - "dictIterDone" - @@ -776,10 +840,11 @@ "initIfNotExists" { my IssueValueInit $l } "throwIfNotExists" { set test [my IssueThrowIfNEXIST $l] + my SetErrorLine $errorCode $test $b condBr $test $block($tgt) $ipath($pc) } "throwNotExists" { lassign $l opcode tgt varname set name [my LiteralValue $varname] @@ -786,10 +851,11 @@ set msg "can't read \"$name\": no such variable" set exn [list TCL LOOKUP VARNAME $name] set msg [Const $msg STRING] set exn [Const $exn STRING] $b initException $exn $msg $errorCode + my SetErrorLine $errorCode $b br $block([lindex $tgt 1]) } "instanceOf" - "narrowToType" { lassign $l opcode tgt src lassign $opcode opcode - type @@ -830,10 +896,11 @@ append opcode . $type ( [my OperandType $src] ) set msg [Const $msg STRING] set exn [Const $exn STRING] set jmp [my Unlikely $opcode [my LoadOrLiteral $src] \ $msg $exn $errorCode "parse.failed"] + my SetErrorLine $errorCode $jmp $b condBr $jmp $block($tgt) $ipath($pc) } } "throwArithDomainError" { lassign $l opcode tgt src opname @@ -842,10 +909,11 @@ [my LiteralValue $opname]] set exn "ARITH DOMAIN {non-numeric string}" set msg [Const $msg STRING] set exn [Const $exn STRING] $b initException $exn $msg $errorCode + my SetErrorLine $errorCode $b br $block([lindex $tgt 1]) } "checkFunctionParam" - "narrowToParamType" - "narrowToNotParamType" { @@ -1145,20 +1213,26 @@ 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] - - # FIXME: Assumes that called commands produce either TCL_OK or - # TCL_ERROR. That Ain't Necessarily So... - set ts [lmap t $BASETYPES {Type $t?}] - if {[TypeOf $result] in $ts} { - set ec [$b cast(uint) [$b maybe $result]] - $b store $ec $errorCode - } elseif {[Type [TypeOf $result]?] eq [Type [my ValueTypes $tgt]]} { - # Managed to prove non-failure in this case... - set result [$b just $result] + if {[my ValueTypes $tgt] eq "FAIL"} { + # FIXME: Assumes that called commands produce either TCL_OK or + # TCL_ERROR. That Ain't Necessarily So... + $b store [Const 1] $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] } @@ -1176,10 +1250,13 @@ # reference (if provided). set result [$b invoke $vector $errorCode $vname] # Result type is now FAIL STRING, always. + 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 $b clearVector $arguments $vector $types @@ -1205,11 +1282,15 @@ if {$tgttype eq ""} { set tgttype [my OperandType $tgt] } if {$srctype in {"VOID" "NOTHING" "NEXIST"}} { switch -glob -- $tgttype { - "FAIL *" - "NEXIST *" { + "FAIL *" { + set t [lrange $tgttype 1 end] + set value [$b fail $t "" $name] + } + "NEXIST *" { set t [lrange $tgttype 1 end] set value [$b nothing $t $name] } "STRING" - "EMPTY" { set value [my LoadOrLiteral "literal {}"] @@ -1254,15 +1335,15 @@ if {"FAIL" in $srctype && "FAIL" in $tgttype} { set value [$b unmaybe $value] set srctype [lrange $srctype 1 end] set tgttype [lrange $tgttype 1 end] set value [my WidenedComplexValue $value $srctype $tgttype] - return [$b just $value $name] + return [$b ok $value $name] } elseif {"FAIL" in $tgttype} { set tgttype [lrange $tgttype 1 end] set value [my WidenedComplexValue $value $srctype $tgttype] - return [$b just $value $name] + return [$b ok $value $name] } # Handle NEXIST-extended types if {"NEXIST" in $srctype && "NEXIST" in $tgttype} { set value [$b unmaybe $value] @@ -1325,10 +1406,12 @@ set value [Const "" STRING] } elseif {$srctype ne $tgttype} { my Warn "unimplemented convert from '$srctype' to '$tgttype'" } if {[Type $tgttype] eq [Type [TypeOf $value]?]} { + set value [$b ok $value] + } elseif {[Type $tgttype] eq [Type [TypeOf $value]!]} { set value [$b just $value] } return $value } @@ -1533,11 +1616,12 @@ && literal([lindex $srcs 1]) && literal([lindex $srcs 2]) && [lindex $srcs 1 1] == 1 && [lindex $srcs 2 1] == 0} { # Really a throw set exn [Const [dict get $s2lit -errorcode] STRING] $b initException $exn $value $errorCode - my StoreResult $tgt [$b nothing $maintype] + my SetErrorLine $errorCode + my StoreResult $tgt [$b fail $maintype [$b load $errorCode]] return } if {$dlen == 0} { # Blank options; substitute a NULL set vals [linsert [lmap s [lrange $srcs 1 end] { @@ -1553,10 +1637,53 @@ if {![info exist vals]} { set vals [lmap s $srcs {my LoadOrLiteral $s}] } my StoreResult $tgt [$b $opcode {*}$vals $value $maintype \ $errorCode $name] + if {[llength $vals] == 1} { + $b logCommandInfo [$b load $errorCode] $currentscript + } else { + my SetErrorLine $errorCode + } + return + } + + # TclCompiler:SetErrorLine -- + # + # Generate code to set the errorLine and errorInfo for an exception. The + # error information is only set if the errorCode is TCL_ERROR and the + # test passes. + # + # Expects to only ever be called in a context where it is possible to + # determine what the current source line and command script text are. + # + # Parameters: + # errorCode - + # The LLVM int32* (i.e., pointer to variable) that the error + # code will be loaded from. + # test (optional) - + # The LLVM bool that will govern whether to issue the exception + # processing. If omitted, will be taken as being the true + # constant. + # + # Results: + # none + + method SetErrorLine {errorCode {test ""}} { + if {$test eq ""} { + set test [Const true bool] + } + set line $currentline + if {[dict exists $bytecode initiallinenumber]} { + set line [expr { + $line - [dict get $bytecode initiallinenumber] + }] + } + # The line number for the errorLine field needs to begin at 1 + incr line + $b setErrorLine $test [$b load $errorCode] [Const $line int] \ + $currentscript return } # TclCompiler:Unlikely -- # Index: codegen/mathlib.tcl ================================================================== --- codegen/mathlib.tcl +++ codegen/mathlib.tcl @@ -723,11 +723,11 @@ set y [my getInt64 $y_struct "y.64"] set z [my Call tcl.div.64 $x $y] my ret [my cast(INT?) $z] label error: my MathException $ecvar ARITH DIVZERO "divide by zero" - my ret [my nothing INT] + my ret [my fail INT] } ##### Function tcl.div.double ##### # # Type signature: x:DOUBLE * y:DOUBLE * ecvar:int* -> DOUBLE? @@ -744,15 +744,15 @@ my condBr [my and \ [my eq(DOUBLE,DOUBLE) $x $zero] \ [my eq(DOUBLE,DOUBLE) $y $zero]] \ $error $normal label normal: - my ret [my just [my div $x $y]] + my ret [my ok [my div $x $y]] label error: my MathException $ecvar ARITH DOMAIN \ "domain error: argument not in valid range" - my ret [my nothing DOUBLE] + my ret [my fail DOUBLE] } ##### Function tcl.mod ##### # # Type signature: x:INT * y:INT * ecvar:int* -> INT? @@ -781,11 +781,11 @@ set y [my getInt64 $y_struct "y.64"] set z [my sub $x [my mult $y [my Call tcl.div.64 $x $y]]] my ret [my cast(INT?) $z] label error: my MathException $ecvar ARITH DIVZERO "divide by zero" - my ret [my nothing INT] + my ret [my fail INT] } ##### Function tcl.div.numeric ##### # # Type signature: left:NUMERIC * right:NUMERIC * ecvar:int* @@ -838,19 +838,19 @@ my condBr [my and \ [my eq(DOUBLE,INT) $x [my int 0]] \ [my lt(DOUBLE,INT) $y [my int 0]]] \ $fail0toNeg $ordinary label ordinary: - my ret [my just [my Call $pow $x $y]] + my ret [my ok [my Call $pow $x $y]] label failRange "fail.negativeToFraction" my MathException $ecvar ARITH DOMAIN \ "domain error: argument not in valid range" - my ret [my nothing DOUBLE] + my ret [my fail DOUBLE] label fail0toNeg "fail.zeroToNegative" my MathException $ecvar ARITH DOMAIN \ "exponentiation of zero by negative power" - my ret [my nothing DOUBLE] + my ret [my fail DOUBLE] } ##### Function tcl.powi ##### # # Type signature: x:DOUBLE * y:INT * ecvar:int* -> DOUBLE? @@ -877,18 +877,18 @@ my condBr [my expect [my in32range $y] true] $false32 $outofrange label false32: set y2 [my cast(int) $y] my br $dopow label outofrange "out.of.range" - my ret [my just [my Call $pow $x [my castInt2Dbl $y]]] + my ret [my ok [my Call $pow $x [my castInt2Dbl $y]]] label dopow "apply.powi" set y [my phi [list $y1 $y2] [list $real32 $false32]] - my ret [my just [my Call $powi $x $y]] + my ret [my ok [my Call $powi $x $y]] label fail0toNeg "fail.zeroToNegative" my MathException $ecvar ARITH DOMAIN \ "exponentiation of zero by negative power" - my ret [my nothing DOUBLE] + my ret [my fail DOUBLE] } ##### Function tcl.ipow.bypow2 ##### # # Type signature: x:INT * y:INT -> INT @@ -1083,15 +1083,15 @@ set r64 [my Call tcl.ipow64 $x $y] my br $ok label ok: set sources [list $pow0 $pow1 $32 $64] set result [my phi [list $r0 $x $r32 $r64] $sources "result"] - my ret [my just $result] + my ret [my ok $result] label fail0toNeg "fail.zeroToNegative" my MathException $ecvar ARITH DOMAIN \ "exponentiation of zero by negative power" - my ret [my nothing INT] + my ret [my fail INT] } ##### Function tcl.pow.numeric ##### # # Type signature: x:NUMERIC * y:NUMERIC * ecvar:int* -> NUMERIC? Index: codegen/stdlib.tcl ================================================================== --- codegen/stdlib.tcl +++ codegen/stdlib.tcl @@ -7,11 +7,11 @@ # inject extra basic blocks without disturbing the analysis from the # reasoning engine. # # See build.tcl for where these functions are called from. # -# Copyright (c) 2015-2016 by Donal K. Fellows +# Copyright (c) 2015-2017 by Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ @@ -18,11 +18,12 @@ oo::define Builder { # Variables holding implementations of Tcl's string operators variable tcl.stringify.double tcl.stringify.int tcl.stringify.numeric variable tcl.addReference tcl.dropReference - variable tcl.addMaybeReference tcl.dropMaybeReference + variable tcl.addFailReference tcl.dropFailReference + variable tcl.addNExistReference tcl.dropNExistReference variable tcl.unshare tcl.unshare.copy variable tcl.strlen tcl.append.string tcl.streq tcl.strcmp tcl.strmatch variable tcl.stridx tcl.stridx.idx variable tcl.strrange tcl.strrange.idx tcl.strreplace tcl.strreplace.idx variable tcl.strfind.fwd tcl.strfind.rev @@ -41,28 +42,24 @@ # Variables holding implementations of Tcl's dict operators variable tcl.dict.get1 tcl.dict.get tcl.dict.set1 tcl.dict.set variable tcl.dict.exists1 tcl.dict.exists tcl.dict.unset1 tcl.dict.unset variable tcl.dict.iterStart tcl.dict.iterNext tcl.dict.iterDone variable tcl.dict.iterKey tcl.dict.iterValue tcl.dict.addIterReference + variable tcl.dict.addIterFailReference variable tcl.dict.dropIterReference tcl.dict.dropIterFailReference variable tcl.dict.append tcl.dict.lappend tcl.dict.incr tcl.dict.size variable tcl.maptoint # Variables holding implementations of Tcl's exception-handling machinery variable tcl.getresult tcl.getreturnopts tcl.initExceptionOptions - variable tcl.initExceptionSimple tcl.processReturn - variable tcl.existsOrError tcl.invoke.command - - # Variables holding implementations of Tcl's callframe handling - variable tcl.callframe.init tcl.callframe.makevar tcl.callframe.clear - variable tcl.callframe.store tcl.callframe.load + variable tcl.initExceptionSimple tcl.processReturn tcl.procedure.return + variable tcl.setErrorLine tcl.existsOrError tcl.invoke.command + variable tcl.logCommandInfo # Helper functions - variable tcl.impl.trimleft tcl.impl.trimright + variable tcl.impl.trimleft tcl.impl.trimright obj.cleanup variable tcl.impl.getIndex tcl.impl.listDupe - variable var.hash.getValue - variable tcl.read.var.ptr tcl.write.var.ptr tcl.unset.var.ptr # Reference to the module object variable m # Builder:ReferenceFunctions -- @@ -165,18 +162,56 @@ nonnull $value $api Tcl_DecrRefCount $value my ret } - ##### tcl.addMaybeReference ##### + ##### tcl.addFailReference ##### + # + # Type signature: objPtr:Tcl_Obj*? -> void + # + # Increment the reference count of a Tcl_Obj reference if the + # object is supplied + + set f [$m local "tcl.addFailReference" void<-Tcl_Obj*?] + params value:maybeObjPtr + build { + my condBr [my maybe $value] $nothing $incr + label incr "action.required" + set value [my unmaybe $value "objPtr"] + $api Tcl_IncrRefCount $value + my ret + label nothing "nothing.to.do" + my ret + } + + ##### tcl.dropFailReference ##### # # Type signature: objPtr:Tcl_Obj*? -> void + # + # Decrement the reference count of a Maybe containing a Tcl_Obj + # reference, and delete it if the reference count drops to zero. + + set f [$m local "tcl.dropFailReference" void<-Tcl_Obj*?] + params value:maybeObjPtr + build { + my condBr [my maybe $value] $nothing $decr + label decr "action.required" + set value [my unmaybe $value "objPtr"] + $api Tcl_DecrRefCount $value + my ret + label nothing "nothing.to.do" + my ret + } + + ##### tcl.addNExistReference ##### + # + # Type signature: objPtr:Tcl_Obj*! -> void # # Increment the reference count of a Tcl_Obj reference if the # object is supplied - set f [$m local "tcl.addMaybeReference" void<-Tcl_Obj*?] + set f [$m local "tcl.addNExistReference" void<-Tcl_Obj*!] params value:maybeObjPtr build { my condBr [my maybe $value] $nothing $incr label incr "action.required" set value [my unmaybe $value "objPtr"] @@ -184,18 +219,18 @@ my ret label nothing "nothing.to.do" my ret } - ##### tcl.dropMaybeReference ##### + ##### tcl.dropNExistReference ##### # - # Type signature: objPtr:Tcl_Obj*? -> void + # Type signature: objPtr:Tcl_Obj*! -> void # # Decrement the reference count of a Maybe containing a Tcl_Obj # reference, and delete it if the reference count drops to zero. - set f [$m local "tcl.dropMaybeReference" void<-Tcl_Obj*?] + set f [$m local "tcl.dropNExistReference" void<-Tcl_Obj*!] params value:maybeObjPtr build { my condBr [my maybe $value] $nothing $decr label decr "action.required" set value [my unmaybe $value "objPtr"] @@ -415,10 +450,12 @@ my call $memcmp [list $bytes1 $bytes2 $length] $name } my StringInspectionFunctions $api my StringWritingFunctions $api + my ListFunctions $api + my DictionaryFunctions $api my StringComparisonFunctions $api return } @@ -529,25 +566,25 @@ unset -nocomplain valueObj ##### Function tcl.impl.getWide ##### ##### MAPPED CALL TO METHOD: Build:GetWide ##### # - # Type signature: valueObj:STRING -> int * int64 + # Type signature: valueObj:STRING -> bool * int64 # # Gets an int64 from a Tcl string. Wrapper around Tcl API to ensure # that scope lifetime gets better understood. set f [$m local "tcl.impl.getWide" struct{int1,int64}<-STRING] - my closure GetWide {valueObj} { - my call ${tcl.impl.getWide} [list $valueObj] "result" + my closure GetWide {valueObj {name "result"}} { + my call ${tcl.impl.getWide} [list $valueObj] $name } params valueObj build { nonnull $valueObj set intVar [my alloc int64 "intPtr"] set code [$api Tcl_GetWideIntFromObj {} $valueObj $intVar] - set res [my undef struct{int1,int64}] + set res [my undef struct{bool,int64}] set res [my insert $res [my eq $code [Const 0]] 0] set res [my insert $res [my load $intVar "int"] 1 "result"] my ret $res } unset -nocomplain valueObj @@ -1276,14 +1313,14 @@ label done: set result [my phi \ [list $emptyResult $byteResult $asciiResult $unicodeResult] \ [list $empty $baIdx $byteIndex $strIdx] "result"] my addReference(STRING) $result - my ret [my just $result] + my ret [my ok $result] label failed: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.strrange ##### # # Type signature: objPtr:STRING * fromInt:INT * toInt:INT -> STRING @@ -1352,14 +1389,14 @@ my br $finish label finish: set result [my phi [list $value1 $value2] \ [list $empty $realSubstring] "result"] my addReference(STRING) $result - my ret [my just $result] + my ret [my ok $result] label failed: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.strreplace ##### # # Type signature: objPtr:STRING * fromInt:INT * toInt:INT @@ -1506,14 +1543,14 @@ $rangeCheck $failed label rangeCheck: set from [my packInt32 $from] set to [my packInt32 $to] set replaced [my Call tcl.strreplace $str $from $to $substr] - my ret [my just $replaced] + my ret [my ok $replaced] label failed: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.strmap ##### # # Type signature: sourceObj:STRING * targetObj:STIRNG * @@ -1708,10 +1745,68 @@ my br $done label done: my addReference(STRING) $string my ret $string } + + ##### Function tcl.maptoint ##### + # + # Type signature: value:STRING * mapping:STRING * notThere:int -> INT + # + # Quadcode implementation ('maptoint') + # + # Returns the INT looked up in 'mapping' that corresponds to 'value'. + # If the value is absent, returns the 'notThere' value. + + set f [$m local "tcl.maptoint" INT<-STRING,HashTable*,int] + params value mapping notThere + build { + nonnull $value $mapping + set offset [$api TclFindHashEntry $mapping $value] + SetValueName $offset "offsetPtr" + my condBr [my nonnull $offset] $present $absent + label present: + set offset [$api Tcl_GetHashValue $offset int] + SetValueName $offset "offset" + my ret [my packInt32 $offset] + label absent: + my ret [my packInt32 $notThere] + } + + ##### Function tcl.concatenate ##### + # + # Type signature: len:int * ary:STRING* -> STRING + # + # Quadcode implementation ('concat') + # + # Returns the application of Tcl_ConcatObj() to the given values, so + # much so that it is just a very thin wrapper around that function. + + set f [$m local "tcl.concatenate" STRING<-int,STRING*] + params len ary + build { + nonnull $ary + set result [$api Tcl_ConcatObj $len $ary] + my addReference(STRING) $result + my ret $result + } + } + + # Builder:ListFunctions -- + # + # Generate the functions that implement the list-handling operators. + # Only called from StringFunctions method. + # + # Parameters: + # api - The handle of the Tcl API object (currently an instance of the + # Thunk class). + # + # Results: + # None. + + method ListFunctions {api} { + upvar 1 0 0 1 1 -1 -1 ##### Function tcl.impl.listDupe ##### ##### Closure Build:ListDupe ##### # # Type signature: interp:Interp* * obj:STRING -> STRING @@ -1787,11 +1882,11 @@ my condBr [my eq $code $0] $ok $fail label ok: my ret [my cast(INT?) [my load $var]] label fail: my store $1 $ecvar - my ret [my nothing INT] + my ret [my fail INT] } ##### Function tcl.list.append ##### # # Type signature: list:STRING * value:STRING * ecvar:int* -> STRING? @@ -1824,14 +1919,14 @@ my condBr [my shared $value] $exit $extraRef label extraRef "add.extra.reference.to.value" my addReference(STRING) $value my br $exit label exit: - my ret [my just $list] + my ret [my ok $list] label error: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.list.concat ##### # # Type signature: list:STRING * value:STRING * ecvar:int* -> STRING? @@ -1864,14 +1959,14 @@ set working [my phi [list $list $copy] [list $checkDupe $dupe] "list"] set objc [my load $objc "objc"] set objv [my load $objv "objv"] $api Tcl_ListObjReplace {} $working $len $0 $objc $objv my addReference(STRING) $working - my ret [my just $working] + my ret [my ok $working] label error: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.list.index ##### # # Type signature: list:STRING * idxc:int * idxv:STRING* * ecvar:int* @@ -1930,11 +2025,11 @@ my store [set list [$api Tcl_NewObj]] $listPtr my addReference(STRING) $list my br $loopNext label loopIndexValidityCheck: my condBr [my GetIndex $interp \ - [my load [my getelementptr $idxv [list $i]]] [Const -1]] \ + [my load [my getelementptr $idxv [list $i]]] ${-1}] \ $loopIndexOutOfRange $loopIndexBad label loopIndexBad: my dropReference $sublistCopy my br $error label loopNext: @@ -1941,14 +2036,14 @@ my dropReference $sublistCopy my store [my add [my load $iPtr "i"] $1] $iPtr my br $loopTest label done: set list [my load $listPtr "list"] - my ret [my just $list] + my ret [my ok $list] label error: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.list.index1 ##### # # Type signature: list:STRING * index:INT * ecvar:int* -> STRING? @@ -1974,18 +2069,18 @@ $realIndex $outOfBounds label realIndex "real.index" set objv [my load $objv "objv"] set obj [my load [my getelementptr $objv [list $idx]] "objPtr"] my addReference(STRING) $obj - my ret [my just $obj] + my ret [my ok $obj] label outOfBounds "out.of.bounds" set obj [$api Tcl_NewObj] my addReference(STRING) $obj - my ret [my just $obj] + my ret [my ok $obj] label fail: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.list.indexList ##### # # Type signature: list:STRING * index:STRING * ecvar:int* -> STRING? @@ -2005,11 +2100,11 @@ set code [$api Tcl_ListObjGetElements $interp $list $objc $objv] my condBr [my eq $code $0] $checkType $notList label notList: # We're not a list and we know it right now my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] label checkType: my condBr [my neq [my dereference $index 0 Tcl_Obj.typePtr] \ [$api tclListType]] \ $checkIndex $slowPath label checkIndex: @@ -2021,15 +2116,15 @@ $realIndex $outOfBounds label realIndex "real.index" set objv [my load $objv "objv"] set obj [my load [my getelementptr $objv [list $idx]] "objPtr"] my addReference(STRING) $obj - my ret [my just $obj] + my ret [my ok $obj] label outOfBounds "out.of.bounds" set obj [$api Tcl_NewObj] my addReference(STRING) $obj - my ret [my just $obj] + my ret [my ok $obj] label slowPath: set dupe [my ListDupe $interp $index "copy"] my condBr [my nonnull $dupe] $okIndex $notList label okIndex: set listRep [my load [my cast(ptr) \ @@ -2126,14 +2221,14 @@ my br $ok label ok: set sources [list $sublistInplaceDone $sublistNew $empty] set result [my phi [list $list $r1 $r2] $sources "result"] my addReference(STRING) $result - my ret [my just $result] + my ret [my ok $result] label error: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.list.range1 ##### # # Type signature: list:STRING * from:INT * to:INT -> STRING? @@ -2214,14 +2309,14 @@ my br $ok label ok: set sources [list $sublistInplaceDone $sublistNew $empty] set result [my phi [list $list $r1 $r2] $sources "result"] my addReference(STRING) $result - my ret [my just $result] + my ret [my ok $result] label error: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.list.set ##### # # Type signature: list:STRING * idxc:int * idxv:STRING* * elem:STRING @@ -2238,11 +2333,11 @@ nonnull $list $idxv $elem $ecvar set interp [$api tclInterp] my condBr [my eq $idxc $0] $doNothing $sharedCheck label doNothing: my addReference(STRING) $list - my ret [my just $list] + my ret [my ok $list] label sharedCheck: my condBr [my shared $list] $duplicate $prepareToLoop label duplicate: set dupe [$api Tcl_DuplicateObj $list] my br $prepareToLoop @@ -2333,11 +2428,11 @@ label loopFailDropOverall: my dropReference $retValue my br $loopFailExit label loopFailExit: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] label loopEnd: set sublist [my load $subList] set obj [my load $chain] my condBr [my nonnull $obj] $loopEndDrop $terminalSet label loopEndDrop: @@ -2362,11 +2457,11 @@ my condBr [my shared $elem] $exit2 $exit3 label exit3 "exit" my addReference(STRING) $elem my br $exit2 label exit2 "exit" - my ret [my just $retValue] + my ret [my ok $retValue] } ##### Function tcl.list.set1 ##### # # Type signature: list:STRING * index:INT * elem:STRING * ecvar:int* @@ -2409,21 +2504,21 @@ my condBr [my shared $elem] $exit2 $exit3 label exit3 "exit" my addReference(STRING) $elem my br $exit2 label exit2 "exit" - my ret [my just $list] + my ret [my ok $list] label outRange "failure.outOfRange" $api Tcl_SetObjResult $interp \ [$api obj.constant "list index out of range"] $api Tcl_SetObjErrorCode $interp \ [$api obj.constant {TCL OPERATION LSET BADINDEX}] my br $out label out "failure.exit" my Call obj.cleanup $duped my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.list.setList ##### # # Type signature: list:STRING * idxArg:STRING * elem:STRING @@ -2496,15 +2591,15 @@ label loopNext: ReplaceAllUsesWith $iLoop [set i [my add $i $1 "i"]] my condBr [my lt $i $objc] $loop $done label fail: my store $1 $ecVar - my ret [my nothing ZEROONE] + my ret [my fail ZEROONE] label done: set flag [my phi [list [Const false bool] [Const false bool] [Const true bool]] \ [list $realCheck $loopNext $loopCompare] "flag"] - my ret [my just $flag] + my ret [my ok $flag] } ##### Function tcl.list.unshare ##### # # Type signature: list:STRING -> STRING @@ -2565,14 +2660,14 @@ my br $loopStart label ok: set pair [my undef FOREACH] set pair [my insert $pair $0 FOREACH.val] set pair [my insert $pair $max FOREACH.max] - my ret [my just $pair] + my ret [my ok $pair] label fail: my store $1 $ecVar - my ret [my nothing FOREACH] + my ret [my fail FOREACH] } ##### Function tcl.list.foreach.getStep ##### # # Type signature: pair:FOREACH -> INT @@ -2621,10 +2716,26 @@ params pair build { set val [my extract $pair FOREACH.val] my ret [my insert $pair [my add $val $1] FOREACH.val] } + } + + # Builder:DictionaryFunctions -- + # + # Generate the functions that implement the dict-handling operators. + # Only called from StringFunctions method. + # + # Parameters: + # api - The handle of the Tcl API object (currently an instance of the + # Thunk class). + # + # Results: + # None. + + method DictionaryFunctions {api} { + upvar 1 0 0 1 1 ##### Function tcl.dict.exists1 ##### # # Type signature: dict:STRING * key:STRING -> ZEROONE # @@ -2695,11 +2806,11 @@ my condBr [my eq $code $0] $ok $fail label ok: my ret [my cast(INT?) [my load $size]] label fail: my store $1 $ecvar - my ret [my nothing INT] + my ret [my fail INT] } ##### Function tcl.dict.get1 ##### # # Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING? @@ -2719,11 +2830,11 @@ label OK: set value [my load $resvar "value"] my condBr [my nonnull $value] $return $fail label return: my addReference(STRING) $value - my ret [my just $value] + my ret [my ok $value] label fail: set keyval [$api Tcl_GetString $key] $api Tcl_SetObjResult $interp \ [$api Tcl_ObjPrintf [my constString \ "key \"%s\" not known in dictionary"] \ @@ -2732,11 +2843,11 @@ [my constString TCL] [my constString LOOKUP] \ [my constString DICT] $keyval [my null char*] my br $notOK label notOK: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.dict.get ##### # # Type signature: dict:STRING * pathlen:int * pathobjs:STRING* @@ -2770,11 +2881,11 @@ set value [my load $resvar "value"] my condBr [my nonnull $value] $return $fail label return: set value [my phi [list $dict $value] [list $verify $OK] "value"] my addReference(STRING) $value - my ret [my just $value] + my ret [my ok $value] label fail: set keyval [$api Tcl_GetString $key] $api Tcl_SetObjResult $interp \ [$api Tcl_ObjPrintf [my constString \ "key \"%s\" not known in dictionary"] \ @@ -2783,11 +2894,11 @@ [my constString TCL] [my constString LOOKUP] \ [my constString DICT] $keyval [my null char*] my br $notOK label notOK: my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.dict.set1 ##### # # Type signature: dict:STRING * key:STRING * value:STRING @@ -2810,15 +2921,15 @@ my condBr [my shared $value] $exit2 $exit3 label exit3 "exit" my addReference(STRING) $value my br $exit2 label exit2 "exit" - my ret [my just $dict] + my ret [my ok $dict] label notOK: my Call obj.cleanup $dd my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.dict.set ##### # # Type signature: dict:STRING * pathlen:int * pathobjs:STRING* @@ -2841,15 +2952,15 @@ my condBr [my shared $value] $exit2 $exit3 label exit3 "exit" my addReference(STRING) $value my br $exit2 label exit2 "exit" - my ret [my just $dict] + my ret [my ok $dict] label notOK: my Call obj.cleanup $dd my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.dict.unset1 ##### # # Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING? @@ -2866,15 +2977,15 @@ set dd [my Dedup dict] set result [$api Tcl_DictObjRemove $interp $dict $key] my condBr [my eq $result $0] $OK $notOK label OK: my addReference(STRING) $dict - my ret [my just $dict] + my ret [my ok $dict] label notOK: my Call obj.cleanup $dd my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.dict.unset ##### # # Type signature: dict:STRING * pathlen:int * pathobjs:STRING* @@ -2891,15 +3002,15 @@ set interp [$api tclInterp] set dd [my Dedup dict] set result [$api Tcl_DictObjRemoveKeyList $interp $dict $pathlen $pathobjs] my condBr [my eq $result $0] $OK $notOK label OK: - my ret [my just $dict] + my ret [my ok $dict] label notOK: my Call obj.cleanup $dd my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.dict.addIterReference ##### # # Type signature: iter:DICTITER -> void @@ -2913,10 +3024,28 @@ set ref [my gep $iter 0 DICTFOR.ref] set rc [my load $ref] my store [my add $rc $1] $ref my ret } + + ##### Function tcl.dict.addIterFailReference ##### + # + # Type signature: value:DICTITER? -> void + # + # Increments the reference count inside a dictionary iteration + # state, allowing for failure + + set f [$m local "tcl.dict.addIterFailReference" void<-DICTITER?] + params value + build { + my condBr [my maybe $value] $nothing $release + label nothing: + my ret + label release: + my Call tcl.dict.addIterReference [my unmaybe $value] + my ret + } ##### Function tcl.dict.iterStart ##### # # Type signature: dict:STRING * ecvar:int* -> DICTITER? # @@ -2944,15 +3073,15 @@ my storeInStruct $iter DICTFOR.dict $dict my storeInStruct $iter DICTFOR.ref $0 my storeInStruct $iter DICTFOR.done [my neq [my load $done] $0] my addReference(STRING) $dict my Call tcl.dict.addIterReference $iter - my ret [my just $iter] + my ret [my ok $iter] label failed: $api ckfree $iter my store $1 $ecvar - my ret [my nothing DICTITER] + my ret [my fail DICTITER] } ##### Function tcl.dict.iterNext ##### # # Type signature: iter:DICTITER -> DICTITER @@ -3121,15 +3250,15 @@ set c [$api Tcl_DictObjPut {} $dict $key $dictVal2] AddCallAttribute $c 3 nocapture my br $done label done: my addReference(STRING) $dict - my ret [my just $dict] + my ret [my ok $dict] label notOK: my Call obj.cleanup $dd my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.dict.incr ##### # # Type signature: dict:STRING * key:STRING * value:INT @@ -3169,15 +3298,15 @@ set resultValue [my phi [list $strVal $addVal] \ [list $set $doAdd] "value"] # No failure mode at this point: we know we've got a dictionary. set c [$api Tcl_DictObjPut {} $dict $key $resultValue] my addReference(STRING) $dict - my ret [my just $dict] + my ret [my ok $dict] label notOK: my Call obj.cleanup $dd my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } ##### Function tcl.dict.lappend ##### # # Type signature: dict:STRING * key:STRING * value:STRING @@ -3221,60 +3350,18 @@ set c [$api Tcl_DictObjPut {} $dict $key $dictVal] AddCallAttribute $c 3 nocapture my br $done label done: my addReference(STRING) $dict - my ret [my just $dict] + my ret [my ok $dict] label dupeNotOK: my dropReference $dictVal my br $notOK label notOK: my Call obj.cleanup $dd my store $1 $ecvar - my ret [my nothing STRING] - } - - ##### Function tcl.maptoint ##### - # - # Type signature: value:STRING * mapping:STRING * notThere:int -> INT - # - # Quadcode implementation ('maptoint') - # - # Returns the INT looked up in 'mapping' that corresponds to 'value'. - # If the value is absent, returns the 'notThere' value. - - set f [$m local "tcl.maptoint" INT<-STRING,HashTable*,int] - params value mapping notThere - build { - nonnull $value $mapping - set offset [$api TclFindHashEntry $mapping $value] - SetValueName $offset "offsetPtr" - my condBr [my nonnull $offset] $present $absent - label present: - set offset [$api Tcl_GetHashValue $offset int] - SetValueName $offset "offset" - my ret [my packInt32 $offset] - label absent: - my ret [my packInt32 $notThere] - } - - ##### Function tcl.concatenate ##### - # - # Type signature: len:int * ary:STRING* -> STRING - # - # Quadcode implementation ('concat') - # - # Returns the application of Tcl_ConcatObj() to the given values, so - # much so that it is just a very thin wrapper around that function. - - set f [$m local "tcl.concatenate" STRING<-int,STRING*] - params len ary - build { - nonnull $ary - set result [$api Tcl_ConcatObj $len $ary] - my addReference(STRING) $result - my ret $result + my ret [my fail STRING] } } # Builder:StringComparisonFunctions -- # @@ -3454,113 +3541,16 @@ label exec "re.exec" set match [$api Tcl_RegExpExecObj $interp $RE $stringObj $0 $0 $0] my condBr [my ge $match $0] $done $err label done "re.done" my store $0 $errVar - my ret [my just [my gt $match $0]] + my ret [my ok [my gt $match $0]] label err "re.error" my store $1 $errVar - my ret [my nothing ZEROONE] - } - - } - - # Builder:CallFrameFunctions -- - # - # Generate the functions that implement the callframe handling. - # - # Parameters: - # api - The handle of the Tcl API object (currently an instance of the - # Thunk class). - # - # Results: - # None. - - method CallFrameFunctions {api} { - set 0 [Const 0] - set 1 [Const 1] - - set f [$m local "tcl.callframe.init" \ - void<-CALLFRAME,int,int,STRING*,Proc*,LocalCache*,Var*] - params frame length objc objv proc localCache locals - build { - set interp [$api tclInterp] - set rcPtr [my gep $proc 0 Proc.refCount] - my store [my add [my load $rcPtr] $1] $rcPtr - set nsPtr [my dereference [my dereference $proc 0 Proc.cmdPtr] \ - 0 Command.nsPtr] - $api Tcl_PushCallFrame $interp $frame $nsPtr $1 - set varTable [my null VarHashTable*] - set cllen1 [my mult $length [my cast(int) [my sizeof Var]]] - my storeInStruct $frame CallFrame.objc $objc - my storeInStruct $frame CallFrame.objv $objv - my storeInStruct $frame CallFrame.procPtr $proc - my storeInStruct $frame CallFrame.varTablePtr $varTable - my storeInStruct $frame CallFrame.numCompiledLocals $length - my storeInStruct $frame CallFrame.compiledLocals $locals - my storeInStruct $frame CallFrame.localCachePtr $localCache - set rcPtr [my gep $localCache 0 LocalCache.refCount] - my store [my add [my load $rcPtr] $1] $rcPtr - - my bzero $locals $cllen1 - my ret - } - - set f [$m local "tcl.callframe.makevar" Var*<-CALLFRAME,int,int] - params frame index flags - build { - set lvt [my dereference $frame 0 CallFrame.compiledLocals] - set local [my getelementptr $lvt $index] - my storeInStruct $local Var.flags $flags - my storeInStruct $local Var.value [my null Tcl_Obj*] - my ret $local - } - - set f [$m local "tcl.callframe.clear" void<-CALLFRAME] - params frame - build { - set interp [$api tclInterp] - $api Tcl_PopCallFrame $interp - set proc [my dereference $frame 0 CallFrame.procPtr] - set rcPtr [my gep $proc 0 Proc.refCount] - my store [my sub [my load $rcPtr] $1] $rcPtr - # TODO: ought to theoretically delete the Proc when it has a - # refcount of 0. - my ret - } - - set f [$m local "tcl.callframe.store" void<-Var*,STRING,STRING?] - params var varName value - build { - set interp [$api tclInterp] - set nv [my null Var*] - set ns [my null STRING] - my condBr [my maybe $value] $doUnset $doSet - label doSet: - set value [my unmaybe $value] - my Call tcl.write.var.ptr $interp $var $nv $varName $ns $value $0 - my ret - label doUnset: - my Call tcl.unset.var.ptr $interp $var $nv $varName $ns $0 - my ret - } - - set f [$m local "tcl.callframe.load" STRING?<-Var*,STRING] - params var varName - build { - set interp [$api tclInterp] - set nv [my null Var*] - set ns [my null STRING] - set value [my Call tcl.read.var.ptr $interp $var $nv $varName $ns $0] - my condBr [my nonnull $value] \ - $gotValue $noValue - label gotValue: - my addReference(STRING) $value - my ret [my just $value] - label noValue: - my ret [my nothing STRING] - } + my ret [my fail ZEROONE] + } + } # Builder:@apiFunctions -- # # Generate the quadcode operator implementations that require access to @@ -3572,10 +3562,44 @@ # # Results: # None. method @apiFunctions {module api} { + ##### Function tcl.print.string ##### + ##### Closure Build:printf ##### + ##### Closure Build:fprintf ##### + # + # Print a formatted string. + # + # Parameters: + # channel (fprintf only) - + # Either "stdout" or "stderr" to select which channel to + # print to. + # str - The Tcl string holding the format string. + # args - The arguments to use in the format. These must be all + # LLVM values of the correct type. + # Results: + # The reference count, as a LLVM value. + + set f [$module local tcl.print.string void<-int,Tcl_Obj*] + my closure printf {str args} { + my Call tcl.print.string [Const [expr 1<<2]] \ + [$api Tcl_ObjPrintf [my constString $str] {*}$args] + } + my closure fprintf {channel str args} { + set id [dict get {stdout 2 stderr 3} $channel] + my Call tcl.print.string [Const [expr {1<<$id}]] \ + [$api Tcl_ObjPrintf [my constString $str] {*}$args] + } + params chanID str + build { + set chan [$api Tcl_GetStdChannel $chanID] + $api Tcl_WriteObj $chan $str + $api Tcl_DecrRefCount $str + my ret + } + my StringifyFunctions $api my ReferenceFunctions $api my StringFunctions $api # Builder:MathException -- @@ -3845,10 +3869,126 @@ my store [my or [my load $field] [Const 0x800]] $field my br $done label done: my ret $code } + + ##### Function tcl.procedure.return ##### + # + # Type signature: code:INT * procName:STRING -> int32 + # + # Handles the transforms on a result when a procedure returns. See + # InterpProcNR2 in tclProc.c for what is going on; this is the part + # commencing at the 'process' label. + + set f [$m local "tcl.procedure.return" int32<-INT,STRING] + params code procName + build { + set interp [$api tclInterp] + set code [my getInt32 $code] + my condBr [my eq $code [Const 2]] $handleReturn $test2 + label test2: + my condBr [my eq $code [Const 3]] $handleBreak $test3 + label test3: + my condBr [my eq $code [Const 4]] $handleContinue $test4 + label test4: + my condBr [my eq $code [Const 1]] $handleError $done + label handleError "handle.error" + set limitVar [my alloc int] + set name [$api Tcl_GetStringFromObj $procName $limitVar] + SetValueName $name "name" + set limit [Const 60] + set nameLen [my load $limitVar "name.len"] + set overflow [my gt $nameLen $limit] + $api Tcl_AppendObjToErrorInfo $interp [$api Tcl_ObjPrintf \ + [my constString "\n (procedure \"%.*s%s\" line %d)"] \ + [my select $overflow $limit $nameLen] $name \ + [my select $overflow [my constString "..."] \ + [my constString ""]] \ + [my dereference $interp 0 Interp.errorLine]] + my br $done + label handleReturn "handle.return" + my ret [$api TclUpdateReturnInfo $interp] + label handleBreak "handle.leaked.break" + $api Tcl_SetObjResult $interp [$api Tcl_ObjPrintf \ + [my constString "invoked \"%s\" outside of a loop"] \ + [my constString "break"]] + $api Tcl_SetObjErrorCode $interp \ + [$api obj.constant {TCL RESULT UNEXPECTED}] + my ret [Const 1] + label handleContinue "handle.leaked.continue" + $api Tcl_SetObjResult $interp [$api Tcl_ObjPrintf \ + [my constString "invoked \"%s\" outside of a loop"] \ + [my constString "continue"]] + $api Tcl_SetObjErrorCode $interp \ + [$api obj.constant {TCL RESULT UNEXPECTED}] + my ret [Const 1] + label done: + my ret $code + } + + ##### Function tcl.logCommandInfo ##### + # + # Type signature: code:int * length:int * command:char* + # * ellipsis:char* -> void + # + # Builds the current entry in the errorInfo trace if the code is + # TCL_ERROR. Note that most of the arguments to this function are + # expected to be values that our caller will compute at compile time. + + set f [$m local "tcl.logCommandInfo" void<-int,int,char*,char*] + params code length command ellipsis + build { + nonnull $command $ellipsis + set ERR_ALREADY_LOGGED [Const 4] + + set interp [$api tclInterp] + set flagVar [my gep $interp 0 Interp.flags] + set flags [my load $flagVar "flags"] + my condBr [my eq $code [Const 1]] $checkForLog $done + label checkForLog "check.for.log.error" + my condBr [my eq [my and $flags $ERR_ALREADY_LOGGED] [Const 0]] \ + $logError $done + label logError "log.error" + set initText [my select [my nonnull \ + [my dereference $interp 0 Interp.errorInfo]] \ + [my constString "invoked from within"] \ + [my constString "while executing"]] + $api Tcl_AppendObjToErrorInfo $interp [ + $api Tcl_ObjPrintf [my constString "\n %s\n\"%.*s%s\""] \ + $initText $length $command $ellipsis] + # TODO: update the errorStack as well... + # $api Tcl_LogCommandInfo $interp {} {} [Const 0] + my br $done + label done: + my store [my and $flags [my not $ERR_ALREADY_LOGGED]] $flagVar + my ret + } + + ##### Function tcl.setErrorLine ##### + # + # Type signature: test:bool * code:int * line:int * length:int + # * command:char* * ellipsis:char* -> void + # + # Sets the current errorLine if the test is true and builds the + # current entry in the errorInfo trace if necessary. Note that most of + # the arguments to this function are expected to be values that our + # caller will compute at compile time. + + set f [$m local "tcl.setErrorLine" void<-bool,int,int,int,char*,char*] + params test code line length command ellipsis + build { + nonnull $command $ellipsis + my condBr $test $setLine $done + label setLine "set.error.line" + set interp [$api tclInterp] + my store $line [my gep $interp 0 Interp.errorLine] + my Call tcl.logCommandInfo $code $length $command $ellipsis + my br $done + label done: + my ret + } ##### Function tcl.booleanTest ##### # # Type signature: objPtr:Tcl_Obj* -> ZEROONE # @@ -3881,14 +4021,14 @@ set code [$api Tcl_EvalObjv $interp $objc $objv $0] my condBr [my eq $code $0] $ok $fail label ok: set result [$api Tcl_GetObjResult $interp] my addReference(STRING) $result - my ret [my just $result] + my ret [my ok $result] label fail: my store $code $ecvar - my ret [my nothing STRING] + my ret [my fail STRING $code] } ##### Function tcl.existsOrError ##### # # Type signature: exists:int1 * message:STRING * ecvar:int* -> int1 @@ -3926,14 +4066,14 @@ set interp [$api tclInterp] set bvar [my alloc int] set code [$api Tcl_GetBooleanFromObj $interp $value $bvar] my condBr [my eq $code [Const 0]] $ok $fail label fail: - my store $code $ecvar - my ret [my nothing ZEROONE] + my store [Const 1] $ecvar + my ret [my fail ZEROONE] label ok: - my ret [my just [my neq [my load $bvar "bool"] [Const 1]]] + my ret [my ok [my neq [my load $bvar "bool"] [Const 1]]] } my @variableFunctions $api my @numericConverterFunctions $api @@ -3990,11 +4130,11 @@ label done: set finalCmdPtr [my phi [list $origCmdPtr $cmdPtr] \ [list $aliased $notAliased]] $api Tcl_GetCommandFullName $interp $finalCmdPtr $result my addReference(STRING) $result - my ret [my just $result] + my ret [my ok $result] label notResolved: my dropReference(STRING) $result $api Tcl_SetObjResult $interp \ [$api Tcl_ObjPrintf \ [my constString "invalid command name \"%s\""] \ @@ -4002,1336 +4142,14 @@ $api Tcl_SetErrorCode $interp \ [my constString TCL] [my constString LOOKUP] \ [my constString COMMAND] [$api Tcl_GetString $cmdName] \ [my null char*] my store $1 $ecvar - my ret [my nothing STRING] + my ret [my fail STRING] } my CallFrameFunctions $api - } - - # Builder:@variableFunctions -- - # - # Generate the quadcode operator implementations that access Tcl - # variables. - # - # Parameters: - # api - The handle of the Tcl API object (currently an instance of the - # Thunk class). - # - # Results: - # None. - - method @variableFunctions {api} { - set 0 [Const 0] - set 1 [Const 1] - set ARRAY [Const 0x1] - set LINK [Const 0x2] - set ARRAY_OR_LINK [Const 0x3] - set NSGLBL [Const [expr {0x1 | 0x2}]] - set APPEND_VALUE [Const 0x04] - set IN_HASHTABLE [Const 0x04] - set LIST_ELEMENT [Const 0x08] - set DEAD_HASH [Const 0x8] - set TRACED_READS [Const 0x10] - set TRACED_WRITES [Const 0x20] - set TRACED_UNSETS [Const 0x40] - set NAMESPACE_VAR [Const 0x80] - set LEAVE_ERR_MSG [Const 0x200] - set TRACED_ARRAY [Const 0x800] - set TRACED_ALL [Const 0x870] - set ARRAY_ELEMENT [Const 0x1000] - set TRACE_ACTIVE [Const 0x2000] - set SEARCH_ACTIVE [Const 0x4000] - set ALL_HASH [Const 0x108c] - - ##### Function tcl.getornull ##### - # - # Convenience helper, that converts a NULL Tcl_Obj* to a NULL char*, - # and otherwise returns the string content of the Tcl_Obj*. - - set f [$m local tcl.getornull char*<-Tcl_Obj*] - params objPtr - build { - my condBr [my nonnull $objPtr] $realObj $nullObj - label nullObj: - my ret [my null char*] - label realObj: - my ret [$api Tcl_GetString $objPtr] - } - - ##### Function var.value ##### - # - # Get the value stored in a Tcl variable - - set f [$m local var.value Tcl_Obj*<-Var* readonly] - params varPtr - build { - nonnull $varPtr - my ret [my dereference $varPtr 0 Var.value] - } - - ##### Function var.defined ##### - # - # Test if the Tcl variable has a value. - - set f [$m local var.defined int1<-Var* readonly] - params varPtr - build { - nonnull $varPtr - my ret [my nonnull [my Call var.value $varPtr]] - } - - ##### Function var.value.set ##### - # - # Set the value stored in a Tcl variable - - set f [$m local var.value.set void<-Var*,Tcl_Obj*] - params varPtr valuePtr - build { - nonnull $varPtr - set ptr [my gep $varPtr 0 Var.value] - my store $valuePtr $ptr - my ret - } - - ##### Function var.value.set.undefined ##### - # - # Mark a variable as being undefined. - - set f [$m local var.value.set.undefined void<-Var*] - params varPtr - build { - nonnull $varPtr - set ref [my gep $varPtr 0 Var.flags] - my store [my and [my load $ref] [my not $ARRAY_OR_LINK]] $ref - my store [my null Tcl_Obj*] [my gep $varPtr 0 Var.value] - my ret - } - - ##### Function var.table ##### - # - # Get the variable lined to from a Tcl variable - - set f [$m local var.table VarHashTable*<-Var* readonly] - params varPtr - build { - nonnull $varPtr - set value [my dereference $varPtr 0 Var.value] - my ret [my cast(ptr) $value VarHashTable "table"] - } - - ##### Function var.link ##### - # - # Get the variable lined to from a Tcl variable - - set f [$m local var.link Var*<-Var* readonly] - params varPtr - build { - nonnull $varPtr - set value [my dereference $varPtr 0 Var.value] - my ret [my cast(ptr) $value Var "link"] - } - - ##### Function var.flag ##### - # - # Test if any of the given flag bits are set on a Tcl variable - - set f [$m local var.flag int1<-Var*,int readonly] - params varPtr flag - build { - nonnull $varPtr - set flags [my dereference $varPtr 0 Var.flags] - my ret [my neq [my and $flags $flag] $0] - } - - ##### Function var.flag.set ##### - # - # Set the given flag bits on a Tcl variable - - set f [$m local var.flag.set void<-Var*,int] - params varPtr flag - build { - nonnull $varPtr - set ref [my gep $varPtr 0 Var.flags] - my store [my or [my load $ref] $flag] $ref - my ret - } - - ##### Function var.flag.clear ##### - # - # Clear the given flag bits on a Tcl variable - - set f [$m local var.flag.clear void<-Var*,int] - params varPtr flag - build { - nonnull $varPtr - set ref [my gep $varPtr 0 Var.flags] - my store [my and [my load $ref] [my not $flag]] $ref - my ret - } - - ##### Function var.isScalar ##### - # - # Test if a Tcl variable is a scalar (not array or link) - - set f [$m local var.isScalar int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my not [my Call var.flag $varPtr $ARRAY_OR_LINK]] - } - - ##### Function var.isArray ##### - # - # Test if a Tcl variable is an array - - set f [$m local var.isArray int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $ARRAY] - } - - ##### Function var.isLink ##### - # - # Test if a Tcl variable is a link to another variable - - set f [$m local var.isLink int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $LINK] - } - - ##### Function var.isArrayElement ##### - # - # Test if a Tcl variable is an array element - - set f [$m local var.isArrayElement int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $ARRAY_ELEMENT] - } - - ##### Function var.hasSearch ##### - # - # Test if a Tcl variable has an array search running over it - - set f [$m local var.hasSearch int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $SEARCH_ACTIVE] - } - - ##### Function var.isTraced ##### - # - # Test if a Tcl variable is traced at all - - set f [$m local var.isTraced int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $TRACED_ALL] - } - - ##### Function var.isTraced.read ##### - # - # Test if a Tcl variable has read traces - - set f [$m local var.isTraced.read int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $TRACED_READS] - } - - ##### Function var.isTraced.write ##### - # - # Test if a Tcl variable has write traces - - set f [$m local var.isTraced.write int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $TRACED_WRITES] - } - - ##### Function var.isTraced.unset ##### - # - # Test if a Tcl variable has unset traces - - set f [$m local var.isTraced.unset int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $TRACED_UNSETS] - } - - ##### Function var.isTraced.array ##### - # - # Test if a Tcl array has whole-array-level traces - - set f [$m local var.isTraced.array int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $TRACED_ARRAY] - } - - ##### Function var.isInHash ##### - # - # Test if a Tcl variable is stored in a hash table - - set f [$m local var.isInHash int1<-Var*] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $IN_HASHTABLE] - } - - ##### Function var.hash.refCount ##### - # - # Get a pointer to the reference count for a variable in a hash table. - # MUST ONLY BE CALLED IF THE VARIABLE IS IN A HASH. - - set f [$m local var.hash.refCount int*<-Var* readonly] - params varPtr - build { - nonnull $varPtr - set varPtr [my cast(ptr) $varPtr VarInHash "varPtr"] - my ret [my gep $varPtr 0 VarInHash.refCount] - } - - ##### Function var.hash.invalidateEntry ##### - # - # Mark a variable in a hash table as being invalid. MUST ONLY BE - # CALLED IF THE VARIABLE IS IN A HASH. - - set f [$m local var.hash.invalidateEntry void<-Var*] - params varPtr - build { - nonnull $varPtr - my Call var.flag.set $varPtr $DEAD_HASH - my ret - } - - ##### Function var.hash.clearNamespaceVar ##### - # - # Mark a variable in a namespace as no longer being so. MUST ONLY BE - # CALLED IF THE VARIABLE IS IN A HASH. - - set f [$m local var.clearNamespaceVar void<-Var*] - params varPtr - build { - my condBr [my Call var.flag $varPtr $NAMESPACE_VAR] \ - $2 $done - label 2: - my Call var.flag.clear $varPtr $NAMESPACE_VAR - my condBr [my Call var.isInHash $varPtr] \ - $3 $done - label 3: - set ref [my call ${var.hash.refCount} $varPtr] - my store [my sub [my load $ref] $1] $ref - my br $done - label done: - my ret - } - - ##### Function var.hash.getKey ##### - # - # Get a pointer to the key of an element of a hash table. MUST ONLY BE - # CALLED IF THE VARIABLE IS IN A HASH. - - set f [$m local var.hash.getKey Tcl_Obj*<-Var* readonly] - params varPtr - build { - nonnull $varPtr - set var [my cast(ptr) $varPtr VarInHash "varPtr"] - set entry [my gep $var 0 VarInHash.entry] - set key [my dereference $entry 0 HashEntry.key] - my ret [my cast(ptr) $key Tcl_Obj "objPtr"] - } - - ##### Function var.hash.getValue ##### - # - # Get a pointer to the variable in a hash table from its hash entry. - # MUST ONLY BE CALLED IF THE VARIABLE IS IN A HASH. - - set f [$m local var.hash.getValue Var*<-HashEntry* readonly] - params hPtr - build { - nonnull $hPtr - set ptr [my cast(ptr) $hPtr char "ptr"] - set offset [my neg [my offsetof VarInHash entry]] - set ptr [my getelementptr $ptr [list $offset] "ptr"] - my ret [my cast(ptr) $ptr Var "var"] - } - - ##### Function var.hash.delete ##### - # - # Delete a hash table that is inside a variable (i.e., where that - # variable is an array). MUST ONLY BE CALLED IF THE VARIABLE IS AN - # ARRAY AND IF THE CONTENTS HAVE BEEN DELETED. - - set f [$m local var.hash.delete void<-Var*] - params varPtr - build { - nonnull $varPtr - set tablePtr [my Call var.table $varPtr] - set table [my gep $tablePtr 0 VarHashTable.table] - $api Tcl_DeleteHashTable $table - $api ckfree $tablePtr - my ret - } - - ##### Function var.hash.firstVar ##### - # - # Get a pointer to the first variable in a hash table. MUST ONLY BE - # CALLED IF THE VARIABLE IS IN A HASH. - - set f [$m local var.hash.firstVar Var*<-VarHashTable*,HashSearch*] - params tablePtr searchPtr - build { - nonnull $tablePtr $searchPtr - set table [my gep $tablePtr 0 VarHashTable.table] - set hPtr [$api Tcl_FirstHashEntry $table $searchPtr] - SetValueName $hPtr "hPtr" - my condBr [my nonnull $hPtr] $yes $no - label yes: - my ret [my Call var.hash.getValue $hPtr] - label no: - my ret [my null Var*] - } - - ##### Function var.hash.nextVar ##### - # - # Get a pointer to the next variable in a hash table. MUST ONLY BE - # CALLED IF THE VARIABLE IS IN A HASH. - - set f [$m local var.hash.nextVar Var*<-HashSearch*] - params searchPtr - build { - nonnull $searchPtr - set hPtr [$api Tcl_NextHashEntry $searchPtr] - SetValueName $hPtr "hPtr" - my condBr [my nonnull $hPtr] $yes $no - label yes: - my ret [my Call var.hash.getValue $hPtr] - label no: - my ret [my null Var*] - } - - ##### Function var.isDeadHash ##### - # - # Test if a Tcl variable is a dead member of a hash table - - set f [$m local var.isDeadHash int1<-Var* readonly] - params varPtr - build { - nonnull $varPtr - my ret [my Call var.flag $varPtr $DEAD_HASH] - } - - ##### Function var.readerr ##### - # - # Support function for tcl.read.var.ptr - - set f [$m local var.readerr char*<-Var*,Var* readonly] - params varPtr arrayPtr - build { - nonnull $varPtr - my condBr [my and \ - [my not [my Call var.defined $varPtr]] \ - [my nonnull $arrayPtr]] \ - $testDefinedArray $testArray - label testDefinedArray: - my condBr [my Call var.defined $arrayPtr] \ - $noSuchElement $testArray - label testArray: - my condBr [my Call var.flag $varPtr $1] \ - $isArray $noSuchVar - label noSuchElement: - my ret [my constString "no such element in array" "noSuchElement"] - label isArray: - my ret [my constString "variable is array" "isArray"] - label noSuchVar: - my ret [my constString "no such variable" "noSuchVar"] - } - - ##### Function tcl.read.var.ptr ##### - # - # Replica of TclPtrGetVar, except without index parameter. - - set f [$m local tcl.read.var.ptr \ - Tcl_Obj*<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,int] - params interp varPtr arrayPtr part1Ptr part2Ptr flags - build { - nonnull $interp $varPtr $part1Ptr - my condBr [my expect [my Call var.isTraced.read $varPtr] false] \ - $callTraces $test2 - label test2: - my condBr [my nonnull $arrayPtr] $test3 $testDirect - label test3: - my condBr [my expect [my Call var.isTraced.read $arrayPtr] false] \ - $callTraces $testDirect - label callTraces: - set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \ - [$api Tcl_GetString $part1Ptr] \ - [my Call tcl.getornull $part2Ptr] \ - [my or [my and $flags $NSGLBL] $TRACED_READS] \ - [my and $flags $LEAVE_ERR_MSG]] - my condBr [my expect [my eq $code $0] true] \ - $testDirect $errorReturn - label testDirect: - my condBr [my and \ - [my expect [my Call var.isScalar $varPtr] true] \ - [my expect [my Call var.defined $varPtr] true]] \ - $direct $readFail - label direct: - my ret [my Call var.value $varPtr] - label readFail: - my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \ - $errorReturn $generateError - label generateError "generate.error" - set msg [my Call var.readerr $varPtr $arrayPtr] - SetValueName $msg "msg" - $api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \ - [my Call tcl.getornull $part2Ptr] \ - [my constString "read"] $msg - my br $errorReturn - label errorReturn: - $api Tcl_SetObjErrorCode $interp \ - [$api obj.constant {TCL READ VARNAME}] - my condBr [my Call var.defined $varPtr] \ - $cleanupErrorReturn $doneError - label cleanupErrorReturn: - $api TclCleanupVar $varPtr $arrayPtr - my br $doneError - label doneError: - my ret [my null Tcl_Obj*] - } - - ##### Function set.by.append.element ##### - # - # Helper for tcl.write.var.ptr - - set f [$m local set.by.append.element \ - int1<-Interp*,Var*,Tcl_Obj*,Tcl_Obj*] - params interp var oldValue newValue - build { - my condBr [my nonnull $oldValue] \ - $update $initial - label initial: - set vp1 [$api Tcl_NewObj] - SetValueName $vp1 "oldValue" - my Call var.value.set $var $vp1 - $api Tcl_IncrRefCount $vp1 - my br $append - label update: - my condBr [my shared $oldValue] \ - $unshare $append - label unshare: - set vp2 [$api Tcl_DuplicateObj $oldValue] - SetValueName $vp2 "oldValue" - my Call var.value.set $var $vp2 - $api Tcl_DecrRefCount $oldValue - $api Tcl_IncrRefCount $vp2 - my br $append - label append: - set origins [list $initial $unshare $update] - set vp [my phi [list $vp1 $vp2 $oldValue] $origins "oldValue"] - set result [$api Tcl_ListObjAppendElement $interp $vp $newValue] - my ret [my eq $result $0] - } - - ##### Function set.copy.continuations ##### - # - # Helper for tcl.write.var.ptr; TclContinuationsCopy by another name - - set f [$m local set.copy.continuations void<-Tcl_Obj*,Tcl_Obj*] - params to from - build { - # FIXME: Cannot make this work from here! Requires access to - # internal variables of tclObj.c. - my ret - } - - ##### Function set.by.append.string ##### - # - # Helper for tcl.write.var.ptr - - set f [$m local set.by.append.string void<-Var*,Tcl_Obj*,Tcl_Obj*] - params var oldValue newValue - build { - # We append newValuePtr's bytes but don't change its ref count. - - my condBr [my nonnull $oldValue] \ - $update $initial - label initial: - my Call var.value.set $var $newValue - $api Tcl_IncrRefCount $newValue - my br $done - label update: - my condBr [my shared $oldValue] \ - $unshare $append - label unshare: - set vp1 [$api Tcl_DuplicateObj $oldValue] - SetValueName $vp1 "oldValue" - my Call var.value.set $var $vp1 - my Call set.copy.continuations $vp1 $oldValue - $api Tcl_DecrRefCount $oldValue - $api Tcl_IncrRefCount $vp1 - my br $append - label append: - set origins [list $unshare $update] - set vp [my phi [list $vp1 $oldValue] $origins "oldValue"] - $api Tcl_AppendObjToObj $vp $newValue - my condBr [my eq [my refCount $newValue] $0] \ - $dropRef $done - label dropRef "dropReference" - $api Tcl_DecrRefCount $newValue - my br $done - label done: - my ret - } - - ##### Function set.direct ##### - # - # Helper for tcl.write.var.ptr - - set f [$m local set.direct void<-Var*,Tcl_Obj*,Tcl_Obj*] - params var oldValue newValue - build { - my condBr [my eq $newValue $oldValue] \ - $done $replace - label replace: - # In this case we are replacing the value, so we don't need to do - # more than swap the objects. - - my Call var.value.set $var $newValue - $api Tcl_IncrRefCount $newValue - my condBr [my nonnull $oldValue] \ - $dropRef $done - label dropRef "dropReference" - $api Tcl_DecrRefCount $oldValue - my br $done - label done: - my ret - } - - ##### Function tcl.write.var.ptr ##### - # - # Replica of TclPtrSetVar, except without index parameter. - - set f [$m local tcl.write.var.ptr \ - Tcl_Obj*<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,Tcl_Obj*,int] - params interp varPtr arrayPtr part1Ptr part2Ptr newValuePtr flags - build { - nonnull $interp $varPtr $part1Ptr $newValuePtr - set nullResultPtr [my null Tcl_Obj*] - set cleanupOnEarlyError \ - [my eq [my refCount $newValuePtr] $0 "cleanupOnEarlyError"] - - # If the variable is in a hashtable and its hPtr field is NULL, - # then we may have an upvar to an array element where the array - # was deleted or an upvar to a namespace variable whose namespace - # was deleted. Generate an error (allowing the variable to be - # reset would screw up our storage allocation and is meaningless - # anyway). - - my condBr [my expect [my Call var.isDeadHash $varPtr] false] \ - $deadHash $test2 - - # It's an error to try to set an array variable itself. - - label test2: - my condBr [my expect [my Call var.isArray $varPtr] false] \ - $setArray $test3 - - # Invoke any read traces that have been set for the variable if it - # is requested. This was done for INST_LAPPEND_* but that was - # inconsistent with the non-bc instruction, and would cause - # failures trying to lappend to any non-existing ::env var, which - # is inconsistent with documented behavior. [Bug #3057639]. - - label test3: - my condBr [my eq [my and $flags $TRACED_READS] $0] \ - $doWrite $test4 - label test4: - my condBr [my expect [my Call var.isTraced.read $varPtr] false] \ - $callReadTraces $test5 - label test5: - my condBr [my nonnull $arrayPtr] $test6 $doWrite - label test6: - my condBr [my expect [my Call var.isTraced.read $arrayPtr] false] \ - $callReadTraces $doWrite - label callReadTraces: - set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \ - [$api Tcl_GetString $part1Ptr] \ - [my Call tcl.getornull $part2Ptr] \ - $TRACED_READS [my and $flags $LEAVE_ERR_MSG]] - my condBr [my expect [my eq $code $0] true] $doWrite $earlyError - - # Set the variable's new value. If appending, append the new value - # to the variable, either as a list element or as a string. Also, - # if appending, then if the variable's old value is unshared we - # can modify it directly, otherwise we must create a new copy to - # modify: this is "copy on write". - - label doWrite: - set oldValuePtr [my Call var.value $varPtr] - SetValueName $oldValuePtr "oldValuePtr" - my condBr [my and [my neq [my and $flags $LIST_ELEMENT] $0] \ - [my eq [my and $flags $APPEND_VALUE] $0]] \ - $clearValue $checkAppend - label clearValue: - my Call var.value.set $varPtr [my null Tcl_Obj*] - my br $checkAppend - label checkAppend: - my condBr [my neq [my and $flags [Const [expr {0x4|0x8}]]] $0] \ - $setByAppend $setDirect - label setByAppend "set.by.append" - my condBr [my neq [my and $flags $LIST_ELEMENT] $0] \ - $setByAppendElement $setByAppendString - label setByAppendElement "set.by.append.element" - my condBr [my Call set.by.append.element $interp $varPtr \ - $oldValuePtr $newValuePtr] \ - $testWriteTraces $earlyError - label setByAppendString "set.by.append.string" - my Call set.by.append.string $varPtr $oldValuePtr $newValuePtr - my br $testWriteTraces - label setDirect "set.direct" - my Call set.direct $varPtr $oldValuePtr $newValuePtr - my br $testWriteTraces - - # Invoke any write traces for the variable. - - label testWriteTraces: - my condBr [my Call var.isTraced.write $varPtr] \ - $callWriteTraces $test7 - label test7: - my condBr [my nonnull $arrayPtr] \ - $test8 $testFastReturn - label test8: - my condBr [my Call var.isTraced.write $arrayPtr] \ - $callWriteTraces $testFastReturn - label callWriteTraces: - set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \ - [$api Tcl_GetString $part1Ptr] \ - [my Call tcl.getornull $part2Ptr] \ - [my or [my and $flags $NSGLBL] $TRACED_WRITES] \ - [my and $flags $LEAVE_ERR_MSG]] - my condBr [my expect [my eq $code $0] true] \ - $testFastReturn $cleanup - - # Return the variable's value unless the variable was changed in - # some gross way by a trace (e.g. it was unset and then recreated - # as an array). - - label testFastReturn: - my condBr [my expect [my Call var.isScalar $varPtr] true] \ - $test9 $slowReturn - label test9: - my condBr [my expect [my Call var.defined $varPtr] true] \ - $fastReturn $slowReturn - label fastReturn: - my ret [my Call var.value $varPtr] - - # A trace changed the value in some gross way. Return an empty - # string object. - - label slowReturn: - set resultPtr [my dereference $interp 0 Interp.emptyObjPtr] - my br $cleanup - - # Report problems when a variable is in the process of being - # deleted or when it is really an array. - - label deadHash: - my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \ - $earlyError $test10 - label test10: - my condBr [my Call var.isArrayElement $varPtr] \ - $deadHashElem $deadHashVar - label deadHashElem "deadHash.danglingElement" - set msg1 [my constString "upvar refers to element in deleted array" "danglingElement"] - $api Tcl_SetObjErrorCode $interp \ - [$api obj.constant {TCL LOOKUP ELEMENT}] - my br $reportError - label deadHashVar "deadHash.danglingVariable" - set msg2 [my constString "upvar refers to variable in deleted namespace" "danglingVar"] - $api Tcl_SetObjErrorCode $interp \ - [$api obj.constant {TCL LOOKUP VARNAME}] - my br $reportError - label setArray: - my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \ - $earlyError $setArrayError - label setArrayError "setArray.error" - set msg3 [my constString "variable is array" "isArray"] - $api Tcl_SetObjErrorCode $interp \ - [$api obj.constant {TCL WRITE ARRAY}] - my br $reportError - label reportError: - set origins [list $deadHashElem $deadHashVar $setArrayError] - set msg [my phi [list $msg1 $msg2 $msg3] $origins "msg"] - $api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \ - [my Call tcl.getornull $part2Ptr] \ - [my constString "set"] $msg - my br $earlyError - - # Standard route for reporting problems prior to the set actually - # happening. - - label earlyError: - my condBr $cleanupOnEarlyError \ - $earlyErrorDropRef $earlyErrorDone - label earlyErrorDropRef "earlyError.dropReference" - $api Tcl_DecrRefCount $newValuePtr - my br $earlyErrorDone - label earlyErrorDone "earlyError.done" - my br $cleanup - - # If the variable doesn't exist anymore and no-one's using it, - # then free up the relevant structures and hash table entries. - - label cleanup: - set values [list $nullResultPtr $resultPtr $nullResultPtr] - set origins [list $callWriteTraces $slowReturn $earlyErrorDone] - set resultPtr [my phi $values $origins "resultPtr"] - my condBr [my nonnull $resultPtr] \ - $cleanupErrorCode $test11 - label cleanupErrorCode "cleanup.errorCode" - $api Tcl_SetObjErrorCode $interp \ - [$api obj.constant {TCL WRITE VARNAME}] - my br $test11 - label test11: - my condBr [my Call var.defined $varPtr] \ - $cleanupDone $cleanupVar - label cleanupVar "cleanup.var" - $api TclCleanupVar $varPtr $arrayPtr - my br $cleanupDone - label cleanupDone "cleanup.done" - my ret $resultPtr - } - - ##### Function var.deleteSearches ##### - # - # Replica of DeleteSearches. - - set f [$m local var.deleteSearches void<-Interp*,Var*] - params interp varPtr - build { - nonnull $interp - my condBr [my nonnull $varPtr] $testBit $done - label testBit - my condBr [my Call var.hasSearch $varPtr] $deleteSearches $done - label deleteSearches "delete.searches" - set tablePtr [my gep $interp 0 Interp.varSearches] - set sPtr [$api TclFindHashEntry $tablePtr $varPtr] - SetValueName $sPtr "sPtr" - set store [my alloc ArraySearch*] - set value [$api Tcl_GetHashValue $sPtr ArraySearch*] - SetValueName $value "searchPtr" - my store $value $store - my br $loopTest - label loopTest "loop.test" - set search [my load $store "searchPtr"] - my condBr [my nonnull $search] $loopBody $loopDone - label loopBody "loop.body" - my store [my dereference $search 0 ArraySearch.nextPtr] $store - $api Tcl_DecrRefCount [my dereference $search 0 ArraySearch.name] - $api ckfree $search - my br $loopTest - label loopDone "loop.done" - my Call var.flag.clear $varPtr $SEARCH_ACTIVE - $api Tcl_DeleteHashEntry $sPtr - my br $done - label done: - my ret - } - - ##### Function var.eventuallyFreeTrace ##### - # - # Wrapper round Tcl_EventuallyFree to coerce types right. - - set f [$m local var.eventuallyFreeTrace void<-VarTrace*] - params trace - build { - nonnull $trace - set TCL_DYNAMIC [my castInt2Ptr [Const 3] func{void<-void*}*] - $api Tcl_EventuallyFree [my cast(ptr) $trace char] $TCL_DYNAMIC - my ret - } - - ##### Function tcl.unset.var.array ##### - # - # Replica of DeleteArray, except without index parameter. - - set f [$m local tcl.unset.var.array void<-Interp*,Tcl_Obj*,Var*,int] - params interp part1Ptr varPtr flags - build { - nonnull $interp $part1Ptr $varPtr - my Call var.deleteSearches $interp $varPtr - set search [my alloc HashSearch "search"] - set elPtr [my alloc Var* "elPtr"] - my store [my Call var.hash.firstVar \ - [my Call var.table $varPtr] $search] $elPtr - my br $loopTest - label loopTest "loop.test" - set element [my load $elPtr "element"] - my condBr [my nonnull $element] $loopBody $loopDone - label loopBody "loop.body" - my condBr [my and [my Call var.isScalar $element] \ - [my Call var.defined $element]] \ - $clearContents $considerTraces - label clearContents "clear.element.contents" - $api Tcl_DecrRefCount [my Call var.value $element] - my Call var.value.set $element [my null Tcl_Obj*] - my br $considerTraces - - # Lie about the validity of the hashtable entry. In this way the - # variables will be deleted by VarHashDeleteTable. - - label considerTraces "consider.element.traces" - my Call var.hash.invalidateEntry $element - my condBr [my Call var.isTraced $element] \ - $handleTraces $clearElement - label handleTraces "handle.element.traces" - my condBr [my Call var.isTraced.unset $element] \ - $callTraces $squelchTraces - label callTraces "call.element.traces" - set elName [my Call var.hash.getKey $element] - my Call var.flag.clear $element $TRACE_ACTIVE - # NB: We know that elName is nonnull here - $api TclCallVarTraces $interp [my null Var*] $element \ - [$api Tcl_GetString $part1Ptr] \ - [$api Tcl_GetString $elName] \ - $flags $0 - my br $squelchTraces - label squelchTraces "squelch.element.traces" - set varTraces [my gep $interp 0 Interp.varTraces] - set tPtr [$api TclFindHashEntry $varTraces $element] - SetValueName $tPtr "tPtr" - set tracePtr [my alloc VarTrace* "tracePtr"] - set value [$api Tcl_GetHashValue $tPtr VarTrace*] - SetValueName $value "tracePtr" - my store $value $tracePtr - my br $squelchTracesTest - label squelchTracesTest "squelch.element.traces.test" - set trace [my load $tracePtr "trace"] - my condBr [my nonnull $trace] $squelchTracesBody $clearActives - label squelchTracesBody "squelch.element.traces.body" - my store [my dereference $trace 0 VarTrace.nextPtr] $tracePtr - my store [my null VarTrace*] [my gep $trace 0 VarTrace.nextPtr] - my Call var.eventuallyFreeTrace $trace - my br $squelchTracesTest - label clearActives "clear.element.traces.active" - $api Tcl_DeleteHashEntry $tPtr - my Call var.flag.clear $element $TRACED_ALL - set activePtr [my alloc ActiveVarTrace* "activePtr"] - my store [my dereference $interp 0 Interp.activeVarTracePtr] \ - $activePtr - my br $clearActivesTest - label clearActivesTest "clear.element.traces.active.test" - set active [my load $activePtr "active"] - my condBr [my nonnull $active] $clearActivesBody $clearElement - label clearActivesBody "clear.element.traces.active.body" - set tracedVar [my dereference $active 0 ActiveVarTrace.varPtr] - my condBr [my eq $tracedVar $element] \ - $clearActivesClear $clearActivesNext - label clearActivesClear "clear.element.traces.active.next" - my store [my null VarTrace*] \ - [my gep $active 0 ActiveVarTrace.nextTracePtr] - my br $clearActivesNext - label clearActivesNext "clear.element.traces.active.next" - my store [my dereference $active 0 ActiveVarTrace.nextPtr] \ - $activePtr - my br $clearActivesTest - label clearElement "clear.element" - my Call var.value.set.undefined $element - - # Even though array elements are not supposed to be namespace - # variables, some combinations of [upvar] and [variable] may - # create such beasts - see [Bug 604239]. This is necessary to - # avoid leaking the corresponding Var struct, and is otherwise - # harmless. - - my Call var.clearNamespaceVar $element - my br $loopNext - label loopNext "loop.next" - my store [my Call var.hash.nextVar $search] $elPtr - my br $loopTest - label loopDone "loop.done" - my Call var.hash.delete $varPtr - my ret - } - - ##### Function var.dispose.activetraces ##### - # - # Helper for tcl.unset.var.struct to make that code simpler. - - set f [$m local var.dispose.activetraces \ - void<-Interp*,Var*,VarTrace*] - params interp varPtr tracePtr - build { - set store [my alloc VarTrace* "store"] - my store $tracePtr $store - my br $traceTest - label traceTest: - set trace [my load $store "trace"] - my condBr [my nonnull $trace] $traceBody $unlinkActive - label traceBody: - my store [my dereference $trace 0 VarTrace.nextPtr] $store - my store [my null VarTrace*] [my gep $trace 0 VarTrace.nextPtr] - my Call var.eventuallyFreeTrace $trace - my br $traceTest - - label unlinkActive: - set store [my alloc ActiveVarTrace* "store"] - my store [my dereference $interp 0 Interp.activeVarTracePtr] \ - $store - my br $activeTest - label activeTest: - set active [my load $store "activeTrace"] - my condBr [my nonnull $active] $activeBody $done - label activeBody: - set activeVar [my dereference $active 0 ActiveVarTrace.varPtr] - my condBr [my eq $activeVar $varPtr] $activeBody2 $activeNext - label activeBody2: - my store [my null VarTrace*] \ - [my gep $active 0 ActiveVarTrace.nextTracePtr] - my br $activeNext - label activeNext: - my store [my dereference $active 0 ActiveVarTrace.nextPtr] \ - $store - my br $activeTest - - label done: - my ret - } - - ##### Function tcl.unset.var.struct ##### - # - # Replica of UnsetVarStruct, except without index parameter. - - set f [$m local tcl.unset.var.struct \ - void<-Var*,Var*,Interp*,Tcl_Obj*,Tcl_Obj*,int] - params varPtr arrayPtr interp part1Ptr part2Ptr flags - build { - nonnull $varPtr $interp $part1Ptr - set dummyVar [my alloc Var "dummyVar"] - my br $ct1 - label ct1 "computing.traced" - set t [my Call var.isTraced $varPtr] - my condBr $t $ct4 $ct2 - label ct2 "check.array.for.traced" - my condBr [my nonnull $arrayPtr] \ - $ct3 $ct4 - label ct3 "check.array.for.traced" - set t2 [my Call var.isTraced.unset $arrayPtr] - my br $ct4 - label ct4 "computed.traced" - set sources [list $ct1 $ct2 $ct3] - set traced [my phi [list $t $t $t2] $sources "traced"] - - my Call var.deleteSearches $interp $arrayPtr - my Call var.deleteSearches $interp $varPtr - - # The code below is tricky, because of the possibility that a - # trace function might try to access a variable being deleted. To - # handle this situation gracefully, do things in three steps: - # 1. Copy the contents of the variable to a dummy variable - # structure, and mark the original Var structure as undefined. - # 2. Invoke traces and clean up the variable, using the dummy - # copy. - # 3. If at the end of this the original variable is still - # undefined and has no outstanding references, then delete it - # (but it could have gotten recreated by a trace). - - set dummy [my load $varPtr] - set dummy [my insert $dummy [my and [my not $ALL_HASH] \ - [my extract $dummy Var.flags]] Var.flags] - my store $dummy $dummyVar - my Call var.value.set.undefined $varPtr - - # Call trace functions for the variable being deleted. Then delete - # its traces. Be sure to abort any other traces for the variable - # that are still pending. Special tricks: - # 1. We need to increment varPtr's refCount around this: - # TclCallVarTraces will use dummyVar so it won't increment - # varPtr's refCount itself. - # 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to - # call unset traces even if other traces are pending. - - my condBr $traced $processTraces $clearValues - - label processTraces "process.traces" - set varTraces [my gep $interp 0 Interp.varTraces] - set traceActive [my alloc VarTrace*] - my store [my null VarTrace*] $traceActive - my condBr [my Call var.isTraced $dummyVar] \ - $removeUnsetTraces $callUnsetTraces - - # Transfer any existing traces on var, IF there are unset traces. - # Otherwise just delete them. - - label removeUnsetTraces "remove.original.traces" - set tPtr [$api TclFindHashEntry $varTraces $varPtr] - SetValueName $tPtr "tPtr" - set tracePtr [$api Tcl_GetHashValue $tPtr VarTrace*] - SetValueName $tracePtr "tracePtr" - my store $tracePtr $traceActive - my Call var.flag.clear $varPtr $TRACED_ALL - $api Tcl_DeleteHashEntry $tPtr - my condBr [my Call var.isTraced.unset $dummyVar] \ - $recreateUnsetTraces $callUnsetTracesCheck - label recreateUnsetTraces "recreate.unset.traces" - set tPtr [$api TclCreateHashEntry $varTraces $dummyVar] - SetValueName $tPtr "tPtr" - $api Tcl_SetHashValue $tPtr $tracePtr - my br $callUnsetTracesCheck - label callUnsetTracesCheck "call.unset.traces.check" - my condBr [my Call var.isTraced.unset $dummyVar] \ - $callUnsetTraces $callUnsetTracesCheck2 - label callUnsetTracesCheck2 "call.unset.traces.check" - my condBr [my nonnull $arrayPtr] \ - $callUnsetTracesCheck3 $disposeActiveTraces - label callUnsetTracesCheck3 "call.unset.traces.check" - my condBr [my Call var.isTraced.unset $arrayPtr] \ - $callUnsetTraces $disposeActiveTraces - label callUnsetTraces "call.unset.traces" - my Call var.flag.clear $dummyVar $TRACE_ACTIVE - $api TclCallVarTraces $interp $arrayPtr $dummyVar \ - [$api Tcl_GetString $part1Ptr] \ - [my Call tcl.getornull $part2Ptr] \ - [my or [my and $flags $NSGLBL] $TRACED_UNSETS] $0 - - # The traces that we just called may have triggered a change in - # the set of traces. If so, reload the traces to manipulate. - - my store [my null VarTrace*] $traceActive - my condBr [my Call var.isTraced $dummyVar] \ - $refetchActive $disposeActiveTraces - label refetchActive "refetch.active.trace" - set tPtr [$api TclFindHashEntry $varTraces $dummyVar] - SetValueName $tPtr "tPtr" - my condBr [my nonnull $tPtr] \ - $refetchActive2 $disposeActiveTraces - label refetchActive2 "refetch.active.trace" - set tracePtr [$api Tcl_GetHashValue $tPtr VarTrace*] - SetValueName $tracePtr "tracePtr" - my store $tracePtr $traceActive - $api Tcl_DeleteHashEntry $tPtr - my br $disposeActiveTraces - - label disposeActiveTraces "dispose.active.traces" - set tracePtr [my load $traceActive "tracePtr"] - my condBr [my nonnull $tracePtr] $disposeClear $clearValues - label disposeClear "dispose.active.traces.clear" - my Call var.dispose.activetraces $interp $varPtr $tracePtr - my Call var.flag.clear $dummyVar $TRACED_ALL - my br $clearValues - - label clearValues "clear.values" - my condBr [my and \ - [my Call var.isScalar $dummyVar] \ - [my Call var.defined $dummyVar]] \ - $clearScalar $clearArrayTest - label clearScalar "clear.scalar" - $api Tcl_DecrRefCount [my Call var.value $dummyVar] - my br $clearNsVar - label clearArrayTest "clear.array.test" - my condBr [my Call var.isArray $dummyVar] \ - $clearArray $clearLinkTest - label clearArray "clear.array" - # If the variable is an array, delete all of its elements. This - # must be done after calling and deleting the traces on the array, - # above (that's the way traces are defined). If the array name is - # not present and is required for a trace on some element, it will - # be computed at DeleteArray. - - my Call tcl.unset.var.array $interp $part1Ptr $dummyVar \ - [my or [my and $flags $NSGLBL] $TRACED_UNSETS] - my br $clearNsVar - label clearLinkTest "clear.link.test" - my condBr [my Call var.isLink $dummyVar] \ - $clearLink $clearNsVar - label clearLink "clear.link" - # For global/upvar variables referenced in procedures, decrement - # the reference count on the variable referred to, and free the - # referenced variable if it's no longer needed. - - set linked [my Call var.link $dummyVar] - SetValueName $linked "linkedVarPtr" - my condBr [my Call var.isInHash $linked] \ - $cleanLinked $clearNsVar - label cleanLinked "clean.linked.variable" - set rcref [my Call var.hash.refCount $linked] - my store [my sub [my load $rcref] $1] $rcref - $api TclCleanupVar $linked [my null Var*] - my br $clearNsVar - - # If the variable was a namespace variable, decrement its - # reference count. - - label clearNsVar "clear.namespace.var" - my Call var.clearNamespaceVar $varPtr - my ret - } - - ##### Function tcl.unset.var.ptr ##### - # - # Replica of TclPtrUnsetVar, except without index parameter. - - set f [$m local tcl.unset.var.ptr \ - int<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,int] - params interp varPtr arrayPtr part1Ptr part2Ptr flags - build { - set result [my select [my Call var.defined $varPtr] $0 $1 "result"] - - # Keep the variable alive until we're done with it. We used to - # increase/decrease the refCount for each operation, making it - # hard to find [Bug 735335] - caused by unsetting the variable - # whose value was the variable's name. - - my condBr [my Call var.isInHash $varPtr] \ - $addRef $uvs - label addRef "add.reference" - set rcref [my Call var.hash.refCount $varPtr] - my store [my add [my load $rcref] $1] $rcref - my br $uvs - label uvs "unset.var.struct" - my Call tcl.unset.var.struct $varPtr $arrayPtr $interp \ - $part1Ptr $part2Ptr $flags - - # It's an error to unset an undefined variable. - - my condBr [my eq $result $0] \ - $finalCleanup $handleError - label handleError "handle.error" - my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \ - $finalCleanup $generateError - label generateError "generate.error" - set noSuchElement [my constString "no such element in array" "noSuchElement"] - set noSuchVar [my constString "no such variable" "noSuchVar"] - set msg [my select [my nonnull $arrayPtr] \ - $noSuchElement $noSuchVar] - $api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \ - [my Call tcl.getornull $part2Ptr] \ - [my constString "unset"] $msg - $api Tcl_SetObjErrorCode $interp \ - [$api obj.constant {TCL UNSET VARNAME}] - my br $finalCleanup - - # Finally, if the variable is truly not in use then free up its - # Var structure and remove it from its hash table, if any. The ref - # count of its value object, if any, was decremented above. - - label finalCleanup "final.cleanup" - my condBr [my Call var.isInHash $varPtr] \ - $doCleanup $done - label doCleanup "cleanup" - set rcref [my Call var.hash.refCount $varPtr] - my store [my sub [my load $rcref] $1] $rcref - $api TclCleanupVar $varPtr $arrayPtr - my br $done - label done: - my ret $result - } - - ##### Function tcl.read.global.ns ##### - # - # Type signature: ns:NAMESPACE * varname:STRING * ecvar:int* - # -> STRING? - # - # Reads from a global (or other namespace) variable. - - set f [$m local tcl.read.global.ns STRING?<-Namespace*,STRING,int*] - params ns varname ecvar - build { - nonnull $ns $varname $ecvar - set interp [$api tclInterp] - set arrayPtr [my alloc Var*] - # save NS - set frameNsPtr [my gep \ - [my dereference $interp 0 Interp.varFramePtr] \ - 0 CallFrame.nsPtr] - set savedNs [my load $frameNsPtr "savedNs"] - my store $ns $frameNsPtr - set var [$api TclObjLookupVar $interp $varname \ - [my null char*] [Const [expr {2+0x200+0x40000}]] \ - [my constString "access"] $1 $1 $arrayPtr] - # restore NS - my store $savedNs $frameNsPtr - my condBr [my expect [my nonnull $var] true] \ - $gotVar $fail - label gotVar: - set result [my Call tcl.read.var.ptr $interp \ - $var [my null Var*] $varname [my null Tcl_Obj*] \ - $LEAVE_ERR_MSG] - my condBr [my expect [my nonnull $result] true] \ - $gotValue $fail - label gotValue: - my addReference(STRING) $result - my ret [my just $result] - label fail: - my store $1 $ecvar - my ret [my nothing STRING] - } - - ##### Function tcl.read.global ##### - # - # Type signature: ns:STRING * varname:STRING * ecvar:int* -> STRING? - # - # Reads from a global (or other namespace) variable. - - set f [$m local tcl.read.global STRING?<-STRING,STRING,int*] - params nsname varname ecvar - build { - nonnull $nsname $varname $ecvar - set interp [$api tclInterp] - set nsptr [my alloc Namespace*] - set code [$api TclGetNamespaceFromObj $interp $nsname $nsptr] - my condBr [my expect [my eq $code $0] true] $gotNS $fail - label gotNS: - set ns [my load $nsptr] - my ret [my Call tcl.read.global.ns $ns $varname $ecvar] - label fail: - my store $1 $ecvar - my ret [my nothing STRING] - } - - ##### Function tcl.namespace.global ##### - # - # Type signature: void -> NAMESPACE - # - # Gets the handle to the global namespace. - - set f [$m local tcl.namespace.global Namespace*<-] - params - build { - set interp [$api tclInterp] - my ret [my dereference $interp 0 Interp.globalNsPtr] - } - - ##### Function tcl.namespace.current ##### - # - # Type signature: void -> NAMESPACE - # - # Gets the handle to the current namespace. - - set f [$m local tcl.namespace.current Namespace*<-] - params - build { - set interp [$api tclInterp] - set frame [my dereference $interp 0 Interp.varFramePtr] - my ret [my dereference $frame 0 CallFrame.nsPtr] - } } export @apiFunctions } Index: codegen/struct.tcl ================================================================== --- codegen/struct.tcl +++ codegen/struct.tcl @@ -1469,21 +1469,27 @@ DBTY DFR <- DICTITER pointer "DICTFOR*" $DICTFOR DBTY dummy <- "FOREACH FAIL" struct "FOREACH?" $bool $FOREACH DBTY dummy <- "DICTITER FAIL" struct "DICTITER?" $bool $DFR foreach {ty rt1} { + i32 int32 + i64 int64 ZON ZEROONE INT INT DBL DOUBLE NUMERIC NUMERIC STR STRING } { upvar 0 $ty t set rt [linsert $rt1 0 IMPURE] DBTY impure <- $rt struct <$rt1> $Obj $t + set rt [linsert $rt1 0 NEXIST] + DBTY impure <- $rt struct $rt1! $i32 $t set rt [linsert $rt1 0 FAIL] DBTY fail <- $rt struct $rt1? $bool $t + set rt [linsert $rt1 0 NEXIST IMPURE] + DBTY dummy <- $rt struct <$rt1>? $i32 $impure set rt [linsert $rt1 0 FAIL IMPURE] DBTY dummy <- $rt struct <$rt1>? $bool $impure } struct "" { Index: codegen/tclapi.tcl ================================================================== --- codegen/tclapi.tcl +++ codegen/tclapi.tcl @@ -1228,11 +1228,12 @@ my API 251 Tcl_UnlinkVar void<-Interp*,char* { NoCapture NoAliasArgs {ReadOnlyArgs 2} {NonNullArgs 1 2}} my API 252 Tcl_UnregisterChannel int<-Interp*,Channel* { NoCapture NoAliasArgs {NonNullArgs 1 2}} "code" # 253 unused: Tcl_UnsetVar - # 254 unused: Tcl_UnsetVar2 + my API 254 Tcl_UnsetVar2 int<-Interp*,char*,char*,int { + NoCapture {NonNullArgs 1 2} {ReadOnlyArgs 2 3}} "code" # 255 unused: Tcl_UntraceVar # 256 unused: Tcl_UntraceVar2 my API 257 Tcl_UpdateLinkedVar void<-Interp*,char* { NoCapture NoAliasArgs {NonNullArgs 1 2} {ReadOnlyArgs 2}} # 258 unused: Tcl_UpVar @@ -2159,10 +2160,30 @@ NoCapture NonNullArgs} # 248 unused: TclCopyChannel # 249 unused: TclDoubleDigits # 250 unused: TclSetSlaveCancelFlags # 251 unused: TclRegisterLiteral + if {[package vsatisfies [package require Tcl] 8.6.7]} { + my IntAPI 252 TclPtrGetVar \ + Tcl_Obj*<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,int { + NoCapture {NonNullArgs 1 2 4} {NoAliasArgs 1 2 3} + } "objPtr" + my IntAPI 253 TclPtrSetVar \ + Tcl_Obj*<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,Tcl_Obj*,int { + {NoCapture 1 2 3 4} {NonNullArgs 1 2 4 6} + {NoAliasArgs 1 2 3}} "objPtr" + my IntAPI 254 TclPtrIncrVar \ + Tcl_Obj*<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,Tcl_Obj*,int { + {NoCapture 1 2 3 4} {NonNullArgs 1 2 4 6} + {NoAliasArgs 1 2 3}} "objPtr" + my IntAPI 255 TclPtrObjMakeUpvar int<-Interp*,Var*,Tcl_Obj*,int { + {NoCapture 1} NonNullArgs NoAliasArgs} "code" + my IntAPI 256 TclPtrUnsetVar \ + int<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,int { + NoCapture {NonNullArgs 1 2 4} {NoAliasArgs 1 2 3} + } "code" + } ### -------------------- The TclOO API -------------------- ### if {[info exists ::USE_TCL_STUBS]} { set oost [$b alloc TclOOStubs*] @@ -2211,11 +2232,11 @@ NonNullArgs ReadOnly} "deleted" my OOAPI 15 Tcl_ObjectContextIsFiltering int<-CallContext* { NonNullArgs ReadOnly} "filtering" my OOAPI 16 Tcl_ObjectContextMethod Method*<-CallContext* { NonNullArgs ReadOnly} "method" - my OOAPI 17 Tcl_ObjectContextMethod Object*<-CallContext* { + my OOAPI 17 Tcl_ObjectContextObject Object*<-CallContext* { NonNullArgs ReadOnly} "object" my OOAPI 18 Tcl_ObjectContextSkippedArgs int<-CallContext* { NonNullArgs ReadOnly} "skip" my OOAPI 19 Tcl_ClassGetMetadata \ ClientData<-Class*,ObjectMetadataType* { Index: codegen/thunk.tcl ================================================================== --- codegen/thunk.tcl +++ codegen/thunk.tcl @@ -423,11 +423,11 @@ set resultType [string range $resultType 5 end] set isFail [$thunk block] set next [$thunk block] $b condBr [$b maybe $result] $isFail $next $isFail build $b { - $b ret $ERROR + $b ret [$b extract $result 0] } $next build-in $b set result [$b unmaybe $result] } if {[regexp "^IMPURE (.*)" $resultType]} { Index: codegen/tycon.tcl ================================================================== --- codegen/tycon.tcl +++ codegen/tycon.tcl @@ -213,14 +213,17 @@ } {^VOID FAIL$} - {^VOID\?$} - {^FAIL$} - {^NEXIST$} - {^NOTHING$} { return [Type bool] } - {^(.*) FAIL$} - {^FAIL (.*)} - {^(.*)\?$} - {^NEXIST (.*)$} { + {^(.*) FAIL$} - {^FAIL (.*)} - {^(.*)\?$} { + return [Type struct{int,[Type [lindex $m 1]]}] + } + {^NEXIST (.*)$} - {^(.*)\!$} { return [Type struct{bool,[Type [lindex $m 1]]}] } - {^IMPURE (.*)} { + {^IMPURE (.*)$} - {^<(.*)>$} { return [Type struct{STRING,[Type [lindex $m 1]]}] } {\*$} { return [PointerType [Type [string range $t 0 end-1]] 0] } ADDED codegen/varframe.tcl Index: codegen/varframe.tcl ================================================================== --- /dev/null +++ codegen/varframe.tcl @@ -0,0 +1,1944 @@ +# varframe.tcl -- +# +# Implementations of the variable and callframe quadcodes in LLVM IR. +# The implementations are generated as mandatory-inline functions that +# are added onto the Builder class, so that it can issue them by just +# generating a call to the implementation function. This allows us to +# inject extra basic blocks without disturbing the analysis from the +# reasoning engine. +# +# See build.tcl for where these functions are called from. +# +# Copyright (c) 2015-2017 by Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +#------------------------------------------------------------------------------ + +oo::define Builder { + # Variables holding implementations of Tcl's callframe handling + variable tcl.callframe.init tcl.callframe.makevar tcl.callframe.clear + variable tcl.callframe.store tcl.callframe.load tcl.callframe.bindvar + variable tcl.callframe.lookup.varns tcl.callframe.lookup.var + variable tcl.callframe.lookup.upvar + + # Helper functions + variable var.hash.getValue var.setNamespaceVar var.clearNamespaceVar + variable tcl.read.var.ptr tcl.write.var.ptr tcl.unset.var.ptr + variable var.isTraced var.defined var.isLink var.link var.isInHash + variable var.hash.refCount var.flag.set var.link.set var.hash.getKey + + variable tcl.direct.append tcl.direct.exists tcl.direct.get + variable tcl.direct.lappend tcl.direct.set tcl.direct.unset + + # Builder:CallFrameFunctions -- + # + # Generate the functions that implement the callframe handling. + # + # Parameters: + # api - The handle of the Tcl API object (currently an instance of the + # Thunk class). + # + # Results: + # None. + + method CallFrameFunctions {api} { + set 0 [Const 0] + set 1 [Const 1] + set NAMESPACE_ONLY 0x2 + set LEAVE_ERR_MSG 0x200 + set AVOID_RESOLVERS 0x40000 + + ##### tcl.callframe.init ##### + # + # Type signature: frame:CALLFRAME * length:int * objc:int * + # objv:STRING* * proc:Proc* * localCache:LocalCache* * + # locals:Var* -> void + # + # Set up a call frame, with all local variables in it as simple unset + # variables. + + set f [$m local "tcl.callframe.init" \ + void<-CALLFRAME,int,int,STRING*,Proc*,LocalCache*,Var*] + params frame length objc objv proc localCache locals + build { + nonnull $frame $objv $proc $localCache $locals + set interp [$api tclInterp] + set rcPtr [my gep $proc 0 Proc.refCount] + my store [my add [my load $rcPtr] $1] $rcPtr + set nsPtr [my dereference [my dereference $proc 0 Proc.cmdPtr] \ + 0 Command.nsPtr] + $api Tcl_PushCallFrame $interp $frame $nsPtr $1 + set varTable [my null VarHashTable*] + set cllen1 [my mult $length [my cast(int) [my sizeof Var]]] + my storeInStruct $frame CallFrame.objc $objc + my storeInStruct $frame CallFrame.objv $objv + my storeInStruct $frame CallFrame.procPtr $proc + my storeInStruct $frame CallFrame.varTablePtr $varTable + my storeInStruct $frame CallFrame.numCompiledLocals $length + my storeInStruct $frame CallFrame.compiledLocals $locals + my storeInStruct $frame CallFrame.localCachePtr $localCache + set rcPtr [my gep $localCache 0 LocalCache.refCount] + my store [my add [my load $rcPtr] $1] $rcPtr + my bzero $locals $cllen1 + my ret + } + + ##### tcl.callframe.makevar ##### + # + # Type signature: frame:CALLFRAME * index:int * flags:int -> Var* + # + # Set up (and return) a variable within a call frame's LVT. + + set f [$m local "tcl.callframe.makevar" Var*<-CALLFRAME,int,int] + params frame index flags + build { + nonnull $frame + set lvt [my dereference $frame 0 CallFrame.compiledLocals] + set local [my getelementptr $lvt $index] + my storeInStruct $local Var.flags $flags + my storeInStruct $local Var.value [my null Tcl_Obj*] + my ret $local + } + + ##### tcl.callframe.clear ##### + # + # Type signature: frame:CALLFRAME -> void + # + # Dispose of all resources associated with a call frame. + + set f [$m local "tcl.callframe.clear" void<-CALLFRAME] + params frame + build { + nonnull $frame + set interp [$api tclInterp] + $api Tcl_PopCallFrame $interp + set proc [my dereference $frame 0 CallFrame.procPtr] + set rcPtr [my gep $proc 0 Proc.refCount] + my store [my sub [my load $rcPtr] $1] $rcPtr + # TODO: ought to theoretically delete the Proc when it has a + # refcount of 0. But we can actually postpone that until the + # library is deleted. And we don't do that anyway... + my ret + } + + ##### var.followLinks ##### + # + # Type signature: var:Var* -> Var* + # + # Given a particular variable, follow its chain of links (which might + # be none at all) to get to the actual variable holding the real + # value. + + set f [$m local "var.followLinks" Var*<-Var*] + params var + build { + nonnull $var + set vp [my alloc Var*] + my store $var $vp + my br $test + label test: + set var [my load $vp "varPtr"] + my condBr [my Call var.isLink $var] $follow $done + label follow: + my store [my Call var.link $var] $vp + my br $test + label done: + my ret $var + } + + ##### tcl.callframe.store ##### + # + # Type signature: var:Var* * varName:STRING * value:STRING! -> void + # + # Write a value to a local variable (in the call frame). + + set f [$m local "tcl.callframe.store" void<-Var*,STRING,STRING!] + params var varName value + build { + nonnull $var $varName + set interp [$api tclInterp] + set nv [my null Var*] + set ns [my null STRING] + set var [my call ${var.followLinks} [list $var] "varPtr"] + my condBr [my maybe $value] $doUnset $doSet + # TODO: Writes and unsets may fail if traces on a global variable + # are present and fail. + label doSet: + set value [my unmaybe $value] + my Call tcl.write.var.ptr $interp $var $nv $varName $ns $value $0 + my ret + label doUnset: + my Call tcl.unset.var.ptr $interp $var $nv $varName $ns $0 + my ret + } + + ##### tcl.callframe.load ##### + # + # Type signature: var:Var* * varName:STRING -> STRING! + # + # Read a value from a local variable (in the call frame). + + set f [$m local "tcl.callframe.load" STRING!<-Var*,STRING] + params var varName + build { + nonnull $var $varName + set interp [$api tclInterp] + set nv [my null Var*] + set ns [my null STRING] + set var [my call ${var.followLinks} [list $var] "varPtr"] + set value [my Call tcl.read.var.ptr $interp $var $nv $varName $ns\ + [Const $LEAVE_ERR_MSG]] + my condBr [my nonnull $value] $gotValue $noValue + label gotValue: + my addReference(STRING) $value + my ret [my just $value] + label noValue: + my ret [my nothing STRING] + } + + ##### tcl.callframe.bindvar ##### + # + # Type signature: frame:CALLFRAME * otherVar:Var* * localVar:Var* * + # localName:STRING * errorCode:int* -> bool? + # + # Link a variable in the local call frame to a variable to a variable + # in another context that has already been looked up. Also finishes up + # handling the result of a failure to look up the variable: a NULL for + # otherVar causes the state to be set correctly. + # + # The result type is not very important other than that it is a FAIL + # type. + + set f [$m local "tcl.callframe.bindvar" \ + bool?<-CALLFRAME,Var*,Var*,STRING,int*] + params frame otherVar localVar localName errorCode + build { + nonnull $frame $localVar $localName $errorCode + set interp [$api tclInterp] + my condBr [my nonnull $otherVar] $bind $error + label bind: + my condBr [my eq $otherVar $localVar] $complex $check2 + label check2: + my condBr [my Call var.isTraced $localVar] $complex $check3 + label check3: + my condBr [my or [my not [my Call var.defined $localVar]] \ + [my Call var.isLink $localVar]] \ + $check4 $complex + label check4: + my condBr [my Call var.defined $localVar] $linkExisting $link + label linkExisting "link.existing" + set linkVar [my Call var.link $localVar] + my condBr [my eq $linkVar $otherVar] $done $checkUnlinkExisting + label checkUnlinkExisting "check.unlink.existing" + my condBr [my Call var.isInHash $linkVar] $unlinkExisting $link + label unlinkExisting "unlink.existing" + set rcref [my Call var.hash.refCount $linkVar] + my store [my sub [my load $rcref] $1] $rcref + my condBr [my Call var.defined $linkVar] $link $cleanupOldLink + label cleanupOldLink "cleanup.old.link" + $api TclCleanupVar $linkVar [my null Var*] + my br $link + label link: + my Call var.link.set $localVar $otherVar + my condBr [my Call var.isInHash $otherVar] $linkAddRef $done + label linkAddRef "link.addRef" + set rc [my Call var.hash.refCount $otherVar] + my store [my add [my load $rc] $1] $rc + my br $done + label complex: + # This is all too complicated! Call into Tcl to do the dirty + set nameStr [$api Tcl_GetString $localName] + set code [$api TclPtrMakeUpvar $interp $otherVar $nameStr \ + $0 [Const -1]] + my condBr [my neq $code $0] $error $done + label done: + my ret [my ok [my undef bool]] + label error: + my store $1 $errorCode + my ret [my fail bool] + } + + ##### tcl.callframe.lookup.varns ##### + # + # Type signature: frame:CALLFRAME * nsName:STRING * varName:STRING + # -> Var* + # + # Look up a variable by name in the named namespace. + + set f [$m local "tcl.callframe.lookup.varns" \ + Var*<-CALLFRAME,STRING,STRING] + params frame nsName varName + build { + nonnull $frame $nsName $varName + set interp [$api tclInterp] + set nsPtrPtr [my alloc Namespace* "nsPtr"] + set arrayPtrPtr [my alloc Var* "arrayPtr"] + my condBr [my neq $0 \ + [$api TclGetNamespaceFromObj $interp $nsName $nsPtrPtr]] \ + $gotError $gotNamespace + label gotNamespace: + set iNsPtr [my gep [my dereference $interp 0 \ + Interp.varFramePtr] 0 CallFrame.nsPtr] + set saved [my load $iNsPtr "savedNsPtr"] + set nsPtr [my load $nsPtrPtr "nsPtr"] + my assume [my nonnull $nsPtr] + my store $nsPtr $iNsPtr + set flags [expr { + $NAMESPACE_ONLY | $LEAVE_ERR_MSG | $AVOID_RESOLVERS + }] + set other [$api TclObjLookupVar $interp \ + $varName [my null char*] [Const $flags] \ + [my constString "access"] $1 $1 $arrayPtrPtr] + my store $saved $iNsPtr + my condBr [my nonnull $other] $gotVar $gotError + label gotVar: + my ret $other + label gotError: + my ret [my null Var*] + } + + ##### tcl.callframe.lookup.var ##### + # + # Type signature: frame:CALLFRAME * varName:STRING -> Var* + # + # Look up a variable by name, using the current frame as general + # context. + + set f [$m local "tcl.callframe.lookup.var" Var*<-CALLFRAME,STRING] + params frame varName + build { + nonnull $frame $varName + set interp [$api tclInterp] + set arrayPtrPtr [my alloc Var* "arrayPtr"] + set flags [expr {$NAMESPACE_ONLY | $LEAVE_ERR_MSG}] + set other [$api TclObjLookupVar $interp \ + $varName [my null char*] [Const $flags] \ + [my constString "access"] $1 $1 $arrayPtrPtr] + my condBr [my nonnull $other] $gotVar $gotError + label gotVar: + my Call var.setNamespaceVar $other + my ret $other + label gotError: + my ret [my null Var*] + } + + ##### tcl.get.level.frame ##### + # + # Type signature: level:STRING -> CallFrame* + # + # Look up a call frame by descriptor of stack level. Wrapper round + # TclObjGetFrame to tame its strangeness. + + set f [$m local "tcl.get.level.frame" CallFrame*<-STRING] + params level + build { + nonnull $level + set interp [$api tclInterp] + set framePtrPtr [my alloc CallFrame* "framePtrPtr"] + set code [$api TclObjGetFrame $interp $level $framePtrPtr] + # Yes, the result code out of TclObjGetFrame is non-standard + my condBr [my expect [my eq $code $1] true] $ok $checkForWeird + label ok: + set framePtr [my load $framePtrPtr "framePtr"] + my assume [my nonnull $framePtr] + my ret $framePtr + label checkForWeird "check.for.weird.level" + my condBr [my eq $code $0] $weirdLevel $error + label weirdLevel "weird.level" + # The level parameter was not a level! Treat as error here because + # TclObjGetFrame doesn't do it for us. + set levelstr [$api Tcl_GetString $level] + $api Tcl_SetObjResult $interp [$api \ + Tcl_ObjPrintf [my constString "bad level \"%s\""] $levelstr] + $api Tcl_SetErrorCode $interp \ + [my constString TCL] [my constString LOOKUP] \ + [my constString LEVEL] $levelstr [my null char*] + my br $error + label error: + my ret [my null CallFrame*] + } + + ##### tcl.callframe.lookup.upvar ##### + # + # Type signature: frame:CALLFRAME * level:STRING * varName:STRING + # -> Var* + # + # Look up a variable by name in the indicated level. + + set f [$m local "tcl.callframe.lookup.upvar" \ + Var*<-CALLFRAME,STRING,STRING] + params frame level varName + build { + nonnull $frame $level $varName + set framePtr [my Call tcl.get.level.frame $level] + SetValueName $framePtr "framePtr" + my condBr [my nonnull $framePtr] $lookup $error + label lookup: + set interp [$api tclInterp] + set vfp [my gep $interp 0 Interp.varFramePtr] + set savedFramePtr [my load $vfp "savedFramePtr"] + my store $framePtr $vfp + set arrayPtrPtr [my alloc Var* "arrayPtr"] + set flags [expr {$LEAVE_ERR_MSG}] + set other [$api TclObjLookupVar $interp \ + $varName [my null char*] [Const $flags] \ + [my constString "access"] $1 $1 $arrayPtrPtr] + my store $savedFramePtr $vfp + my condBr [my nonnull $other] $gotVar $error + label gotVar: + my ret $other + label error: + my ret [my null Var*] + } + } + + # Builder:@variableFunctions -- + # + # Generate the quadcode operator implementations that access Tcl + # variables. + # + # Parameters: + # api - The handle of the Tcl API object (currently an instance of the + # Thunk class). + # + # Results: + # None. + + method @variableFunctions {api} { + set 0 [Const 0] + set 1 [Const 1] + + # Various flag bits + set ARRAY [Const 0x1] + set LINK [Const 0x2] + set ARRAY_OR_LINK [Const 0x3] + set NS_ONLY [Const 0x2] + set NSGLBL [Const [expr {0x1 | 0x2}]] + set APPEND_VALUE [Const 0x04] + set IN_HASHTABLE [Const 0x04] + set LIST_ELEMENT [Const 0x08] + set DEAD_HASH [Const 0x8] + set TRACED_READS [Const 0x10] + set TRACED_WRITES [Const 0x20] + set TRACED_UNSETS [Const 0x40] + set NAMESPACE_VAR [Const 0x80] + set LEAVE_ERR_MSG [Const 0x200] + set TRACED_ARRAY [Const 0x800] + set TRACED_ALL [Const 0x870] + set ARRAY_ELEMENT [Const 0x1000] + set TRACE_ACTIVE [Const 0x2000] + set SEARCH_ACTIVE [Const 0x4000] + set ALL_HASH [Const 0x108c] + set AVOID_RESOLVERS [Const 0x40000] + + ##### Function tcl.getornull ##### + # + # Convenience helper, that converts a NULL Tcl_Obj* to a NULL char*, + # and otherwise returns the string content of the Tcl_Obj*. + + set f [$m local tcl.getornull char*<-Tcl_Obj*] + params objPtr + build { + my condBr [my nonnull $objPtr] $realObj $nullObj + label nullObj: + my ret [my null char*] + label realObj: + my ret [$api Tcl_GetString $objPtr] + } + + ##### Function var.value ##### + # + # Get the value stored in a Tcl variable + + set f [$m local var.value Tcl_Obj*<-Var* readonly] + params varPtr + build { + nonnull $varPtr + my ret [my dereference $varPtr 0 Var.value] + } + + ##### Function var.defined ##### + # + # Test if the Tcl variable has a value. + + set f [$m local var.defined int1<-Var* readonly] + params varPtr + build { + nonnull $varPtr + my ret [my nonnull [my Call var.value $varPtr]] + } + + ##### Function var.value.set ##### + # + # Set the value stored in a Tcl variable + + set f [$m local var.value.set void<-Var*,Tcl_Obj*] + params varPtr valuePtr + build { + nonnull $varPtr + set ptr [my gep $varPtr 0 Var.value] + my store $valuePtr $ptr + my ret + } + + ##### Function var.value.set.undefined ##### + # + # Mark a variable as being undefined. + + set f [$m local var.value.set.undefined void<-Var*] + params varPtr + build { + nonnull $varPtr + set ref [my gep $varPtr 0 Var.flags] + my store [my and [my load $ref] [my not $ARRAY_OR_LINK]] $ref + my store [my null Tcl_Obj*] [my gep $varPtr 0 Var.value] + my ret + } + + ##### Function var.table ##### + # + # Get the variable lined to from a Tcl variable + + set f [$m local var.table VarHashTable*<-Var* readonly] + params varPtr + build { + nonnull $varPtr + set value [my dereference $varPtr 0 Var.value] + my ret [my cast(ptr) $value VarHashTable "table"] + } + + ##### Function var.link ##### + # + # Get the variable lined to from a Tcl variable + + set f [$m local var.link Var*<-Var* readonly] + params varPtr + build { + nonnull $varPtr + set value [my dereference $varPtr 0 Var.value] + my ret [my cast(ptr) $value Var "link"] + } + + ##### Function var.flag ##### + # + # Test if any of the given flag bits are set on a Tcl variable + + set f [$m local var.flag int1<-Var*,int readonly] + params varPtr flag + build { + nonnull $varPtr + set flags [my dereference $varPtr 0 Var.flags] + my ret [my neq [my and $flags $flag] $0] + } + + ##### Function var.flag.set ##### + # + # Set the given flag bits on a Tcl variable + + set f [$m local var.flag.set void<-Var*,int] + params varPtr flag + build { + nonnull $varPtr + set ref [my gep $varPtr 0 Var.flags] + my store [my or [my load $ref] $flag] $ref + my ret + } + + ##### Function var.flag.clear ##### + # + # Clear the given flag bits on a Tcl variable + + set f [$m local var.flag.clear void<-Var*,int] + params varPtr flag + build { + nonnull $varPtr + set ref [my gep $varPtr 0 Var.flags] + my store [my and [my load $ref] [my not $flag]] $ref + my ret + } + + ##### Function var.link.set ##### + # + # Set the link stored in a Tcl variable; caller is responsible for + # releasing any previously held references. + + set f [$m local var.link.set void<-Var*,Var*] + params varPtr otherPtr + build { + nonnull $varPtr $otherPtr + my Call var.flag.set $varPtr $LINK + my Call var.value.set $varPtr [my cast(ptr) $otherPtr Tcl_Obj] + my ret + } + + ##### Function var.isScalar ##### + # + # Test if a Tcl variable is a scalar (not array or link) + + set f [$m local var.isScalar int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my not [my Call var.flag $varPtr $ARRAY_OR_LINK]] + } + + ##### Function var.isArray ##### + # + # Test if a Tcl variable is an array + + set f [$m local var.isArray int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $ARRAY] + } + + ##### Function var.isLink ##### + # + # Test if a Tcl variable is a link to another variable + + set f [$m local var.isLink int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $LINK] + } + + ##### Function var.isArrayElement ##### + # + # Test if a Tcl variable is an array element + + set f [$m local var.isArrayElement int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $ARRAY_ELEMENT] + } + + ##### Function var.hasSearch ##### + # + # Test if a Tcl variable has an array search running over it + + set f [$m local var.hasSearch int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $SEARCH_ACTIVE] + } + + ##### Function var.isTraced ##### + # + # Test if a Tcl variable is traced at all + + set f [$m local var.isTraced int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $TRACED_ALL] + } + + ##### Function var.isTraced.read ##### + # + # Test if a Tcl variable has read traces + + set f [$m local var.isTraced.read int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $TRACED_READS] + } + + ##### Function var.isTraced.write ##### + # + # Test if a Tcl variable has write traces + + set f [$m local var.isTraced.write int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $TRACED_WRITES] + } + + ##### Function var.isTraced.unset ##### + # + # Test if a Tcl variable has unset traces + + set f [$m local var.isTraced.unset int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $TRACED_UNSETS] + } + + ##### Function var.isTraced.array ##### + # + # Test if a Tcl array has whole-array-level traces + + set f [$m local var.isTraced.array int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $TRACED_ARRAY] + } + + ##### Function var.isInHash ##### + # + # Test if a Tcl variable is stored in a hash table + + set f [$m local var.isInHash int1<-Var*] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $IN_HASHTABLE] + } + + ##### Function var.hash.refCount ##### + # + # Get a pointer to the reference count for a variable in a hash table. + # MUST ONLY BE CALLED IF THE VARIABLE IS IN A HASH. + + set f [$m local var.hash.refCount int*<-Var* readonly] + params varPtr + build { + nonnull $varPtr + set varPtr [my cast(ptr) $varPtr VarInHash "varPtr"] + my ret [my gep $varPtr 0 VarInHash.refCount] + } + + ##### Function var.hash.invalidateEntry ##### + # + # Mark a variable in a hash table as being invalid. MUST ONLY BE + # CALLED IF THE VARIABLE IS IN A HASH. + + set f [$m local var.hash.invalidateEntry void<-Var*] + params varPtr + build { + nonnull $varPtr + my Call var.flag.set $varPtr $DEAD_HASH + my ret + } + + ##### Function var.setNamespaceVar ##### + # + # Mark a variable as being in a namespace. + + set f [$m local var.setNamespaceVar void<-Var*] + params varPtr + build { + my condBr [my nonnull $varPtr] \ + $l1 $done + label l1: + my condBr [my Call var.flag $varPtr $NAMESPACE_VAR] \ + $done $l2 + label l2: + my Call var.flag.set $varPtr $NAMESPACE_VAR + my condBr [my Call var.isInHash $varPtr] \ + $l3 $done + label l3: + set ref [my Call var.hash.refCount $varPtr] + my store [my add [my load $ref] $1] $ref + my br $done + label done: + my ret + } + + ##### Function var.clearNamespaceVar ##### + # + # Mark a variable in a namespace as no longer being so. MUST ONLY BE + # CALLED IF THE VARIABLE IS IN A HASH. + + set f [$m local var.clearNamespaceVar void<-Var*] + params varPtr + build { + nonnull $varPtr + my condBr [my Call var.flag $varPtr $NAMESPACE_VAR] \ + $2 $done + label 2: + my Call var.flag.clear $varPtr $NAMESPACE_VAR + my condBr [my Call var.isInHash $varPtr] \ + $3 $done + label 3: + set ref [my Call var.hash.refCount $varPtr] + my store [my sub [my load $ref] $1] $ref + my br $done + label done: + my ret + } + + ##### Function var.hash.getKey ##### + # + # Get a pointer to the key of an element of a hash table. MUST ONLY BE + # CALLED IF THE VARIABLE IS IN A HASH. + + set f [$m local var.hash.getKey Tcl_Obj*<-Var* readonly] + params varPtr + build { + nonnull $varPtr + set var [my cast(ptr) $varPtr VarInHash "varPtr"] + set entry [my gep $var 0 VarInHash.entry] + set key [my dereference $entry 0 HashEntry.key] + my ret [my cast(ptr) $key Tcl_Obj "objPtr"] + } + + ##### Function var.hash.getValue ##### + # + # Get a pointer to the variable in a hash table from its hash entry. + # MUST ONLY BE CALLED IF THE VARIABLE IS IN A HASH. + + set f [$m local var.hash.getValue Var*<-HashEntry* readonly] + params hPtr + build { + nonnull $hPtr + set ptr [my cast(ptr) $hPtr char "ptr"] + set offset [my neg [my offsetof VarInHash entry]] + set ptr [my getelementptr $ptr [list $offset] "ptr"] + my ret [my cast(ptr) $ptr Var "var"] + } + + ##### Function var.hash.delete ##### + # + # Delete a hash table that is inside a variable (i.e., where that + # variable is an array). MUST ONLY BE CALLED IF THE VARIABLE IS AN + # ARRAY AND IF THE CONTENTS HAVE BEEN DELETED. + + set f [$m local var.hash.delete void<-Var*] + params varPtr + build { + nonnull $varPtr + set tablePtr [my Call var.table $varPtr] + set table [my gep $tablePtr 0 VarHashTable.table] + $api Tcl_DeleteHashTable $table + $api ckfree $tablePtr + my ret + } + + ##### Function var.hash.firstVar ##### + # + # Get a pointer to the first variable in a hash table. MUST ONLY BE + # CALLED IF THE VARIABLE IS IN A HASH. + + set f [$m local var.hash.firstVar Var*<-VarHashTable*,HashSearch*] + params tablePtr searchPtr + build { + nonnull $tablePtr $searchPtr + set table [my gep $tablePtr 0 VarHashTable.table] + set hPtr [$api Tcl_FirstHashEntry $table $searchPtr] + SetValueName $hPtr "hPtr" + my condBr [my nonnull $hPtr] $yes $no + label yes: + my ret [my Call var.hash.getValue $hPtr] + label no: + my ret [my null Var*] + } + + ##### Function var.hash.nextVar ##### + # + # Get a pointer to the next variable in a hash table. MUST ONLY BE + # CALLED IF THE VARIABLE IS IN A HASH. + + set f [$m local var.hash.nextVar Var*<-HashSearch*] + params searchPtr + build { + nonnull $searchPtr + set hPtr [$api Tcl_NextHashEntry $searchPtr] + SetValueName $hPtr "hPtr" + my condBr [my nonnull $hPtr] $yes $no + label yes: + my ret [my Call var.hash.getValue $hPtr] + label no: + my ret [my null Var*] + } + + ##### Function var.isDeadHash ##### + # + # Test if a Tcl variable is a dead member of a hash table + + set f [$m local var.isDeadHash int1<-Var* readonly] + params varPtr + build { + nonnull $varPtr + my ret [my Call var.flag $varPtr $DEAD_HASH] + } + + ##### Function var.readerr ##### + # + # Support function for tcl.read.var.ptr + + set f [$m local var.readerr char*<-Var*,Var* readonly] + params varPtr arrayPtr + build { + nonnull $varPtr + my condBr [my and \ + [my not [my Call var.defined $varPtr]] \ + [my nonnull $arrayPtr]] \ + $testDefinedArray $testArray + label testDefinedArray: + my condBr [my Call var.defined $arrayPtr] \ + $noSuchElement $testArray + label testArray: + my condBr [my Call var.flag $varPtr $1] \ + $isArray $noSuchVar + label noSuchElement: + my ret [my constString "no such element in array" "noSuchElement"] + label isArray: + my ret [my constString "variable is array" "isArray"] + label noSuchVar: + my ret [my constString "no such variable" "noSuchVar"] + } + + ##### Function tcl.read.var.ptr ##### + # + # Replica of TclPtrGetVar, except without index parameter. + + set f [$m local tcl.read.var.ptr \ + Tcl_Obj*<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,int] + params interp varPtr arrayPtr part1Ptr part2Ptr flags + if {"TclPtrGetVar" in [info object methods $api -all]} { + build { + nonnull $interp $varPtr $part1Ptr + noalias $interp $varPtr + my ret [$api TclPtrGetVar \ + $interp $varPtr $arrayPtr $part1Ptr $part2Ptr $flags] + } + } else { + build { + nonnull $interp $varPtr $part1Ptr + noalias $interp $varPtr + my condBr \ + [my expect [my Call var.isTraced.read $varPtr] false] \ + $callTraces $test2 + label test2 "test" + my condBr [my nonnull $arrayPtr] $test3 $testDirect + label test3 "test" + my condBr \ + [my expect [my Call var.isTraced.read $arrayPtr] false] \ + $callTraces $testDirect + label callTraces "call.traces" + set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \ + [$api Tcl_GetString $part1Ptr] \ + [my Call tcl.getornull $part2Ptr] \ + [my or [my and $flags $NSGLBL] $TRACED_READS] \ + [my and $flags $LEAVE_ERR_MSG]] + my condBr [my expect [my eq $code $0] true] \ + $testDirect $errorReturn + label testDirect "test" + my condBr [my and \ + [my expect [my Call var.isScalar $varPtr] true] \ + [my expect [my Call var.defined $varPtr] true]] \ + $direct $readFail + label direct: + my ret [my Call var.value $varPtr] + label readFail "read.fail" + my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \ + $errorReturn $generateError + label generateError "generate.error" + set msg [my Call var.readerr $varPtr $arrayPtr] + SetValueName $msg "msg" + $api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \ + [my Call tcl.getornull $part2Ptr] \ + [my constString "read"] $msg + my br $errorReturn + label errorReturn "error.return" + $api Tcl_SetObjErrorCode $interp \ + [$api obj.constant {TCL READ VARNAME}] + my condBr [my Call var.defined $varPtr] \ + $cleanupErrorReturn $doneError + label cleanupErrorReturn "cleanup.error.return" + $api TclCleanupVar $varPtr $arrayPtr + my br $doneError + label doneError "done" + my ret [my null Tcl_Obj*] + } + } + + ##### Function set.by.append.element ##### + # + # Helper for tcl.write.var.ptr + + set f [$m local set.by.append.element \ + int1<-Interp*,Var*,Tcl_Obj*,Tcl_Obj*] + params interp var oldValue newValue + build { + nonnull $interp $var $newValue + my condBr [my nonnull $oldValue] \ + $update $initial + label initial: + set vp1 [$api Tcl_NewObj] + SetValueName $vp1 "oldValue" + my Call var.value.set $var $vp1 + $api Tcl_IncrRefCount $vp1 + my br $append + label update: + my condBr [my shared $oldValue] \ + $unshare $append + label unshare: + set vp2 [$api Tcl_DuplicateObj $oldValue] + SetValueName $vp2 "oldValue" + my Call var.value.set $var $vp2 + $api Tcl_DecrRefCount $oldValue + $api Tcl_IncrRefCount $vp2 + my br $append + label append: + set origins [list $initial $unshare $update] + set vp [my phi [list $vp1 $vp2 $oldValue] $origins "oldValue"] + set result [$api Tcl_ListObjAppendElement $interp $vp $newValue] + my ret [my eq $result $0] + } + + ##### Function set.copy.continuations ##### + # + # Helper for tcl.write.var.ptr; TclContinuationsCopy by another name + + set f [$m local set.copy.continuations void<-Tcl_Obj*,Tcl_Obj*] + params to from + build { + # FIXME: Cannot make this work from here! Requires access to + # internal variables of tclObj.c. + my ret + } + + ##### Function set.by.append.string ##### + # + # Helper for tcl.write.var.ptr + + set f [$m local set.by.append.string void<-Var*,Tcl_Obj*,Tcl_Obj*] + params var oldValue newValue + build { + nonnull $var $newValue + # We append newValuePtr's bytes but don't change its ref count. + + my condBr [my nonnull $oldValue] \ + $update $initial + label initial: + my Call var.value.set $var $newValue + $api Tcl_IncrRefCount $newValue + my br $done + label update: + my condBr [my shared $oldValue] \ + $unshare $append + label unshare: + set vp1 [$api Tcl_DuplicateObj $oldValue] + SetValueName $vp1 "oldValue" + my Call var.value.set $var $vp1 + my Call set.copy.continuations $vp1 $oldValue + $api Tcl_DecrRefCount $oldValue + $api Tcl_IncrRefCount $vp1 + my br $append + label append: + set origins [list $unshare $update] + set vp [my phi [list $vp1 $oldValue] $origins "oldValue"] + $api Tcl_AppendObjToObj $vp $newValue + my condBr [my eq [my refCount $newValue] $0] \ + $dropRef $done + label dropRef "dropReference" + $api Tcl_DecrRefCount $newValue + my br $done + label done: + my ret + } + + ##### Function set.direct ##### + # + # Helper for tcl.write.var.ptr + + set f [$m local set.direct void<-Var*,Tcl_Obj*,Tcl_Obj*] + params var oldValue newValue + build { + nonnull $var $newValue + my condBr [my eq $newValue $oldValue] \ + $done $replace + label replace: + # In this case we are replacing the value, so we don't need to do + # more than swap the objects. + + my Call var.value.set $var $newValue + $api Tcl_IncrRefCount $newValue + my condBr [my nonnull $oldValue] \ + $dropRef $done + label dropRef "dropReference" + $api Tcl_DecrRefCount $oldValue + my br $done + label done: + my ret + } + + ##### Function tcl.write.var.ptr ##### + # + # Replica of TclPtrSetVar. + + set f [$m local tcl.write.var.ptr \ + Tcl_Obj*<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,Tcl_Obj*,int] + params interp varPtr arrayPtr part1Ptr part2Ptr newValuePtr flags + if {"TclPtrSetVar" in [info object methods $api -all]} { + build { + nonnull $interp $varPtr $part1Ptr $newValuePtr + noalias $interp $varPtr + my ret [$api TclPtrSetVar \ + $interp $varPtr $arrayPtr $part1Ptr $part2Ptr \ + $newValuePtr $flags] + } + } else { + build { + nonnull $interp $varPtr $part1Ptr $newValuePtr + noalias $interp $varPtr + set nullResultPtr [my null Tcl_Obj*] + set cleanupOnEarlyError \ + [my eq [my refCount $newValuePtr] $0 "cleanupOnEarlyError"] + + # If the variable is in a hashtable and its hPtr field is + # NULL, then we may have an upvar to an array element where + # the array was deleted or an upvar to a namespace variable + # whose namespace was deleted. Generate an error (allowing the + # variable to be reset would screw up our storage allocation + # and is meaningless anyway). + + my condBr [my expect [my Call var.isDeadHash $varPtr] false] \ + $deadHash $test2 + + # It's an error to try to set an array variable itself. + + label test2 "test" + my condBr [my expect [my Call var.isArray $varPtr] false] \ + $setArray $test3 + + # Invoke any read traces that have been set for the variable + # if it is requested. This was done for INST_LAPPEND_* but + # that was inconsistent with the non-bc instruction, and would + # cause failures trying to lappend to any non-existing ::env + # var, which is inconsistent with documented behavior. [Bug + # #3057639]. + + label test3 "test" + my condBr [my eq [my and $flags $TRACED_READS] $0] \ + $doWrite $test4 + label test4 "test" + my condBr \ + [my expect [my Call var.isTraced.read $varPtr] false] \ + $callReadTraces $test5 + label test5 "test" + my condBr [my nonnull $arrayPtr] $test6 $doWrite + label test6 "test" + my condBr \ + [my expect [my Call var.isTraced.read $arrayPtr] false] \ + $callReadTraces $doWrite + label callReadTraces "call.read.traces" + set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \ + [$api Tcl_GetString $part1Ptr] \ + [my Call tcl.getornull $part2Ptr] \ + $TRACED_READS [my and $flags $LEAVE_ERR_MSG]] + my condBr [my expect [my eq $code $0] true] \ + $doWrite $earlyError + + # Set the variable's new value. If appending, append the new + # value to the variable, either as a list element or as a + # string. Also, if appending, then if the variable's old value + # is unshared we can modify it directly, otherwise we must + # create a new copy to modify: this is "copy on write". + + label doWrite "do.write" + set oldValuePtr [my Call var.value $varPtr] + SetValueName $oldValuePtr "oldValuePtr" + my condBr [my and [my neq [my and $flags $LIST_ELEMENT] $0] \ + [my eq [my and $flags $APPEND_VALUE] $0]] \ + $clearValue $checkAppend + label clearValue "clear.value" + my Call var.value.set $varPtr [my null Tcl_Obj*] + my br $checkAppend + label checkAppend "check.append" + my condBr [my neq $0 \ + [my and $flags [my or $APPEND_VALUE $LIST_ELEMENT]]] \ + $setByAppend $setDirect + label setByAppend "set.by.append" + my condBr [my neq [my and $flags $LIST_ELEMENT] $0] \ + $setByAppendElement $setByAppendString + label setByAppendElement "set.by.append.element" + my condBr [my Call set.by.append.element $interp $varPtr \ + $oldValuePtr $newValuePtr] \ + $testWriteTraces $earlyError + label setByAppendString "set.by.append.string" + my Call set.by.append.string $varPtr $oldValuePtr $newValuePtr + my br $testWriteTraces + label setDirect "set.direct" + my Call set.direct $varPtr $oldValuePtr $newValuePtr + my br $testWriteTraces + + # Invoke any write traces for the variable. + + label testWriteTraces "test" + my condBr [my Call var.isTraced.write $varPtr] \ + $callWriteTraces $test7 + label test7 "test" + my condBr [my nonnull $arrayPtr] \ + $test8 $testFastReturn + label test8 "test" + my condBr [my Call var.isTraced.write $arrayPtr] \ + $callWriteTraces $testFastReturn + label callWriteTraces "call.write.traces" + set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \ + [$api Tcl_GetString $part1Ptr] \ + [my Call tcl.getornull $part2Ptr] \ + [my or [my and $flags $NSGLBL] $TRACED_WRITES] \ + [my and $flags $LEAVE_ERR_MSG]] + my condBr [my expect [my eq $code $0] true] \ + $testFastReturn $cleanup + + # Return the variable's value unless the variable was changed + # in some gross way by a trace (e.g. it was unset and then + # recreated as an array). + + label testFastReturn "test" + my condBr [my expect [my Call var.isScalar $varPtr] true] \ + $test9 $slowReturn + label test9 "test" + my condBr [my expect [my Call var.defined $varPtr] true] \ + $fastReturn $slowReturn + label fastReturn "fast.return" + my ret [my Call var.value $varPtr] + + # A trace changed the value in some gross way. Return an empty + # string object. + + label slowReturn "slow.return" + set resultPtr [my dereference $interp 0 Interp.emptyObjPtr] + my br $cleanup + + # Report problems when a variable is in the process of being + # deleted or when it is really an array. + + label deadHash "test.dead.hash" + my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \ + $earlyError $test10 + label test10 "test" + my condBr [my Call var.isArrayElement $varPtr] \ + $deadHashElem $deadHashVar + label deadHashElem "dead.hash.danglingElement" + set msg1 [my constString "upvar refers to element in deleted array" "danglingElement"] + $api Tcl_SetObjErrorCode $interp \ + [$api obj.constant {TCL LOOKUP ELEMENT}] + my br $reportError + label deadHashVar "dead.hash.danglingVariable" + set msg2 [my constString "upvar refers to variable in deleted namespace" "danglingVar"] + $api Tcl_SetObjErrorCode $interp \ + [$api obj.constant {TCL LOOKUP VARNAME}] + my br $reportError + label setArray: + my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \ + $earlyError $setArrayError + label setArrayError "setArray.error" + set msg3 [my constString "variable is array" "isArray"] + $api Tcl_SetObjErrorCode $interp \ + [$api obj.constant {TCL WRITE ARRAY}] + my br $reportError + label reportError "report.error" + set origins [list $deadHashElem $deadHashVar $setArrayError] + set msg [my phi [list $msg1 $msg2 $msg3] $origins "msg"] + $api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \ + [my Call tcl.getornull $part2Ptr] \ + [my constString "set"] $msg + my br $earlyError + + # Standard route for reporting problems prior to the set + # actually happening. + + label earlyError "early.error" + my condBr $cleanupOnEarlyError \ + $earlyErrorDropRef $earlyErrorDone + label earlyErrorDropRef "early.error.dropReference" + $api Tcl_DecrRefCount $newValuePtr + my br $earlyErrorDone + label earlyErrorDone "early.error.done" + my br $cleanup + + # If the variable doesn't exist anymore and no-one's using it, + # then free up the relevant structures and hash table entries. + + label cleanup: + set values [list $nullResultPtr $resultPtr $nullResultPtr] + set origins [list $callWriteTraces $slowReturn $earlyErrorDone] + set resultPtr [my phi $values $origins "resultPtr"] + my condBr [my nonnull $resultPtr] \ + $cleanupErrorCode $test11 + label cleanupErrorCode "cleanup.errorCode" + $api Tcl_SetObjErrorCode $interp \ + [$api obj.constant {TCL WRITE VARNAME}] + my br $test11 + label test11 "test" + my condBr [my Call var.defined $varPtr] \ + $cleanupDone $cleanupVar + label cleanupVar "cleanup.var" + $api TclCleanupVar $varPtr $arrayPtr + my br $cleanupDone + label cleanupDone "cleanup.done" + my ret $resultPtr + } + } + + ##### Function var.deleteSearches ##### + # + # Replica of DeleteSearches. + + set f [$m local var.deleteSearches void<-Interp*,Var*] + params interp varPtr + build { + nonnull $interp + my condBr [my nonnull $varPtr] $testBit $done + label testBit + my condBr [my Call var.hasSearch $varPtr] $deleteSearches $done + label deleteSearches "delete.searches" + set tablePtr [my gep $interp 0 Interp.varSearches] + set sPtr [$api TclFindHashEntry $tablePtr $varPtr] + SetValueName $sPtr "sPtr" + set store [my alloc ArraySearch*] + set value [$api Tcl_GetHashValue $sPtr ArraySearch*] + SetValueName $value "searchPtr" + my store $value $store + my br $loopTest + label loopTest "loop.test" + set search [my load $store "searchPtr"] + my condBr [my nonnull $search] $loopBody $loopDone + label loopBody "loop.body" + my store [my dereference $search 0 ArraySearch.nextPtr] $store + $api Tcl_DecrRefCount [my dereference $search 0 ArraySearch.name] + $api ckfree $search + my br $loopTest + label loopDone "loop.done" + my Call var.flag.clear $varPtr $SEARCH_ACTIVE + $api Tcl_DeleteHashEntry $sPtr + my br $done + label done: + my ret + } + + ##### Function var.eventuallyFreeTrace ##### + # + # Wrapper round Tcl_EventuallyFree to coerce types right. + + set f [$m local var.eventuallyFreeTrace void<-VarTrace*] + params trace + build { + nonnull $trace + set TCL_DYNAMIC [my castInt2Ptr [Const 3] func{void<-void*}*] + $api Tcl_EventuallyFree [my cast(ptr) $trace char] $TCL_DYNAMIC + my ret + } + + ##### Function tcl.unset.var.array ##### + # + # Replica of DeleteArray, except without index parameter. + + set f [$m local tcl.unset.var.array void<-Interp*,Tcl_Obj*,Var*,int] + params interp part1Ptr varPtr flags + build { + nonnull $interp $part1Ptr $varPtr + noalias $interp $part1Ptr $varPtr + my Call var.deleteSearches $interp $varPtr + set search [my alloc HashSearch "search"] + set elPtr [my alloc Var* "elPtr"] + my store [my Call var.hash.firstVar \ + [my Call var.table $varPtr] $search] $elPtr + my br $loopTest + label loopTest "loop.test" + set element [my load $elPtr "element"] + my condBr [my nonnull $element] $loopBody $loopDone + label loopBody "loop.body" + my condBr [my and [my Call var.isScalar $element] \ + [my Call var.defined $element]] \ + $clearContents $considerTraces + label clearContents "clear.element.contents" + $api Tcl_DecrRefCount [my Call var.value $element] + my Call var.value.set $element [my null Tcl_Obj*] + my br $considerTraces + + # Lie about the validity of the hashtable entry. In this way the + # variables will be deleted by VarHashDeleteTable. + + label considerTraces "consider.element.traces" + my Call var.hash.invalidateEntry $element + my condBr [my Call var.isTraced $element] \ + $handleTraces $clearElement + label handleTraces "handle.element.traces" + my condBr [my Call var.isTraced.unset $element] \ + $callTraces $squelchTraces + label callTraces "call.element.traces" + set elName [my Call var.hash.getKey $element] + my Call var.flag.clear $element $TRACE_ACTIVE + # NB: We know that elName is nonnull here + $api TclCallVarTraces $interp [my null Var*] $element \ + [$api Tcl_GetString $part1Ptr] \ + [$api Tcl_GetString $elName] \ + $flags $0 + my br $squelchTraces + label squelchTraces "squelch.element.traces" + set varTraces [my gep $interp 0 Interp.varTraces] + set tPtr [$api TclFindHashEntry $varTraces $element] + SetValueName $tPtr "tPtr" + set tracePtr [my alloc VarTrace* "tracePtr"] + set value [$api Tcl_GetHashValue $tPtr VarTrace*] + SetValueName $value "tracePtr" + my store $value $tracePtr + my br $squelchTracesTest + label squelchTracesTest "squelch.element.traces.test" + set trace [my load $tracePtr "trace"] + my condBr [my nonnull $trace] $squelchTracesBody $clearActives + label squelchTracesBody "squelch.element.traces.body" + my store [my dereference $trace 0 VarTrace.nextPtr] $tracePtr + my store [my null VarTrace*] [my gep $trace 0 VarTrace.nextPtr] + my Call var.eventuallyFreeTrace $trace + my br $squelchTracesTest + label clearActives "clear.element.traces.active" + $api Tcl_DeleteHashEntry $tPtr + my Call var.flag.clear $element $TRACED_ALL + set activePtr [my alloc ActiveVarTrace* "activePtr"] + my store [my dereference $interp 0 Interp.activeVarTracePtr] \ + $activePtr + my br $clearActivesTest + label clearActivesTest "clear.element.traces.active.test" + set active [my load $activePtr "active"] + my condBr [my nonnull $active] $clearActivesBody $clearElement + label clearActivesBody "clear.element.traces.active.body" + set tracedVar [my dereference $active 0 ActiveVarTrace.varPtr] + my condBr [my eq $tracedVar $element] \ + $clearActivesClear $clearActivesNext + label clearActivesClear "clear.element.traces.active.next" + my store [my null VarTrace*] \ + [my gep $active 0 ActiveVarTrace.nextTracePtr] + my br $clearActivesNext + label clearActivesNext "clear.element.traces.active.next" + my store [my dereference $active 0 ActiveVarTrace.nextPtr] \ + $activePtr + my br $clearActivesTest + label clearElement "clear.element" + my Call var.value.set.undefined $element + + # Even though array elements are not supposed to be namespace + # variables, some combinations of [upvar] and [variable] may + # create such beasts - see [Bug 604239]. This is necessary to + # avoid leaking the corresponding Var struct, and is otherwise + # harmless. + + my Call var.clearNamespaceVar $element + my br $loopNext + label loopNext "loop.next" + my store [my Call var.hash.nextVar $search] $elPtr + my br $loopTest + label loopDone "loop.done" + my Call var.hash.delete $varPtr + my ret + } + + ##### Function var.dispose.activetraces ##### + # + # Helper for tcl.unset.var.struct to make that code simpler. + + set f [$m local var.dispose.activetraces \ + void<-Interp*,Var*,VarTrace*] + params interp varPtr tracePtr + build { + nonnull $interp $varPtr + noalias $interp $varPtr $tracePtr + set store [my alloc VarTrace* "store"] + my store $tracePtr $store + my br $traceTest + label traceTest: + set trace [my load $store "trace"] + my condBr [my nonnull $trace] $traceBody $unlinkActive + label traceBody: + my store [my dereference $trace 0 VarTrace.nextPtr] $store + my store [my null VarTrace*] [my gep $trace 0 VarTrace.nextPtr] + my Call var.eventuallyFreeTrace $trace + my br $traceTest + + label unlinkActive: + set store [my alloc ActiveVarTrace* "store"] + my store [my dereference $interp 0 Interp.activeVarTracePtr] \ + $store + my br $activeTest + label activeTest: + set active [my load $store "activeTrace"] + my condBr [my nonnull $active] $activeBody $done + label activeBody: + set activeVar [my dereference $active 0 ActiveVarTrace.varPtr] + my condBr [my eq $activeVar $varPtr] $activeBody2 $activeNext + label activeBody2: + my store [my null VarTrace*] \ + [my gep $active 0 ActiveVarTrace.nextTracePtr] + my br $activeNext + label activeNext: + my store [my dereference $active 0 ActiveVarTrace.nextPtr] \ + $store + my br $activeTest + + label done: + my ret + } + + ##### Function tcl.unset.var.struct ##### + # + # Replica of UnsetVarStruct, except without index parameter. + + set f [$m local tcl.unset.var.struct \ + void<-Var*,Var*,Interp*,Tcl_Obj*,Tcl_Obj*,int] + params varPtr arrayPtr interp part1Ptr part2Ptr flags + build { + nonnull $varPtr $interp $part1Ptr + noalias $varPtr $interp + set dummyVar [my alloc Var "dummyVar"] + my br $ct1 + label ct1 "computing.traced" + set t [my Call var.isTraced $varPtr] + my condBr $t $ct4 $ct2 + label ct2 "check.array.for.traced" + my condBr [my nonnull $arrayPtr] \ + $ct3 $ct4 + label ct3 "check.array.for.traced" + set t2 [my Call var.isTraced.unset $arrayPtr] + my br $ct4 + label ct4 "computed.traced" + set sources [list $ct1 $ct2 $ct3] + set traced [my phi [list $t $t $t2] $sources "traced"] + + my Call var.deleteSearches $interp $arrayPtr + my Call var.deleteSearches $interp $varPtr + + # The code below is tricky, because of the possibility that a + # trace function might try to access a variable being deleted. To + # handle this situation gracefully, do things in three steps: + # 1. Copy the contents of the variable to a dummy variable + # structure, and mark the original Var structure as undefined. + # 2. Invoke traces and clean up the variable, using the dummy + # copy. + # 3. If at the end of this the original variable is still + # undefined and has no outstanding references, then delete it + # (but it could have gotten recreated by a trace). + + set dummy [my load $varPtr] + set dummy [my insert $dummy [my and [my not $ALL_HASH] \ + [my extract $dummy Var.flags]] Var.flags] + my store $dummy $dummyVar + my Call var.value.set.undefined $varPtr + + # Call trace functions for the variable being deleted. Then delete + # its traces. Be sure to abort any other traces for the variable + # that are still pending. Special tricks: + # 1. We need to increment varPtr's refCount around this: + # TclCallVarTraces will use dummyVar so it won't increment + # varPtr's refCount itself. + # 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to + # call unset traces even if other traces are pending. + + my condBr $traced $processTraces $clearValues + + label processTraces "process.traces" + set varTraces [my gep $interp 0 Interp.varTraces] + set traceActive [my alloc VarTrace*] + my store [my null VarTrace*] $traceActive + my condBr [my Call var.isTraced $dummyVar] \ + $removeUnsetTraces $callUnsetTraces + + # Transfer any existing traces on var, IF there are unset traces. + # Otherwise just delete them. + + label removeUnsetTraces "remove.original.traces" + set tPtr [$api TclFindHashEntry $varTraces $varPtr] + SetValueName $tPtr "tPtr" + set tracePtr [$api Tcl_GetHashValue $tPtr VarTrace*] + SetValueName $tracePtr "tracePtr" + my store $tracePtr $traceActive + my Call var.flag.clear $varPtr $TRACED_ALL + $api Tcl_DeleteHashEntry $tPtr + my condBr [my Call var.isTraced.unset $dummyVar] \ + $recreateUnsetTraces $callUnsetTracesCheck + label recreateUnsetTraces "recreate.unset.traces" + set tPtr [$api TclCreateHashEntry $varTraces $dummyVar] + SetValueName $tPtr "tPtr" + $api Tcl_SetHashValue $tPtr $tracePtr + my br $callUnsetTracesCheck + label callUnsetTracesCheck "call.unset.traces.check" + my condBr [my Call var.isTraced.unset $dummyVar] \ + $callUnsetTraces $callUnsetTracesCheck2 + label callUnsetTracesCheck2 "call.unset.traces.check" + my condBr [my nonnull $arrayPtr] \ + $callUnsetTracesCheck3 $disposeActiveTraces + label callUnsetTracesCheck3 "call.unset.traces.check" + my condBr [my Call var.isTraced.unset $arrayPtr] \ + $callUnsetTraces $disposeActiveTraces + label callUnsetTraces "call.unset.traces" + my Call var.flag.clear $dummyVar $TRACE_ACTIVE + $api TclCallVarTraces $interp $arrayPtr $dummyVar \ + [$api Tcl_GetString $part1Ptr] \ + [my Call tcl.getornull $part2Ptr] \ + [my or [my and $flags $NSGLBL] $TRACED_UNSETS] $0 + + # The traces that we just called may have triggered a change in + # the set of traces. If so, reload the traces to manipulate. + + my store [my null VarTrace*] $traceActive + my condBr [my Call var.isTraced $dummyVar] \ + $refetchActive $disposeActiveTraces + label refetchActive "refetch.active.trace" + set tPtr [$api TclFindHashEntry $varTraces $dummyVar] + SetValueName $tPtr "tPtr" + my condBr [my nonnull $tPtr] \ + $refetchActive2 $disposeActiveTraces + label refetchActive2 "refetch.active.trace" + set tracePtr [$api Tcl_GetHashValue $tPtr VarTrace*] + SetValueName $tracePtr "tracePtr" + my store $tracePtr $traceActive + $api Tcl_DeleteHashEntry $tPtr + my br $disposeActiveTraces + + label disposeActiveTraces "dispose.active.traces" + set tracePtr [my load $traceActive "tracePtr"] + my condBr [my nonnull $tracePtr] $disposeClear $clearValues + label disposeClear "dispose.active.traces.clear" + my Call var.dispose.activetraces $interp $varPtr $tracePtr + my Call var.flag.clear $dummyVar $TRACED_ALL + my br $clearValues + + label clearValues "clear.values" + my condBr [my and \ + [my Call var.isScalar $dummyVar] \ + [my Call var.defined $dummyVar]] \ + $clearScalar $clearArrayTest + label clearScalar "clear.scalar" + $api Tcl_DecrRefCount [my Call var.value $dummyVar] + my br $clearNsVar + label clearArrayTest "clear.array.test" + my condBr [my Call var.isArray $dummyVar] \ + $clearArray $clearLinkTest + label clearArray "clear.array" + # If the variable is an array, delete all of its elements. This + # must be done after calling and deleting the traces on the array, + # above (that's the way traces are defined). If the array name is + # not present and is required for a trace on some element, it will + # be computed at DeleteArray. + + my Call tcl.unset.var.array $interp $part1Ptr $dummyVar \ + [my or [my and $flags $NSGLBL] $TRACED_UNSETS] + my br $clearNsVar + label clearLinkTest "clear.link.test" + my condBr [my Call var.isLink $dummyVar] \ + $clearLink $clearNsVar + label clearLink "clear.link" + # For global/upvar variables referenced in procedures, decrement + # the reference count on the variable referred to, and free the + # referenced variable if it's no longer needed. + + set linked [my Call var.link $dummyVar] + SetValueName $linked "linkedVarPtr" + my condBr [my Call var.isInHash $linked] \ + $cleanLinked $clearNsVar + label cleanLinked "clean.linked.variable" + set rcref [my Call var.hash.refCount $linked] + my store [my sub [my load $rcref] $1] $rcref + $api TclCleanupVar $linked [my null Var*] + my br $clearNsVar + + # If the variable was a namespace variable, decrement its + # reference count. + + label clearNsVar "clear.namespace.var" + my Call var.clearNamespaceVar $varPtr + my ret + } + + ##### Function tcl.unset.var.ptr ##### + # + # Replica of TclPtrUnsetVar, except without index parameter. + + set f [$m local tcl.unset.var.ptr \ + int<-Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,int] + params interp varPtr arrayPtr part1Ptr part2Ptr flags + if {"TclPtrUnsetVar" in [info object methods $api -all]} { + build { + nonnull $interp $varPtr $part1Ptr + noalias $interp $varPtr + my ret [$api TclPtrUnsetVar \ + $interp $varPtr $arrayPtr $part1Ptr $part2Ptr $flags] + } + } else { + build { + nonnull $interp $varPtr $part1Ptr + noalias $interp $varPtr + set result [my select [my Call var.defined $varPtr] $0 $1 "result"] + + # Keep the variable alive until we're done with it. We used to + # increase/decrease the refCount for each operation, making it + # hard to find [Bug 735335] - caused by unsetting the variable + # whose value was the variable's name. + + my condBr [my Call var.isInHash $varPtr] \ + $addRef $uvs + label addRef "add.reference" + set rcref [my Call var.hash.refCount $varPtr] + my store [my add [my load $rcref] $1] $rcref + my br $uvs + label uvs "unset.var.struct" + my Call tcl.unset.var.struct $varPtr $arrayPtr $interp \ + $part1Ptr $part2Ptr $flags + + # It's an error to unset an undefined variable. + + my condBr [my eq $result $0] \ + $finalCleanup $handleError + label handleError "handle.error" + my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \ + $finalCleanup $generateError + label generateError "generate.error" + set noSuchElement [my constString "no such element in array" \ + "noSuchElement"] + set noSuchVar [my constString "no such variable" "noSuchVar"] + set msg [my select [my nonnull $arrayPtr] \ + $noSuchElement $noSuchVar] + $api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \ + [my Call tcl.getornull $part2Ptr] \ + [my constString "unset"] $msg + $api Tcl_SetObjErrorCode $interp \ + [$api obj.constant {TCL UNSET VARNAME}] + my br $finalCleanup + + # Finally, if the variable is truly not in use then free up + # its Var structure and remove it from its hash table, if any. + # The ref count of its value object, if any, was decremented + # above. + + label finalCleanup "final.cleanup" + my condBr [my Call var.isInHash $varPtr] \ + $doCleanup $done + label doCleanup "cleanup" + set rcref [my Call var.hash.refCount $varPtr] + my store [my sub [my load $rcref] $1] $rcref + $api TclCleanupVar $varPtr $arrayPtr + my br $done + label done: + my ret $result + } + } + + ##### Function tcl.read.global.ns ##### + # + # Type signature: ns:NAMESPACE * varname:STRING * ecvar:int* + # -> STRING! + # + # Reads from a global (or other namespace) variable. + + set f [$m local tcl.read.global.ns STRING!<-Namespace*,STRING,int*] + params ns varname ecvar + build { + nonnull $ns $varname $ecvar + set interp [$api tclInterp] + set arrayPtr [my alloc Var*] + # save NS + set frameNsPtr [my gep \ + [my dereference $interp 0 Interp.varFramePtr] \ + 0 CallFrame.nsPtr] + set savedNs [my load $frameNsPtr "savedNs"] + my store $ns $frameNsPtr + set flags [my or [my or $NS_ONLY $LEAVE_ERR_MSG] $AVOID_RESOLVERS] + set var [$api TclObjLookupVar $interp $varname \ + [my null char*] $flags [my constString "access"] \ + $1 $1 $arrayPtr] + # restore NS + my store $savedNs $frameNsPtr + my condBr [my expect [my nonnull $var] true] \ + $gotVar $fail + label gotVar: + set result [my Call tcl.read.var.ptr $interp \ + $var [my null Var*] $varname [my null Tcl_Obj*] \ + $LEAVE_ERR_MSG] + my condBr [my expect [my nonnull $result] true] \ + $gotValue $fail + label gotValue: + my addReference(STRING) $result + my ret [my just $result] + label fail: + my store $1 $ecvar + my ret [my nothing STRING] + } + + ##### Function tcl.read.global ##### + # + # Type signature: nsname:STRING * varname:STRING * ecvar:int* + # -> STRING! + # + # Reads from a global (or other namespace) variable. + + set f [$m local tcl.read.global STRING!<-STRING,STRING,int*] + params nsname varname ecvar + build { + nonnull $nsname $varname $ecvar + set interp [$api tclInterp] + set nsptr [my alloc Namespace*] + set code [$api TclGetNamespaceFromObj $interp $nsname $nsptr] + my condBr [my expect [my eq $code $0] true] $gotNS $fail + label gotNS: + set ns [my load $nsptr] + my assume [my nonnull $ns] + my ret [my Call tcl.read.global.ns $ns $varname $ecvar] + label fail: + my store $1 $ecvar + my ret [my nothing STRING] + } + + ##### Function tcl.namespace.global ##### + # + # Type signature: void -> NAMESPACE + # + # Gets the handle to the global namespace. + + set f [$m local tcl.namespace.global Namespace*<-] + params + build { + set interp [$api tclInterp] + my ret [my dereference $interp 0 Interp.globalNsPtr] + } + + ##### Function tcl.namespace.current ##### + # + # Type signature: void -> NAMESPACE + # + # Gets the handle to the current namespace. + + set f [$m local tcl.namespace.current Namespace*<-] + params + build { + set interp [$api tclInterp] + set frame [my dereference $interp 0 Interp.varFramePtr] + my ret [my dereference $frame 0 CallFrame.nsPtr] + } + + ##### Function tcl.direct.append ##### + # + # Type signature: varname:STRING * value:STRING * ecvar:int* + # -> STRING? + # + # Append a value to the named variable and return the resulting value. + + set f [$m local tcl.direct.append STRING?<-STRING,STRING,int*] + params varname value ecvar + build { + set interp [$api tclInterp] + set result [$api Tcl_ObjSetVar2 $interp $varname {} $value \ + [my or $APPEND_VALUE $LEAVE_ERR_MSG]] + my condBr [my nonnull $result] $ok $fail + label ok: + my addReference(STRING) $result + my ret [my ok $result] + label fail: + my store $1 $ecvar + my ret [my fail STRING] + } + + ##### Function tcl.direct.exists ##### + # + # Type signature: varname:STRING -> ZEROONE + # + # Test if the named variable exists (i.e. produces a value when read). + + set f [$m local tcl.direct.exists ZEROONE<-STRING] + params varname + build { + set interp [$api tclInterp] + set result [$api Tcl_ObjGetVar2 $interp $varname {} $0] + my ret [my nonnull $result] + } + + ##### Function tcl.direct.get ##### + # + # Type signature: varname:STRING * ecvar:int* -> STRING? + # + # Return the contents of the named variable. + + set f [$m local tcl.direct.get STRING?<-STRING,int*] + params varname ecvar + build { + set interp [$api tclInterp] + set result [$api \ + Tcl_ObjGetVar2 $interp $varname {} $LEAVE_ERR_MSG] + my condBr [my nonnull $result] $ok $fail + label ok: + my addReference(STRING) $result + my ret [my ok $result] + label fail: + my store $1 $ecvar + my ret [my fail STRING] + } + + ##### Function tcl.direct.lappend ##### + # + # Type signature: varname:STRING * value:STRING * ecvar:int* + # -> STRING? + # + # Append a value to the list in the named variable and return the + # resulting value. + + set f [$m local tcl.direct.lappend STRING?<-STRING,STRING,int*] + params varname value ecvar + build { + set interp [$api tclInterp] + set result [$api Tcl_ObjSetVar2 $interp $varname {} $value \ + [my or $LIST_ELEMENT $LEAVE_ERR_MSG]] + my condBr [my nonnull $result] $ok $fail + label ok: + my addReference(STRING) $result + my ret [my ok $result] + label fail: + my store $1 $ecvar + my ret [my fail STRING] + } + + ##### Function tcl.direct.set ##### + # + # Type signature: varname:STRING * value:STRING * ecvar:int* + # -> STRING? + # + # Set the value of the named variable and return the contents. + + set f [$m local tcl.direct.set STRING?<-STRING,STRING,int*] + params varname value ecvar + build { + set interp [$api tclInterp] + set result [$api Tcl_ObjSetVar2 $interp $varname {} $value \ + $LEAVE_ERR_MSG] + my condBr [my nonnull $result] $ok $fail + label ok: + my addReference(STRING) $result + my ret [my ok $result] + label fail: + my store $1 $ecvar + my ret [my fail STRING] + } + + ##### Function tcl.direct.unset ##### + # + # Type signature: varname:STRING * flag:INT * ecvar:int* -> bool? + # + # Remove the named variable and return if there was an error (the + # actual boolean value is unimportant). + + set f [$m local tcl.direct.unset bool?<-STRING,INT,int*] + params varname flag ecvar + build { + set interp [$api tclInterp] + set flag [my neq [my cast(int) [my getInt64 $flag]] $0 "flag"] + set result [$api Tcl_UnsetVar2 $interp \ + [$api Tcl_GetString $varname] {} \ + [my select $flag $LEAVE_ERR_MSG $0]] + my condBr [my eq $result $0] $ok $fail + label ok: + my ret [my ok [Const 0 bool]] + label fail: + my store $1 $ecvar + my ret [my fail bool] + } + } +} + +# Local Variables: +# mode: tcl +# fill-column: 78 +# auto-fill-function: nil +# buffer-file-coding-system: utf-8-unix +# End: Index: demo.tcl ================================================================== --- demo.tcl +++ demo.tcl @@ -389,10 +389,16 @@ } return $msg } proc errortest4a {x} { list [catch {errortest4 $x} msg] $msg +} +proc errortest4b {x} { + catch {errortest4 $x} msg opt + # regexp -all -inline -line -- {^.* line \d+\)$} [ + list [dict get $opt -errorinfo] [dict get $opt -during -errorinfo] + # ] } proc errortest5 {x} { catch {throw {FOO BAR} $x} a b list $a [dict get $b -errorcode] } @@ -420,10 +426,22 @@ } msg opt] dict unset opt -errorstack dict unset opt -errorinfo list $code $msg $opt } + +namespace eval returntest { + proc break-inner {} { + return -level 2 -code break + } + proc break-mid {} { + break-inner + } + proc break-outer {} { + list [catch { break-mid } msg] $msg + } +} proc dictest {d} { if {[dict exists $d foo]} { dict set d foofoo [dict get $d foo] return [dict unset d foo] @@ -1074,17 +1092,19 @@ variable ::vartest::n variable sum variable sumsq scan "0 0.0 0.0" "%d%g%g" n sum sumsq } - proc accum {x} { + proc accum {args} { variable ::vartest::n variable sum variable sumsq - incr n - set sum [expr {$sum + $x}] - set sumsq [expr {$sumsq + $x * $x}] + foreach x $args { + incr n + set sum [expr {$sum + $x}] + set sumsq [expr {$sumsq + $x * $x}] + } } proc summarize {} { variable ::vartest::n variable sum variable sumsq @@ -1094,19 +1114,260 @@ list count $n sum $sum sumsq $sumsq mean [expr {$sum / $n}] \ stdev [expr {sqrt($n*$sumsq - $sum*$sum)/$n}] } proc check {} { init - foreach v { - 1 2 2 2 2 3 3 3 3 3 3 4 4 4 4 5 - } { - accum $v + accum 1 2 3 4 5 + accum 2 3 4 + accum 2 3 4 + accum 2 3 4 + accum 3 + accum 3 + summarize + } + + proc throw {} { + return -code error -errorcode CORRECT "TEST" + } + + proc throwcheck {} { + global errorCode + set errorCode "INCORRECT" + list [catch {throw} result] $result $errorCode + } +} + +namespace eval ::nsvartest { + + proc init {} { + namespace upvar ::nsvartest n n sum sum sumsq sumsq + scan "0 0.0 0.0" "%d%g%g" n sum sumsq + } + proc accum {args} { + namespace upvar ::nsvartest n n sum sum sumsq sumsq + foreach x $args { + incr n + set sum [expr {$sum + $x}] + set sumsq [expr {$sumsq + $x * $x}] + } + } + proc summarize {} { + namespace upvar ::nsvartest n count sum sum sumsq sumsq + if {$count < 2} { + error "too few data points" + } + list count $count sum $sum sumsq $sumsq mean [expr {$sum / $count}] \ + stdev [expr {sqrt($count*$sumsq - $sum*$sum)/$count}] + } + proc check {} { + init + accum 1 2 3 4 5 + accum 2 3 4 + accum 2 3 4 + accum 2 3 4 + accum 3 + accum 3 + summarize + } +} + +namespace eval ::directtest { + proc init {} { + set ::directtest::n 0 + scan "0.0 0.0" "%g%g" ::directtest::sum ::directtest::sumsq + } + proc accum {args} { + foreach x $args { + incr ::directtest::n + set ::directtest::sum [expr {$::directtest::sum + $x}] + set ::directtest::sumsq [expr {$::directtest::sumsq + $x * $x}] + } + } + proc summarize {} { + set count $::directtest::n + if {$count < 2} { + error "too few data points" + } + set n0 [info exists ::directtest::n] + unset ::directtest::n + append n0 [info exists ::directtest::n] + list $n0 count $count sum $::directtest::sum sumsq $::directtest::sumsq mean [expr {$::directtest::sum / $count}] \ + stdev [expr {sqrt($count*$::directtest::sumsq - $::directtest::sum**2)/$count}] + } + proc check {} { + init + accum 1 2 3 4 5 + accum 2 3 4 + accum 2 3 4 + accum 2 3 4 + accum 3 + accum 3 + summarize + } +} + +proc UpVar0Caller {} { + # This procedure should NOT be compiled + set z 0 + upvar0 z + return $z +} +proc upvar0 {x} { + upvar 1 $x y + set y 1 +} +proc upvar0a {} { + set a 0 + upvar0 a + return $a +} + +namespace eval ::upvartest0 { + + proc init {} { + upvar 1 n n sum sum sumsq sumsq + scan "0 0.0 0.0" "%d%g%g" n sum sumsq + } + proc accum {args} { + upvar 1 n n sum sum sumsq sumsq + foreach x $args { + incr n + set sum [expr {$sum + $x}] + set sumsq [expr {$sumsq + $x * $x}] + } + } + proc summarize {} { + upvar 1 n count sum sum sumsq sumsq + if {$count < 2} { + error "too few data points" } + list count $count sum $sum sumsq $sumsq mean [expr {$sum / $count}] \ + stdev [expr {sqrt($count*$sumsq - $sum*$sum)/$count}] + } + proc check1 {} { + lassign {0 0 0} n sum sumsq + init + accum 1 2 3 4 5 + accum 2 3 4 + accum 2 3 4 + accum 2 3 4 + accum 3 + accum 3 + summarize + } + proc check2 {} { + # variables not yet known at bytecode compile time but will be + # discovered in quadcode compilation. Should be retroactively + # assigned slots in the callframe (this will be needed for + # inlining). + + init + accum 1 2 3 4 5 + accum 2 3 4 + accum 2 3 4 + accum 2 3 4 + accum 3 + accum 3 summarize } } - + +namespace eval ::upvartest1 { + + proc init {nv sumv sumsqv} { + upvar 1 $nv n $sumv sum $sumsqv sumsq + scan "0 0.0 0.0" "%d%g%g" n sum sumsq + } + proc accum {nv sumv sumsqv args} { + upvar 1 $nv n $sumv sum $sumsqv sumsq + foreach x $args { + incr n + set sum [expr {$sum + $x}] + set sumsq [expr {$sumsq + $x * $x}] + } + } + proc summarize {nv sumv sumsqv} { + upvar 1 $nv count $sumv sum $sumsqv sumsq + if {$count < 2} { + error "too few data points" + } + list count $count sum $sum sumsq $sumsq mean [expr {$sum / $count}] \ + stdev [expr {sqrt($count*$sumsq - $sum*$sum)/$count}] + } + proc check1 {} { + lassign {0 0 0} n sum sumsq + init n sum sumsq + accum n sum sumsq 1 2 3 4 5 + accum n sum sumsq 2 3 4 + accum n sum sumsq 2 3 4 + accum n sum sumsq 2 3 4 + accum n sum sumsq 3 + accum n sum sumsq 3 + summarize n sum sumsq + } + proc check2 {} { + # variables not yet known at bytecode compile time but will be + # discovered in quadcode compilation. Should be retroactively + # assigned slots in the callframe (this will be needed for + # inlining). + + init n sum sumsq + accum n sum sumsq 1 2 3 4 5 + accum n sum sumsq 2 3 4 + accum n sum sumsq 2 3 4 + accum n sum sumsq 2 3 4 + accum n sum sumsq 3 + accum n sum sumsq 3 + summarize n sum sumsq + } +} + +namespace eval ::upvartest2 { + + proc test1a {} { + upvar #0 ::upvartest2::x a + set a 1 + } + proc test1 {} { + variable ::upvartest2::x + set x 0 + test1a + return $x + } + + proc test2a {} { + upvar 1 x a + set a 1 + } + proc test2 {} { + set x 0 + test2a + return $x + } + + proc test3a {v} { + upvar 1 $v a + set v 1 + } + proc test3 {} { + set x 0 + test3a x + return $x + } + + proc test4a {u v} { + upvar 1 $u$v a + set a 1 + } + proc test4 {} { + set pq 0 + test4a p q + return $pq + } + +} + namespace eval ::flightawarebench { # See https://github.com/flightaware/tclbench/blob/master/math/bench.tcl proc degrees_radians {degrees} { return [expr {$degrees * 3.14159265358979323846 / 180.0}] @@ -1184,11 +1445,11 @@ continue } set names [string trim [string range $line 0 \ [expr {[lindex $columnStarts 0]-1}]]] - + foreach name [info commands $names] { set name [namespace origin [namespace which -command $name]] set attrs {} foreach ky $keys st $columnStarts en $columnEnds { dict set attrs $ky [string trim [string range $line $st $en]] @@ -1200,20 +1461,108 @@ puts $g "Attribute combinations" dict for {ky lst} $haveAttr { puts $g "$ky: [dict keys $lst]" } close $g +} + +namespace eval ::hash { + variable F [file join [file dirname [info script]] wordlist.txt] + variable D [apply {{} { + variable F + variable D + set f [open $F] + set D [read $f] + close $f + return $D + } ::hash}] + + proc H9fast {s {N 9}} { + variable n $N + Hfast $s + } + proc H9mid {s {N 9}} { + variable n $N + Hmid $s + } + proc H9slow {s {N 9}} { + variable n $N + Hslow $s + } + proc Hslow s { + variable n + foreach c [split $s ""] { + incr h [expr {[scan $c %c]*$n**[incr i]}] + } + expr {$h&0xFFFFFF} + } + proc Hmid s { + variable n + foreach c [split $s ""] { + scan $c %c ch + incr h [expr {$ch*$n**[incr i]}] + } + expr {$h&0xFFFFFF} + } + proc Hfast s { + variable n + binary scan $s cu* cs + foreach c $cs { + incr h [expr {$c*$n**[incr i]}] + } + expr {$h&0xFFFFFF} + } + + proc main {} { + variable n + variable D + set n_min_col 0 + set min_col Inf + set n 0 + + set results {} + + while {[incr n]<1000} { + set hash_map {} + + foreach word $D { + dict lappend hash_map [Hfast $word] $word + } + + set col 0 + dict for {hash words} $hash_map { + if {[llength $words] > 1} { + incr col [llength $words] + } + } + + if {$col < $min_col} { + set min_col $col + set n_min_col $n + } + + lappend results "n= $n\tCollisions= $col \t\t\tCurrent n_min= $n_min_col\tCurrent min_col=$min_col" + } + return [llength $results] + } + } # A simple helper that is not compiled, but rather just shortens code below proc cleanopt {script} { variable cleanopt set code [uplevel 1 [list catch $script cleanopt(msg) cleanopt(opt)]] set msg $cleanopt(msg) + set opt $cleanopt(opt) + if {[dict exists $opt -during]} { + dict set opt -during [lsort -stride 2 -dictionary -index 0 \ + [dict remove [dict get $opt -during] \ + -during -errorinfo -errorstack]] + } list $code $msg [lsort -stride 2 -dictionary -index 0 \ - [dict remove $cleanopt(opt) -errorstack -errorinfo]] + [dict remove $opt -errorinfo -errorstack]] } ######################################################################### # # List of demonstration scripts. Each of these will be executed before and @@ -1331,14 +1680,18 @@ {catch {errortest4 qwe}} {errortest4 qwerty} {errortest4a pqr} {errortest4a qwe} {errortest4a qwerty} + {errortest4b abc} {errortest5 abc} {errortest6 1} {errortest6 2} {errortest6 3} + {cleanopt {returntest::break-inner}} + {cleanopt {returntest::break-mid}} + {returntest::break-outer} {nextest1 0} {nextest1 1} {nextest2 0} {nextest2 1} {nextest3 0} @@ -1406,13 +1759,34 @@ # {flightawarebench::test 5 5 2} # {flightawarebench::clockscan 5 5 5} parseBuiltinsTxt::main vartest::check + vartest::throwcheck + nsvartest::check + directtest::check + + UpVar0Caller + upvar0a + # even the simplest uses of [upvar] throw an error without + # a message at runtime + upvartest0::check1 + upvartest0::check2 + upvartest1::check1 + upvartest1::check2 + upvartest2::test1 + upvartest2::test2 + upvartest2::test3 + upvartest2::test4 + + {hash::H9fast ultraantidisestablishmentarianistically} + {hash::H9mid ultraantidisestablishmentarianistically} + {hash::H9slow ultraantidisestablishmentarianistically} } set demos'slow' { {flightawarebench::test 5 5 2} + {llength [hash::main]} } ######################################################################### # # List of procedures to compile. These do not need to be fully-qualified; the @@ -1462,12 +1836,13 @@ returntest errortest1 errortest2 errortest2-caller errortest3 - errortest4 errortest4a + errortest4 errortest4a errortest4b errortest5 errortest6 + returntest::* # List operations (also see some [try] tests) listtest lrangetest listjoin1 listjoin2 listjoin3 @@ -1513,10 +1888,11 @@ nstest::nstest3 nstest::nstest4 # nstest::nstest5 NEEDS CALLFRAME SUPPORT nstest::nstest6 nstest::nstest7 + upvartest::* # Miscellaneous other tests bctest asmtest # Combined feature tests lcmRange @@ -1530,13 +1906,20 @@ bug-7c599d4029::* linesearch::colinear linesearch::sameline linesearch::getAllLines1 linesearch::getAllLines2 - # vartest::* + vartest::* + nsvartest::* + directtest::* + upvar0 + upvar0a + upvartest0::* + upvartest1::* + upvartest2::* flightawarebench::* - + hash::* } set toCompile'slow' { parseBuiltinsTxt::main } ADDED doc/20170704-upvar-notes.md Index: doc/20170704-upvar-notes.md ================================================================== --- /dev/null +++ doc/20170704-upvar-notes.md @@ -0,0 +1,210 @@ +# Notes on upvar handling in quadcode # + +**[2017-07-04]** These are just a few notes from __kbk__ on the handling +of _[upvar]_in compiled quadcode. They should not be taken as evidence +of final intent for the compiler, but rather as working notes groping +toward a solution. + +The tricky bit about handling the _[upvar]_ command in quadcode will +be assessing its effect on non-local variables. + +In an initial version, I think we can safely confine our efforts to +_[upvar 1]_ and _[upvar #0]_, since these two forms are by far the +most common. Moreover, it should be safe to restrict our attention to +the cases where the local variable name is constant, and the remote +variable name is either constant or passed as a parameter to the +current procedure. Very little sane code violates this constraint. +Most uses of _[upvar]_ are either to provide shorthand: + + upvar #0 some_very_long_and_perhaps_constructed_name local_name + +or else handle pass-by-name: + + upvar 1 $param_name local_name + +and these are the really important cases to get right. Nevertheless, +I think it's wise to explore what else we might be able to handle readily. + +## [upvar] to fixed stack levels ## + +_[upvar #0]_ is relatively easy: it's virtually the same thing as +_[namespace upvar ::]_. The variables that are referenced will always +be sought in the global namespace. The aliasing problems are no more +and no less than those for _[namespace upvar]_, of which _[global]_ is +a special case. + +_[upvar #0]_ in which the global variable name is not constant can be +treated as potentially aliasing anything. This is ugly, but not +catastrophig; in fact, by default, we treat any namespace variable as +potentially aliasing any other. + +_[upvar_ __#N__ _]_ in which the local variable name is non-constant +is probably not feasible at this stage of development. Without +information about what variables it may potentially alias, it's +unlikely that any generated code after its appearance will be any +better than interpreted code. + +_[upvar_ __#N__ _]_, with __N__>1, is probably infeasible at this +level of development. It requires a 'closed world' hypothesis in which +all calling contexts of the current procedure are known. + +The special case of _[upvar #1]_ to address 'coroutine-local' variables +might need to be addressed at some point. Beyond that, _[upvar_ __#N__ _]_, +with __N__>1, is generally regarded as poor practice in any case. + +## [upvar 0] ## + +_[upvar 0_ __A__ __B__ _]_ is actually a relatively nasty case. It +imposes the constraint that any assignment to __B__ will also change +the value of __A__, and vice versa. Unlike the (lack of) alias +analysis we have done so far, this is a relation that affects changes +to otherwise unsuspecting local variables, without an _invoke_ +operation intervening. + +As long as at least one variable name is constant, this is probably +feasible: + + 1. Before reading the variable with the constant name, make sure + that all its potential aliases are in the callframe. + + 2. Before writing the variable with the constant name, also make sure + that all its aliases are in the callframe. because of what will happen + with rule 3. + + 3. After writing the variable with the constant name, retrieve the values + of all potential aliases back out of the callframe. + +The usual store-load and load-store optimizations that we are already +doing will eliminate most useless data motion from these steps. + +This is a rather complicated thing to be doing around virtually every +quadcode instruction, until and unless we have better alias analysis, +so I'm reluctant to start down this road before we have a +better handle on aliasing. _[upvar 0]_ is sufficiently unusual that +I'm willing to defer it to now. + +## [upvar 1] ## + +What we have to track with _[upvar 1_ __A__ __B__ _]_ is the impact of +the procedure on the caller's local variables. The procedure will be +executed using an _invoke_ quadcode instruction, and there is +machinery already in the compiler front end for an invoked command to +assert what variables it modifies. + +The analysis of what variables a procedure modifies depends on its +data flow. We need at least to identify that __B__ is constant (and +refuse to compile if it is not, at least for now), and to identify +that __A__ is either constant or flows directly from a parameter. + +Once a variable __B__ is identified as the local variable of +_[uplevel]_, we will need to monitor loads and stores of it and all +its potential aliases (which is all non-local variables mentioned in +the procedure, until we have a better handle on aliasing). If any of +these is written, the the procedure will have to announce to the +caller that the variable __A__ has potentially been written. Likewise, +if any is read, the procedure will have to announce to the caller that +__A__ has potentially been read. + +Note that this announcement must include the names of namespace +variables as well as the names of variables in the caller's +callframe. This requirement comes from the fact that the caller may +also have local variables aliased to the same namespace variables, and +needs to spoil the values of the corresponding LLVM variables and pull +them back from the callframe. (I've a sneaking suspicion that I've +just found an oversight in the _[namespace variable]_ implementation, +but need to double-check. I may have been more farsighted than I +remember.) + +These requirements add up to tracking the following information about +each compiled procedure: + + * Names of namespace variables read - or a flag indicating that any + arbitrary namespace variable may be read. + + * Names of namespace variables written - or a flag indicating that + any arbitrary namespace variable may be written. + + * Argument indices that receive the names of local variables that + may be read, together with a list of constant names of additional + local variables that may be read. Alternatively, a flag indicating + that any arbitrary local variable may be read or written. + + * Argument indices that receive the names of local variables that + may be written, together with a list of constant names of additional + local variables that may be written. Alternatively, a flag indicating + that any arbitrary local variable may be read or written. + +For cases of [upvar 1] that cannot be analyzed, it is safe to indicate +that anything will be read or written. It will simply have the effect +that the callframe and all namespace variables must be kept up to date +across the _invoke_. + +For an initial implementation with 'maximally conservative' aliasing +assumptions, it is safe to assume that any procedure that touches a +non-local variable requires the entire state of all namespace +variables to be consistent before the _invoke_ (and after it, if the +non-local variable has been modified). + +## [upvar 2] and higher ## + +Here, we're moving into some pretty strange territory, where the ice +is getting quite thin. + +The only cases, apart from debugging interactors, where I've seen +_[upvar_ __N__ _]_, with __N__>2, are kludges where a private +procedure with a known call stack reaches up in the stack to avoid +passing a parameter by name through one or more intermediate calls. +These hacks are always fragile and surprising, and I don't intend to +go out of my way to support them. Instead, I propose that we not +handle this construct in compiled code at all until we start doing +procedure inlining. At that point, inline expansion will reduce the +_[upvar]_ to a local variable reference (or at worst an _[upvar 1]) in +what I believe to be all the cases that we actually care about. + +If inlining is impossible, for instance because the offending +_[upvar]_ is reaching upwards in a recursive nest of procedures, I'm +perfectly willing to say, let the programmer who does such things live +with the performance of interpreted code. + + +## Integrating all this stuff initially ## + +The right place to identify a procedure's affect on the caller's frame +is in the same pass where type analysis is being done. Just as with +changes to type analysis, changes to the set of affected variables +will require that dependent procedure be analyzed again. The +specializer is already capable of iterating this sort of analysis to +convergence. + +For an initial 'worst-first' implementation, I propose: + + 1. _[upvar #0]_ will be recognized as long as the local variable + name is constant. It will make the target variable an alias to + _some_ global variable, which are not distinguished at this phase. + Therefore, assignments to and loads from the global will require + that all potentially-aliased variables in the callframe be + kept in sync. + + 2. _[upvar 1]_ will be recognized as long as the local variable name + is constant. The local variable becomes an alias to some remote + variable. If the name of the remote variable is constant or flows + from the arguments, then the remote variable can be identified, + otherwise, any local or global variable could be the target. + Once again, any aliased variable is treated as possibly an alias of + any other. + +The result will be that the procedure has: + + 1. A list of parameter positions or variable names in the caller that + may be read, or an indication that the list cannot be determined. + + 2. A list of parameter positions or variable names in the caller + that may be written, or an indication that the list cannot be + determined. + + 3. A flag for whether invoking the procedure changes any global variable. + If this flag is set, all non-local variables in the callframe must + be reloaded after the call if they are live. + +This is enough information to compile the callframe operations surrounding +an _invoke_ pessimistically, and will be enough to get something working. ADDED doc/support-instructions.txt Index: doc/support-instructions.txt ================================================================== --- /dev/null +++ doc/support-instructions.txt @@ -0,0 +1,19 @@ +This is just a brief note to mention what some of the support +pseudo-instructions do. They always take their arguments as literals, and +the information is not used immediately but rather updates internal state +variables inside the code issuer that is used later to issue suitable +debugging and stack trace information. + +@debug-line {} {literal LINE-NUMBER} +----------------------------- +This is issued when the line number for the current command changes. Formally, +it is the first line number for the command. The line number is relative to +the overall file that the code was found in if that information is available +(depends on patchlevel of Tcl) and is otherwise relative to the start of the +procedure. + +@debug-script {} {literal SCRIPT-SOURCE} +-------------------------------- +This is issued when the current command changes, and informs the code issuer +what the source code for calling the command looked like, which is used for +generating stack trace information on error. ADDED doc/upvar-notes-20170704.md Index: doc/upvar-notes-20170704.md ================================================================== --- /dev/null +++ doc/upvar-notes-20170704.md @@ -0,0 +1,210 @@ +# Notes on upvar handling in quadcode # + +**[2017-07-04]** These are just a few notes from __kbk__ on the handling +of _[upvar]_in compiled quadcode. They should not be taken as evidence +of final intent for the compiler, but rather aw working notes groping +toward a solution. + +The tricky bit about handling the _[upvar]_ command in quadcode will +be assessing its effect on non-local variables. + +In an initial version, I think we can safely confine our efforts to +_[upvar 1]_ and _[upvar #0]_, since these two forms are by far the +most common. Moreover, it should be safe to restrict our attention to +the cases where the local variable name is constant, and the remote +variable name is either constant or passed as a parameter to the +current procedure. Very little sane code violates this constraint. +Most uses of _[upvar]_ are either to provide shorthand: + + upvar #0 some_very_long_and_perhaps_constructed_name local_name + +or else handle pass-by-name: + + upvar 1 $param_name local_name + +and these are the really important cases to get right. Nevertheless, +I think it's wise to explore what else we might be able to handle readily. + +## [upvar] to fixed stack levels ## + +_[upvar #0]_ is relatively easy: it's virtually the same thing as +_[namespace upvar ::]_. The variables that are referenced will always +be sought in the global namespace. The aliasing problems are no more +and no less than those for _[namespace upvar]_, of which _[global]_ is +a special case. + +_[upvar #0]_ in which the global variable name is not constant can be +treated as potentially aliasing anything. This is ugly, but not +catastrophig; in fact, by default, we treat any namespace variable as +potentially aliasing any other. + +_[upvar_ __#N__ _]_ in which the local variable name is non-constant +is probably not feasible at this stage of development. Without +information about what variables it may potentially alias, it's +unlikely that any generated code after its appearance will be any +better than interpreted code. + +_[upvar_ __#N__ _]_, with __N__>1, is probably infeasible at this +level of development. It requires a 'closed world' hypothesis in which +all calling contexts of the current procedure are known. + +The special case of _[upvar #1]_ to address 'coroutine-local' variables +might need to be addressed at some point. Beyond that, _[upvar_ __#N__ _]_, +with __N__>1, is generally regarded as poor practice in any case. + +## [upvar 0] ## + +_[upvar 0_ __A__ __B__ _]_ is actually a relatively nasty case. It +imposes the constraint that any assignment to __B__ will also change +the value of __A__, and vice versa. Unlike the (lack of) alias +analysis we have done so far, this is a relation that affects changes +to otherwise unsuspecting local variables, without an _invoke_ +operation intervening. + +As long as at least one variable name is constant, this is probably +feasible: + + 1. Before reading the variable with the constant name, make sure + that all its potential aliases are in the callframe. + + 2. Before writing the variable with the constant name, also make sure + that all its aliases are in the callframe. because of what will happen + with rule 3. + + 3. After writing the variable with the constant name, retrieve the values + of all potential aliases back out of the callframe. + +The usual store-load and load-store optimizations that we are already +doing will eliminate most useless data motion from these steps. + +This is a rather complicated thing to be doing around virtually every +quadcode instruction, until and unless we have better alias analysis, +so I'm reluctant to start down this road before we have a +better handle on aliasing. _[upvar 0]_ is sufficiently unusual that +I'm willing to defer it to now. + +## [upvar 1] ## + +What we have to track with _[upvar 1_ __A__ __B__ _]_ is the impact of +the procedure on the caller's local variables. The procedure will be +executed using an _invoke_ quadcode instruction, and there is +machinery already in the compiler front end for an invoked command to +assert what variables it modifies. + +The analysis of what variables a procedure modifies depends on its +data flow. We need at least to identify that __B__ is constant (and +refuse to compile if it is not, at least for now), and to identify +that __A__ is either constant or flows directly from a parameter. + +Once a variable __B__ is identified as the local variable of +_[uplevel]_, we will need to monitor loads and stores of it and all +its potential aliases (which is all non-local variables mentioned in +the procedure, until we have a better handle on aliasing). If any of +these is written, the the procedure will have to announce to the +caller that the variable __A__ has potentially been written. Likewise, +if any is read, the procedure will have to announce to the caller that +__A__ has potentially been read. + +Note that this announcement must include the names of namespace +variables as well as the names of variables in the caller's +callframe. This requirement comes from the fact that the caller may +also have local variables aliased to the same namespace variables, and +needs to spoil the values of the corresponding LLVM variables and pull +them back from the callframe. (I've a sneaking suspicion that I've +just found an oversight in the _[namespace variable]_ implementation, +but need to double-check. I may have been more farsighted than I +remember.) + +These requirements add up to tracking the following information about +each compiled procedure: + + * Names of namespace variables read - or a flag indicating that any + arbitrary namespace variable may be read. + + * Names of namespace variables written - or a flag indicating that + any arbitrary namespace variable may be written. + + * Argument indices that receive the names of local variables that + may be read, together with a list of constant names of additional + local variables that may be read. Alternatively, a flag indicating + that any arbitrary local variable may be read or written. + + * Argument indices that receive the names of local variables that + may be written, together with a list of constant names of additional + local variables that may be written. Alternatively, a flag indicating + that any arbitrary local variable may be read or written. + +For cases of [upvar 1] that cannot be analyzed, it is safe to indicate +that anything will be read or written. It will simply have the effect +that the callframe and all namespace variables must be kept up to date +across the _invoke_. + +For an initial implementation with 'maximally conservative' aliasing +assumptions, it is safe to assume that any procedure that touches a +non-local variable requires the entire state of all namespace +variables to be consistent before the _invoke_ (and after it, if the +non-local variable has been modified). + +## [upvar 2] and higher ## + +Here, we're moving into some pretty strange territory, where the ice +is getting quite thin. + +The only cases, apart from debugging interactors, where I've seen +_[upvar_ __N__ _]_, with __N__>2, are kludges where a private +procedure with a known call stack reaches up in the stack to avoid +passing a parameter by name through one or more intermediate calls. +These hacks are always fragile and surprising, and I don't intend to +go out of my way to support them. Instead, I propose that we not +handle this construct in compiled code at all until we start doing +procedure inlining. At that point, inline expansion will reduce the +_[upvar]_ to a local variable reference (or at worst an _[upvar 1]) in +what I believe to be all the cases that we actually care about. + +If inlining is impossible, for instance because the offending +_[upvar]_ is reaching upwards in a recursive nest of procedures, I'm +perfectly willing to say, let the programmer who does such things live +with the performance of interpreted code. + + +## Integrating all this stuff initially ## + +The right place to identify a procedure's affect on the caller's frame +is in the same pass where type analysis is being done. Just as with +changes to type analysis, changes to the set of affected variables +will require that dependent procedure be analyzed again. The +specializer is already capable of iterating this sort of analysis to +convergence. + +For an initial 'worst-first' implementation, I propose: + + 1. _[upvar #0]_ will be recognized as long as the local variable + name is constant. It will make the target variable an alias to + _some_ global variable, which are not distinguished at this phase. + Therefore, assignments to and loads from the global will require + that all potentially-aliased variables in the callframe be + kept in sync. + + 2. _[upvar 1]_ will be recognized as long as the local variable name + is constant. The local variable becomes an alias to some remote + variable. If the name of the remote variable is constant or flows + from the arguments, then the remote variable can be identified, + otherwise, any local or global variable could be the target. + Once again, any aliased variable is treated as possibly an alias of + any other. + +The result will be that the procedure has: + + 1. A list of parameter positions or variable names in the caller that + may be read, or an indication that the list cannot be determined. + + 2. A list of parameter positions or variable names in the caller + that may be written, or an indication that the list cannot be + determined. + + 3. A flag for whether invoking the procedure changes any global variable. + If this flag is set, all non-local variables in the callframe must + be reloaded after the call if they are live. + +This is enough information to compile the callframe operations surrounding +an _invoke_ pessimistically, and will be enough to get something working. ADDED quadcode/aliases.tcl Index: quadcode/aliases.tcl ================================================================== --- /dev/null +++ quadcode/aliases.tcl @@ -0,0 +1,32 @@ +# aliases.tcl -- +# +# Rudimentary alias analysis for quadcode +# +# Copyright (c) 2017 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 may-alias -- +# +# Determines the set of variables that may alias a given variable +# in the program +# +# Parameters: +# v - Variable for which aliases are sought +# +# Results: +# Returns a list of variable names that may be aliases for $v + +oo::define quadcode::transformer method may-alias {v} { + + if {[dict exists $links $v]} { + set l2 $links + dict unset l2 $v + return [dict keys $l2] + } else { + return {} + } +} Index: quadcode/builtin_specials.tcl ================================================================== --- quadcode/builtin_specials.tcl +++ quadcode/builtin_specials.tcl @@ -8,72 +8,159 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ -# quadcode::specialiser method varreads___lsort -- +# quadcode::specialier method frameEffect___lsort -- # -# Determines the variables that are output from the 'lsort' -# command. +# Determines the stack frame effect of 'lsort' # # Parameters: -# q - The quadcode instruction that invokes the [lsort] +# q - The quadcode instruction that invokes 'lsort' # # Results: -# Returns a two-element list. If the first element of the -# list is 0, the [lsort] command acts on the callframe -# unpredictably. If the first element is 1, the list of -# variables input to the [lsort] command is known a priori, -# and the second element is the list of names. +# Returns the frame effect. + +oo::define quadcode::specializer method frameEffect___lsort {q} { -oo::define quadcode::specializer method varreads___lsort {q} { + # 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 {1 {}} + return {killable Inf noCallFrame {} pure {}} } - + # 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" + +} + +# quadcode::specializer method frameEffect___regexp -- +# +# Determines the callframe effect of the [regexp] command +# +# Parameters: +# q - The quadcode instruction that invokes 'regexp' +# +# Results: +# Returns the frame effect. + +oo::define quadcode::specializer method frameEffect___regexp {q} { + # 0 - 'invoke' + # 1 - result callframe + # 2 - input callframe + # 3 - ::regexp + # 4+ - remaining args + + # Skip over the command line switches + + set ind 4 + while {$ind < [llength $q] - 2} { + if {[lindex $q $ind 0] ne "literal"} { + return {writes 0} + } + switch -exact -- [lindex $q $ind 1] { + -about - + -expanded - + -indices - + -line - + -linestop - + -lineanchor - + -nocase - + -all - + -inline { + incr ind + } + -start { + incr ind 2 + } + -- { + incr ind + break + } + default { + break + } + } + } + + # After the switches come needle and haystack + + incr ind 2 + + # Anything remaining on the line must be a match variable + + if {$ind < [llength $q]} { + return {killable Inf noCallFrame {} pure {}} + } else { + return [list writes [expr {3-$ind}]] + } + } -# quadcode::specialiser method varwrites___lsort -- +# quadcode::specializer method frameEffect___regsub -- # -# Determines the variables that are output from the 'lsort' -# command. +# Determines the callframe effect of the [regsub] command # # Parameters: -# q - The quadcode instruction that invokes the [lsort] +# q - The quadcode instruction that invokes 'regsub' # # Results: -# Returns a two-element list. If the first element of the -# list is 0, the [lsort] command acts on the callframe -# unpredictably. If the first element is 1, the list of -# variables output from the [lsort] command is known a priori, -# and the second element is the list of names. - -oo::define quadcode::specializer method varwrites___lsort {q} { - - # Only [lsort -command] might use callframe data - - lassign [my parse___lsort $q] usesCommand command - if {!$usesCommand} { - return {1 {}} - } - - # 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" +# Returns the frame effect. + +oo::define quadcode::specializer method frameEffect___regsub {q} { + + # 0 - 'invoke' + # 1 - result callframe + # 2 - input callframe + # 3 - ::regsub + # 4+ - remaining args + + # Skip over the command line switches + + set ind 4 + while {$ind < [llength $q]} { + if {[lindex $q $ind 0] ne "literal"} { + if {$ind + 3 == [llength $q]} { + return {killable Inf noCallFrame {} pure {}} + } else { + return [dict create writes $ind] + } + } + switch -exact -- [lindex $q $ind 1] { + -all - + -expanded - + -line - + -linestop - + -lineanchor - + -nocase - + -all { + incr ind + } + -start { + incr ind 2 + } + -- { + incr ind + break + } + default { + break + } + } + } + + # After the switches come needle, haystack and replacement. + # Anything remaining on the line must be a match variable + + return [dict create writes [expr {-$ind}]] } # quadcode::specializer method parse___lsort -- # @@ -120,186 +207,6 @@ incr ind } } } return {0 {}} -} - -# quadcode::specializer method varreads___regexp -- -# -# Determines the variables that are output from the 'regexp' -# command. -# -# Parameters: -# q - The quadcode instruction that invokes the [regexp] -# -# Results: -# Returns {1 {}} always - the [regexp] command reads no variables -# in the caller's frame. - -oo::define quadcode::specializer method varreads___regexp {q} { - return {1 {}} -} - -# quadcode::specializer method varwrites___regexp -- -# -# Determines the variables that are output from the 'regexp' -# command. -# -# Parameters: -# q - The quadcode instruction that invokes the [regexp] -# -# Results: -# Returns a two-element list. If the first element of the -# list is 0, the [regexp] command acts on the callframe -# unpredictably. If the first element is 1, the list of -# variables output from the [regexp] command is known a priori, -# and the second element is the list of names. - -oo::define quadcode::specializer method varwrites___regexp {q} { - - # 0 - 'invoke' - # 1 - result callframe - # 2 - input callframe - # 3 - ::regexp - # 4+ - remaining args - - # Skip over the command line switches - - set ind 4 - while {$ind < [llength $q] - 2} { - if {[lindex $q $ind 0] ne "literal"} { - return {0 {}} - } - switch -exact -- [lindex $q $ind 1] { - -about - - -expanded - - -indices - - -line - - -linestop - - -lineanchor - - -nocase - - -all - - -inline { - incr ind - } - -start { - incr ind 2 - } - -- { - incr ind - break - } - default { - break - } - } - } - - # After the switches come needle and haystack - - incr ind 2 - - # Anything remaining on the line must be a match variable - - set varsWritten {} - foreach matchVar [lrange $q $ind end] { - if {[lindex $matchVar 0] eq "literal"} { - lappend varsWritten [lindex $matchVar 1] - } else { - return {0 {}} - } - } - return [list 1 $varsWritten] - -} - -# quadcode::specializer method varreads___regsub -- -# -# Determines the variables that are output from the 'regsub' -# command. -# -# Parameters: -# q - The quadcode instruction that invokes the [regsub] -# -# Results: -# Returns {1 {}} always - the [regsub] command reads no variables -# in the caller's frame. - -oo::define quadcode::specializer method varreads___regsub {q} { - return {1 {}} -} - -# quadcode::specializer method varwrites___regsub -- -# -# Determines the variables that are output from the 'regsub' -# command. -# -# Parameters: -# q - The quadcode instruction that invokes the [regsub] -# -# Results: -# Returns a two-element list. If the first element of the -# list is 0, the [regsub] command acts on the callframe -# unpredictably. If the first element is 1, the list of -# variables output from the [regsub] command is known a priori, -# and the second element is the list of names. - -oo::define quadcode::specializer method varwrites___regsub {q} { - - # 0 - 'invoke' - # 1 - result callframe - # 2 - input callframe - # 3 - ::regsub - # 4+ - remaining args - - # Skip over the command line switches - - set ind 4 - while {$ind < [llength $q]} { - if {[lindex $q $ind 0] ne "literal"} { - if {$ind + 3 == [llength $q]} { - return {1 {}} - } elseif {[lindex $q end 0] eq "literal"} { - return [list 1 [list [lindex $q end 1]]] - } else { - return {0 {}} - } - } - switch -exact -- [lindex $q $ind 1] { - -all - - -expanded - - -line - - -linestop - - -lineanchor - - -nocase - - -all { - incr ind - } - -start { - incr ind 2 - } - -- { - incr ind - break - } - default { - break - } - } - } - - # After the switches come needle, haystack and replacement. - # Anything remaining on the line must be a match variable - - incr ind 3 - set varsWritten {} - foreach matchVar [lrange $q $ind end] { - if {[lindex $matchVar 0] eq "literal"} { - lappend varsWritten [lindex $matchVar 1] - } else { - return {0 {}} - } - } - return [list 1 $varsWritten] - } Index: quadcode/builtins.tcl ================================================================== --- quadcode/builtins.tcl +++ quadcode/builtins.tcl @@ -1,6 +1,12 @@ -# builtins.tcl -- +# CREATED BY parseBuiltinsTxt.tcl, DO NOT EDIT +# +#----------------------------------------------------------------------------- +# +#----------------------------------------------------------------------------- +# +# builtins.tcl.in -- # # Description of the callframe effects of Tcl built-in commands # # Copyright (c) 2017 by Kevin B. Kenny # @@ -7,15 +13,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ -# This file was once created by running the script, 'parseBuiltinsTxt.tcl' -# over the file, 'builtins.txt', and as such was not intended for manual -# editing. It is now being maintained by hand and may be out of sync -# with 'builtins.txt'. - # quadcode::specializer method initBuiltins -- # # Initializes the table of callframe effects of the Tcl builtin # functions. # @@ -43,26 +44,43 @@ # on the command line. The value is a list of numbers. # Positive numbers are positions on the command line where # the variable names appear. A negative number like '-3' # means "all variables at and after objv[3]." A zero means # that all variables in the callframe are potentially read. -# special - The command must be parsed to determine what its -# callframe effects might be. The parse is done by -# a method, 'vars_writtenBy_${command} in the specializer. -# ${command} is the command being examined, with :: -# replaced by __. +# readsNonLocal - The value of this key is immaterial at present. +# The presence of the key indicates that the +# procedure may read variables at a stack level +# outward of the caller +# readsGlobal - The value of this key is immaterial at present. +# The presence of the key indicates that the +# procedure may read global or namespace variables. # writes - The command writes variables whose names are specified # on the command line. The value is a list of numbers. # Positive numbers are positions on the command line where # the variable names appear. A negative number like '-3' # means "all variables at and after objv[3]." A zero means # that all variables in the callframe are potentially written. +# writesNonLocal - The value of this key is immaterial at present. +# The presence of the key indicates that the +# procedure may write variables at a stack level +# outward of the caller +# writesGlobal - The value of this key is immaterial at present. +# The presence of the key indicates that the +# procedure may write global or namespace variables. +# special - The command must be parsed to determine what its +# callframe effects might be. The parse is done by +# a method, 'vars_writtenBy_${command} in the specializer. +# ${command} is the command being examined, with :: +# replaced by __. # # For the Tcl builtins, it is presumed that if all variables are # accounted for, the command will not depend on the callframe's being # present. - +# +# GENERATED CODE GOES HERE +# +#----------------------------------------------------------------------------- oo::define quadcode::specializer method initBuiltins {} { dict set cmdAttr ::after \ {noCallFrame {}} dict set cmdAttr ::cd \ [dict get $cmdAttr ::after] @@ -69,11 +87,11 @@ dict set cmdAttr ::clock \ {special {}} dict set cmdAttr ::close \ [dict get $cmdAttr ::after] dict set cmdAttr ::encoding \ - [dict get $cmdAttr ::clock] + [dict get $cmdAttr ::clock] dict set cmdAttr ::eof \ {killable Inf noCallFrame {}} dict set cmdAttr ::exit \ [dict get $cmdAttr ::after] dict set cmdAttr ::fblocked \ @@ -150,10 +168,16 @@ [dict get $cmdAttr ::eof] dict set cmdAttr ::open \ [dict get $cmdAttr ::after] dict set cmdAttr ::pid \ [dict get $cmdAttr ::join] + dict set cmdAttr ::platform::generic \ + [dict get $cmdAttr ::join] + dict set cmdAttr ::platform::identify \ + [dict get $cmdAttr ::join] + dict set cmdAttr ::platform::patterns \ + [dict get $cmdAttr ::join] dict set cmdAttr ::puts \ [dict get $cmdAttr ::after] dict set cmdAttr ::pwd \ [dict get $cmdAttr ::eof] dict set cmdAttr ::read \ @@ -223,13 +247,13 @@ dict set cmdAttr ::tcl::chan::tell \ [dict get $cmdAttr ::eof] dict set cmdAttr ::tcl::chan::truncate \ [dict get $cmdAttr ::after] dict set cmdAttr ::tcl::dict::keys \ - [dict get $cmdAttr ::join] + [dict get $cmdAttr ::join] dict set cmdAttr ::tcl::dict::values \ - [dict get $cmdAttr ::join] + [dict get $cmdAttr ::join] dict set cmdAttr ::tcl::file::atime \ [dict get $cmdAttr ::fconfigure] dict set cmdAttr ::tcl::file::attributes \ {killable 4 noCallFrame {}} dict set cmdAttr ::tcl::file::channels \ @@ -321,11 +345,11 @@ dict set cmdAttr ::tcl::info::library \ [dict get $cmdAttr ::join] dict set cmdAttr ::tcl::info::loaded \ [dict get $cmdAttr ::eof] dict set cmdAttr ::tcl::info::locals \ - {killable Inf reads 0} + {killable Inf reads -1} dict set cmdAttr ::tcl::info::nameofexecutable \ [dict get $cmdAttr ::join] dict set cmdAttr ::tcl::info::patchlevel \ [dict get $cmdAttr ::join] dict set cmdAttr ::tcl::info::procs \ ADDED quadcode/builtins.tcl.in Index: quadcode/builtins.tcl.in ================================================================== --- /dev/null +++ quadcode/builtins.tcl.in @@ -0,0 +1,77 @@ +#----------------------------------------------------------------------------- +# +# builtins.tcl.in -- +# +# Description of the callframe effects of Tcl built-in commands +# +# Copyright (c) 2017 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::specializer method initBuiltins -- +# +# Initializes the table of callframe effects of the Tcl builtin +# functions. +# +# The table, 'cmdAttr', is a two-level dictionary. The first key is a +# fully qualified and resolved command name. The second key (and the +# corresponding value) are as follows: +# +# killable - If this flag is present the value is an argument +# count. If the count of actual args on the +# command is less than the given count, then the +# invocation of the command may be removed from the +# program if nothing uses the result. Inf is legal +# for the count, and means that the command is always +# killable +# noCallFrame - If this key is present, then the command runs +# independently of the calling context and the +# caller need not have a callframe at all. The value +# is immaterial. +# pure - The command is free of side effects, and always returns +# the same result when called with the same arguments. +# This 'purity' or 'referential transparency' means that +# the command may be subjected to optimizations such as +# loop-invariant code motion. +# reads - The command reads variables whose names are specified +# on the command line. The value is a list of numbers. +# Positive numbers are positions on the command line where +# the variable names appear. A negative number like '-3' +# means "all variables at and after objv[3]." A zero means +# that all variables in the callframe are potentially read. +# readsNonLocal - The value of this key is immaterial at present. +# The presence of the key indicates that the +# procedure may read variables at a stack level +# outward of the caller +# readsGlobal - The value of this key is immaterial at present. +# The presence of the key indicates that the +# procedure may read global or namespace variables. +# writes - The command writes variables whose names are specified +# on the command line. The value is a list of numbers. +# Positive numbers are positions on the command line where +# the variable names appear. A negative number like '-3' +# means "all variables at and after objv[3]." A zero means +# that all variables in the callframe are potentially written. +# writesNonLocal - The value of this key is immaterial at present. +# The presence of the key indicates that the +# procedure may write variables at a stack level +# outward of the caller +# writesGlobal - The value of this key is immaterial at present. +# The presence of the key indicates that the +# procedure may write global or namespace variables. +# special - The command must be parsed to determine what its +# callframe effects might be. The parse is done by +# a method, 'vars_writtenBy_${command} in the specializer. +# ${command} is the command being examined, with :: +# replaced by __. +# +# For the Tcl builtins, it is presumed that if all variables are +# accounted for, the command will not depend on the callframe's being +# present. +# +# GENERATED CODE GOES HERE +# +#----------------------------------------------------------------------------- Index: quadcode/builtins.txt ================================================================== --- quadcode/builtins.txt +++ quadcode/builtins.txt @@ -27,10 +27,11 @@ 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 Index: quadcode/bytecode.tcl ================================================================== --- quadcode/bytecode.tcl +++ quadcode/bytecode.tcl @@ -437,11 +437,11 @@ dictIncrImm - dictUpdateStart - endCatch - evalStk - existArray - - exitStk - + existStk - exprStk - foreach_step - incrArray1Imm - incrScalar1 - incrScalarStkImm - Index: quadcode/callframe.tcl ================================================================== --- quadcode/callframe.tcl +++ quadcode/callframe.tcl @@ -7,10 +7,34 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ + +# quadcode::transformer method containsUpvar -- +# +# Quick and dirty approximation for whether a given procedure needs +# to have variables in the caller's frame in sync. +# +# Results: +# Returns 1 if the variables must be in sync, 0 if the procedure +# doesn't upvar. +# +# Bugs: +# If a called procedure does something like 'upvar 2', or in the +# presence of dynamically evaluated code, all bets are off, and this +# method will give the wrong answer. It's a stopgap that should be +# better than nothing. + +oo::define quadcode::transformer method containsUpvar {} { + foreach bb $bbcontent { + if {[lsearch -exact -index 0 $bb upvar] >= 0} { + return 1 + } + } + return 0 +} # quadcode::transformer method callframeMotion -- # # Adds callframe data motion for variables that may be links # by virtue of appearing in 'nsupvar', 'upvar' or 'variable' @@ -31,13 +55,20 @@ # will depend on global alias analysis, which we don't yet have. oo::define quadcode::transformer method callFrameMotion {} { my debug-callframe { - puts "Before callframeMoves:" + puts "Before callframeMotion:" my dump-bb + puts "Links: $links" } + + set catches {}; # Dictionary enumerating the places where + ; # errorInfo and errorCode must be spoilt + + # Walk through the basic blocks and insert any needed instructions + # before and after the blocks set b -1 foreach bb $bbcontent { incr b set newbb {} @@ -45,13 +76,51 @@ foreach q $bb { incr pc my callFrameMovesBefore $b $pc newbb $q lappend newbb $q my callFrameMovesAfter $b $pc newbb $q + if {[lindex $q 0] eq "jumpMaybe"} { + dict set catches [lindex $q 1 1] {} + my debug-callframe { + puts " [lindex $q 1] appears to be a catch block" + } + } } lset bbcontent $b $newbb } + + # Insert instructions to spoil ::errorCode and ::errorInfo after each + # catch. + + my debug-callframe { + puts "Clean up catch blocks:" + } + dict for {b -} $catches { + set newbb [list {startCatch {temp @callframe} {temp @callframe}}] + my debug-callframe { + puts "$b:0: [lindex $newbb 0]" + } + dict for {var -} $links { + set vname [lindex $var 1] + set newq [list moveFromCallFrame \ + $var {temp @callframe} \ + [list literal $vname]] + my debug-callframe { + puts "$b:[llength $newbb]: $newq" + } + lappend newbb $newq + } + set bb [lindex $bbcontent $b] + lset bbcontent $b {} + set bb [linsert $bb[set bb {}] 0 {*}$newbb] + lset bbcontent $b $bb + } + + my debug-callframe { + puts "After callframeMotion:" + my dump-bb + } } # quadcode::transformer method callFrameMovesBefore -- # # Inserts any data motion to and from the callframe required before @@ -95,22 +164,22 @@ # moved to the callframe because they are already there. This # optimization may have the effect of killing 'moveFromCallFrame' # instructions, which will be removed by the cleanup optimizations. oo::define quadcode::transformer method callFrameMovesBefore {b pc newbbv q} { - if {[lindex $q 0] in {"invoke" "load" "store"}} { + if {[lindex $q 0] in {"invoke"}} { # All variables are forced into the callframe before 'invoke', # 'load' and 'store'. Variables that cannot be accessed are # optimized away later. upvar 1 $newbbv newbb set newq {moveToCallFrame {temp @callframe} {temp @callframe}} foreach v $vars { - if {![dict exists $links $v]} { - lappend newq [list literal [lindex $v 1]] $v - } + lappend newq [list literal [lindex $v 1]] $v + # TODO - Store-store optimization is needed, to detect that + # $v is already in the callframe } my debug-callframe { puts " $newq" puts "inserted before" puts "$b:$pc: $q" @@ -162,66 +231,96 @@ oo::define quadcode::transformer method callFrameMovesAfter {b pc newbbv q} { switch -exact -- [lindex $q 0] { - "invoke" - "store" { - - # After 'invoke' or 'store', all variables are retrieved - # from the callframe. Variables that are not changed (either - # because an invoked proc doesn't reference them, or because - # they cannot alias the target of the 'store') are removed later. - upvar 1 $newbbv newbb - my debug-callframe { - puts "insert after" - puts "$b:$pc: $q" - } - foreach v $vars { - set newq [list moveFromCallFrame $v {temp @callframe} \ - [list literal [lindex $v 1]]] - my debug-callframe { - puts " $newq" - } - lappend newbb $newq - } - } - - "load" { - - # Loading from a variable has no effect on the callframe - lappend newbb $newq - - } - - "nsupvar" - "upvar" - "variable" { - - # After creating a new alias as a local variable, the - # value of the variable has to be retrieved from the - # callframe. - upvar 1 $newbbv newbb - my debug-callframe { - puts "insert after" - puts "$b:$pc: $q" - } - set litname [lindex $q 3] - set name [lindex $litname 1] - set newq [list moveFromCallFrame \ - [list var $name] {temp @callframe} $litname] - my debug-callframe { - puts " $newq" - } - lappend newbb $newq - } - + "invoke" - "nsupvar" - "upvar" - "variable" { + + # 'invoke', 'nsupvar', 'upvar', 'variable' are followed by + # 'extractCallFrame' and will be dealt with when the + # 'extractCallFrame' is encountered. + + } + + "extractCallFrame" { + + # Find the instruction that altered the callframe + + set sourceCF [lindex $q 2] + + set pc2 $pc + while {$pc2 > 0} { + incr pc2 -1 + set q2 [lindex $bbcontent $b $pc2] + if {[lindex $q2 1] eq $sourceCF} break + } + if {$pc2 < 0} { + error "cannot find source of callframe in $b:$pc: $q" + } + + switch -exact [lindex $q2 0] { + + "invoke" { + + # After 'invoke' or 'store', all variables are + # retrieved from the callframe. Variables that are + # not changed (either because an invoked proc + # doesn't reference them, or because they cannot + # alias the target of the 'store') are removed + # later. + + upvar 1 $newbbv newbb + my debug-callframe { + puts "insert after" + puts "$b:$pc: $q" + puts " (origin: $b:$pc2: $q2)" + } + foreach v $vars { + set newq [list moveFromCallFrame $v [lindex $q 1] \ + [list literal [lindex $v 1]]] + my debug-callframe { + puts " $newq" + } + lappend newbb $newq + } + } + + "nsupvar" - "upvar" - "variable" { + + # After creating a new alias as a local variable, the + # value of the variable has to be retrieved from the + # callframe. + upvar 1 $newbbv newbb + my debug-callframe { + puts "insert after" + puts "$b:$pc: $q" + puts " (origin: $b:$pc2: $q2)" + } + set litname [lindex $q2 3] + set name [lindex $litname 1] + set newq [list moveFromCallFrame \ + [list var $name] [lindex $q 1] $litname] + my debug-callframe { + puts " $newq" + } + lappend newbb $newq + } + } + } + default { # On any assignment, we move the result to the callframe, # then move anything that the result might alias back from # the callframe. We put a 'no op' in between so that code that # tracks the callframe content can find the correct values. - # + + # On a direct assignment, we also need to recover anything + # that might alias the direct variable + set tgt [lindex $q 1] + set needMovesFrom 0 if {[lindex $tgt 0] eq "var" && [dict exists $links $tgt]} { upvar 1 $newbbv newbb my debug-callframe { puts "insert after" @@ -228,19 +327,34 @@ puts "$b:$pc: $q" } set vname [lindex $tgt 1] set newq [list moveToCallFrame \ {temp @callframe} {temp @callframe} \ - [list literal $vname] [lindex $tgt 0]] - set newq2 [list callFrameNop \ - {temp @callframe} {temp @callframe} \ - [list literal $vname]] + [list literal $vname] $tgt] + lappend newbb $newq my debug-callframe { puts " $newq" + } + set needMovesFrom 1 + } elseif {[lindex $q 0] in { + "directAppend" "directLappend" "directSet" "directUnset" + }} { + unset -nocomplain vname + set needMovesFrom 1 + } + + if {$needMovesFrom} { + if {[info exists vname]} { + set nopArg [list literal $vname] + } else { + set nopArg Nothing + } + set newq2 [list callFrameNop \ + {temp @callframe} {temp @callframe} $nopArg] + my debug-callframe { puts " $newq2" } - lappend newbb $newq lappend newbb $newq2 dict for {var -} $links { if {$tgt ne $var} { set vname [lindex $var 1] set newq [list moveFromCallFrame \ @@ -340,24 +454,39 @@ # If the producer is 'callframeNop', then the # potential change happened because a potentially # aliased variable was moved to the callframe. # The affected variables are its potential aliases - dict set vw $producer \ - [list 1 [my may-alias [lindex $producer 3]]] + if {[lindex $producer 3 0] eq "literal"} { + dict set vw $producer \ + [list 1 [my may-alias [lindex $producer 3]]] + } else { + dict set vw $producer {0 {}} + } + } + startCatch { + + # When catching an error, resynchronize to make sure + # that errorCode and errorInfo are up to date. + # Our ultraconservative alias analysis has no + # real way of handling this, so simply spoil everything + + dict set vw $producer [list 1 [dict keys $links]] } + invoke { # The variables altered by the 'invoke', plus # all aliases, are potentially changed. set aliases {} - puts "Analyze variables set by $producer" - lassign [$specializer variablesProducedBy $producer] \ + set atypes [lmap x [lrange $producer 4 end] { + typeOfOperand $types $x + }] + lassign [my variablesProducedBy $producer $atypes] \ known wlist - puts "known=$known, wlist=$wlist" if {$known} { foreach v $wlist { dict set aliases $v {} foreach a [my may-alias $v] { dict set aliases $a {} @@ -451,13 +580,16 @@ # 'moveToCallFrame' are the same frame. If these deletions cause # all the variables to be deleted from the instruction, then the # instruction itself is deleted, and references to the output # callframe are replaced by references to the input callframe. # -# FIXME: This procedure needs to be updated to allow for namespace -# variables - moveToCallFrame has been inserted before non-'invoke' -# to deal with potential aliasing. +# TODO: Also, we can safely remove moveToCallFrame if the value that +# we are moving was just moved from the same callframe under +# the same name. +# +# TODO: Can we track back further, by noting that some operations +# modify only specific callframe slots? oo::define quadcode::transformer method cleanupMoveToCallFrame {} { my debug-callframe { puts "before cleanupMoveToCallFrame:" @@ -486,11 +618,11 @@ set consumer [my cfConsumer $cfout] my debug-callframe { puts " consumed by: $consumer" } - if {[lindex $consumer 0] eq "callFrameNop"} { + if {[lindex $consumer 0] in {"callFrameNop" "startCatch"}} { # The 'callFrameNop' is there because it needs explicitly to # consume the linked variable. Don't touch! my debug-callframe { puts " which is there to sync a linked variable,\ don't touch!" @@ -497,23 +629,31 @@ } lset bbcontent $b [incr outpc] $q continue } - # Find out what variables that the producer potentially reads - # and changes. + # Determine argument types of the consuming call, which always + # begins with some output and a callframe input + set atypes [lmap x [lrange $consumer 4 end] { + typeOfOperand $types $x + }] + + # Find out what variables that the consumer potentially reads. + # Because potentially changed variables may also be unchanged, + # list them also. + set known 1 set vdict {} - lassign [$specializer variablesUsedBy $consumer] flag vlist + lassign [my variablesUsedBy $consumer $atypes] flag vlist if {!$flag} { set known 0 } else { foreach v $vlist { dict set vdict $v {} } } - lassign [$specializer variablesProducedBy $consumer] flag vlist + lassign [my variablesProducedBy $consumer $atypes] flag vlist if {!$flag} { set known 0 } else { foreach v $vlist { dict set vdict $v {} @@ -526,10 +666,26 @@ [list [dict keys $vdict]]" } else { puts " which potentially accesses any variable" } } + + # Make sure that any variables that the callee is known to + # access, that are not otherwise listed in the callframe, + # get listed. + if {[lindex $bbcontent 0 0 0] eq "entry"} { + set vars [lindex $bbcontent 0 0 2 1] + dict for {v -} $vdict { + if {[lsearch -exact $vars $v] < 0} { + my debug-callframe { + puts " add pass-by-name variable $v to callframe" + } + lappend vars $v + lset bbcontent 0 0 2 1 $vars + } + } + } set ok 1 set newq [list $opcode $cfout $cfin] foreach {vnamelit var} $opdlist { lassign $vnamelit l vname @@ -547,11 +703,11 @@ set defopc "entry" } if {$defopc eq "moveFromCallFrame" && $defvar eq $var && $defcf eq $cfin - && $defname eq $vname} { + && [lindex $defname 1] eq $vname} { my debug-callframe { puts " $vname just came out of $cfin and\ doesn't need to go back in." } my removeUse $var $b @@ -756,12 +912,19 @@ # A callframe is always in a temporary if {[lindex $toCF 0] ne "temp"} continue # Is the result a callframe, and can we eliminate it? set toCFType [typeOfOperand $types $toCF] + if {$opcode eq "invoke"} { + set atypes [lmap x [lrange $q 4 end] { + typeOfOperand $types $x + }] + } else { + set atypes {} + } if {($toCFType & $CALLFRAME) - && [$specializer canEliminateCallFrame $q]} { + && [my canEliminateCallFrame $q $atypes]} { my debug-callframe { puts "can eliminate callframe def/use from\n$b:$pc: $q" puts "provided that structure is consistent" } @@ -787,17 +950,25 @@ # extractCallFrame cfOut temp # and will change to # invoke result Nothing command args... set uses [my allUses $toCF] if {[llength $uses] != 6} { + my debug-callframe { + puts " Too many uses of result callframe" + puts " Cannot optimize..." + } continue } lassign $uses b1 pc1 i1 b2 pc2 i2 set q1 [lindex $bbcontent $b1 $pc1] set q2 [lindex $bbcontent $b2 $pc2] if {[lindex $q1 0] ne "retrieveResult" || [lindex $q2 0] ne "extractCallFrame"} { + my debug-callframe { + puts " Uses of destination callframe are: $q1; $q2" + puts " Cannot optimize..." + } continue } dict unset udchain $toCF dict unset duchain $toCF set resultVar [lindex $q1 1] @@ -934,12 +1105,14 @@ set outpc 0 set bl [llength [lindex $bbcontent $b]] for {set pc 0} {$pc < $bl} {incr pc} { set q [lindex $bbcontent $b $pc] - if {[lindex $q 0] eq "callFrameNop"} { - puts "Remove $b:$pc: $q" + if {[lindex $q 0] in {"callFrameNop" "startCatch"}} { + my debug-callframe { + puts "Remove $b:$pc: $q" + } set cfout [lindex $q 1] set cfin [lindex $q 2] my replaceUses $cfout $cfin dict unset udchain $cfout my removeUse $cfin $b @@ -948,17 +1121,216 @@ incr outpc } } set bb [lindex $bbcontent $b] - lset bbcontent $b {} - set bb [lreplace $bb[set bb {}] $outpc end] - lset bbcontent $b $bb + if {$outpc < [llength $bb]} { + lset bbcontent $b {} + set bb [lreplace $bb[set bb {}] $outpc end] + lset bbcontent $b $bb + } } my debug-callframe { puts "After removeCallFrameNop:" my dump-bb } return } + +# quadcode::transformer method variablesUsedBy -- +# +# Determines what variables are used by a given procedure invocation. +# +# Parameters: +# q - Quadcode instruction that invokes the procedure +# atypes - Types of the args to the procedure, if q is an 'invoke' +# +# Results: +# Returns a two-element list. The first element is a Boolean indicating +# whether the set of consumed variables can be determined with certainty. +# The second element is the list of variables that are known to be +# consumed. + +oo::define quadcode::transformer method variablesUsedBy {q atypes} { + + set params [lassign $q opcode cfout cfin command] + set attrs [$specializer frameEffect $q $atypes] + lassign $command kind cmdName + set typeNames [lmap ty $atypes {nameOfType $ty}] + + if {[dict exists $attrs readsNonLocal]} { + return {0 {}}; # Command has nonlocal effects + } + + if {![dict exists $attrs reads] + && ![dict exists $attrs readsNamed] + && ![dict exists $attrs readsGlobal]} { + return {1 {}}; # Command writes nothing + } + + set read {} + if {[dict exists $attrs reads]} { + foreach ind [dict get $attrs reads] { + if {$ind == 0} { + return {0 {}}; # Anything might be read + } elseif {$ind > 0} { + if {[llength $params] >= $ind} { + set p [lindex $params [expr {$ind-1}]] + if {[lindex $p 0] eq "literal"} { + dict set read [lindex $p 1] {} + } else { + return {0 {}}; + } + } + } else { + set i [expr {-$ind}] + foreach p [lrange $params [expr {-1 - $ind}] end] { + if {[lindex $p 0] eq "literal"} { + dict set read [lindex $p 1] {} + } else { + return {0 {}}; + } + incr i + } + } + } + } + + if {[dict exists $attrs readsNamed]} { + foreach nm [dict get $attrs readsNamed] { + dict set read $nm {} + } + } + + if {[dict exists $attrs readsGlobal]} { + foreach v [dict keys $links] { + dict set read [lindex $v 1] {} + } + } + + return [list 1 [dict keys $read]] + +} + +# quadcode::transformer method variablesProducedBy -- +# +# Determines what variables are produced by a given procedure invocation. +# +# Parameters: +# q - Quadcode instruction that invokes the procedure +# atypes - Types of the arguments to q (used only if the instruction is +# 'invoke') +# +# Results: +# Returns a two-element list. The first element is a Boolean indicating +# whether the set of modified variables can be determined with certainty. +# The second element is the list of variables that are known to be +# modified. + +oo::define quadcode::transformer method variablesProducedBy {q atypes} { + + set params [lassign $q opcode cfOut cfIn command] + set attrs [$specializer frameEffect $q $atypes] + lassign $command kind cmdName + set typeNames [lmap ty $atypes {nameOfType $ty}] + + if {[dict exists $attrs writesNonLocal]} { + return {0 {}}; # Command has nonlocal effects + } + + if {![dict exists $attrs writes] + && ![dict exists $attrs writesNamed] + && ![dict exists $attrs writesGlobal]} { + return {1 {}}; # Command writes nothing + } + + set written {} + if {[dict exists $attrs writes]} { + foreach ind [dict get $attrs writes] { + if {$ind == 0} { + return {0 {}}; # Anything might be written + } elseif {$ind > 0} { + if {[llength $params] >= $ind} { + set p [lindex $params [expr {$ind-1}]] + if {[lindex $p 0] eq "literal"} { + dict set written [lindex $p 1] {} + } else { + return {0 {}}; + } + } + } else { + set i [expr {-$ind}] + foreach p [lrange $params [expr {-1 - $ind}] end] { + if {[lindex $p 0] eq "literal"} { + dict set written [lindex $p 1] {} + } else { + return {0 {}}; + } + incr i + } + } + } + } + + if {[dict exists $attrs writesNamed]} { + foreach nm [dict get $attrs writesNamed] { + dict set written $nm {} + } + } + + if {[dict exists $attrs writesGlobal]} { + foreach v [dict keys $links] { + dict set written [lindex $v 1] {} + } + } + + return [list 1 [dict keys $written]] + +} + +# quadcode::transformer method canEliminateCallFrame -- +# +# Tests whether usage of a callframe can be eliminated entirely from +# the instruction that produced it. +# +# Parameters: +# q - Quadcode instruction that produces a callframe. +# argTypes - Types of the arguments to q +# +# Results: +# Returns 1 if the callframe definition and reference may be +# removed from the instruction (to be replaced with {} and Nothing +# respectively), and 0 otherwise. + +oo::define quadcode::transformer method canEliminateCallFrame {q argTypes} { + + set params [lassign $q opcode cfOut cfIn command] + if {$opcode ne "invoke"} { + return 0 + } + + set attrs [$specializer frameEffect $q $argTypes] + + # If the command cannot ever have its callframe eliminated, quit early. + if {![dict exists $attrs noCallFrame]} { + return 0 + } + + # We know that the callframe can be eliminated as long as the command + # does not reference variables explicitly. Figure out whether that's the + # case. + lassign [my variablesUsedBy $q $argTypes] ok consumed + if {!$ok || [llength $consumed] > 0} { + return 0 + } + + # It would be tempting to eliminate the callframe if the produced variables + # are dead, but that would lead to overwriting variables of the same + # name in the next outer callframe, so can't be done safely. + + # If none of the above conditions hold, the callframe reference and + # definition can be removed safely from the quad. + + return 1 +} Index: quadcode/deadcode.tcl ================================================================== --- quadcode/deadcode.tcl +++ quadcode/deadcode.tcl @@ -566,10 +566,13 @@ # Results: # Returns 1 if the instruction is unkillable, 0 if it may be killed method unkillable {q} { switch -exact -- [lindex $q 0] { + "directAppend" - "directLappend" - "directSet" - "directUnset" { + return 1 + } "initException" { return 1 } "invoke" { # TODO - Many of the Tcl builtins are killable, as are Index: quadcode/parseBuiltinsTxt.tcl ================================================================== --- quadcode/parseBuiltinsTxt.tcl +++ quadcode/parseBuiltinsTxt.tcl @@ -1,5 +1,20 @@ +#!/usr/bin/env tclsh8.6 + +# parseBuiltinsText.tcl -- +# +# Creates the file, 'builtins.tcl' from the file 'builtins.tcl.in', +# adding code to populate the 'cmdAttr' dictionary with the +# attributes of the built-in commands. +# +# Usage: +# tclsh parseBuiltinsTxt.tcl +# +# Results: +# 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 haveAttr {} @@ -41,11 +56,20 @@ dict set cmdAttr $name $attrs } } - puts "oo::define quadcode::specializer method initBuiltins \{\} \{" + set f [open builtins.tcl.in r] + set g [open builtins.tcl w] + puts $g "# CREATED BY [info script], DO NOT EDIT" + puts $g "#" + puts $g "#[string repeat - 77]" + puts $g "#" + chan copy $f $g + close $f + + puts $g "oo::define quadcode::specializer method initBuiltins \{\} \{" set attSeen {} foreach {name attrs} [lsort -stride 2 -index 0 -dictionary $cmdAttr] { set att {} switch -exact -- [dict get $attrs idem] { @@ -111,17 +135,18 @@ if {!$readsSomething && !$writesSomething} { lappend att noCallFrame {} } } - puts "\t[list dict set cmdAttr $name]\ \\" + puts $g " [list dict set cmdAttr $name]\ \\" if {[dict exists $attSeen $att]} { - puts "\t\t\[dict get \$cmdAttr [dict get $attSeen $att]\]" + puts $g " \[dict get \$cmdAttr [dict get $attSeen $att]\]" } else { - puts \t\t[list $att] + puts $g " [list $att]" dict set attSeen $att $name } } - puts "\}" + puts $g "\}" + close $g } main Index: quadcode/specializer.tcl ================================================================== --- quadcode/specializer.tcl +++ quadcode/specializer.tcl @@ -39,10 +39,13 @@ # callers. The values are immaterial. # dependencies - Two level dictionary. The first level keys are procedure # instance names (with type information) and the second # level keys are the instance names of the procedures' # callers. The values are immaterial. + # frameEffect - Dictionary whose keys are instance names and whose + # 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. # onWorklist - Dictionary whose keys are the instance names of the # procedures on the worklist for analysis and whose values @@ -61,10 +64,11 @@ # 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 cmdAttr commandList database dependencies dependents \ + frameEffect \ instanceBeingAnalyzed onWorklist precedence requiredInstances \ returnType typeInf # Local commands: # worklist - List of procedures awaiting type analysis. This list is @@ -87,10 +91,11 @@ oo::define quadcode::specializer constructor {{cmds {}}} { set commandList $cmds set database {} set dependencies {} set dependents {} + set frameEffect {} set onWorklist {} set precedence {} set requiredInstances {} set returnType {} set typeInf {} @@ -138,14 +143,11 @@ -namespace $ns -specializer [self] \ -debug [LLVM configure -quadcode-log]] $db initFromBytecode $bytecode $db transform dict set database $origin $db - # TODO - Compiled procedures will have command attributes that - # indicates their effect on the callframe. At present, - # we are not compiling any procedures that have such effects. - dict set cmdAttr $origin noCallFrame {} + } result options] if {$s == 1} { set ei [split [dict get $options -errorinfo] \n] set ei [linsert $ei end-2 " (compiling procedure '$origin')"] dict set options -errorinfo [join $ei \n] @@ -278,10 +280,79 @@ append result " " $procName "(" append result [join [lmap x $argTypes {nameOfType $x}] ","] append result ")" return $result } + +# quadcode::specializer method frameEffect -- +# +# Looks up what the effect of a command is on the callframe. +# +# Parameters: +# q - Quadcode instruction that invokes the command +# argTypes - List of types of the arguments being passed to the +# command. The individual types are chosen from the +# constants in ::quadcode::datatype (see types.tcl). +# +# Results: +# If the command's effect is known, returns the effect (see +# 'builtins.tcl' for a descripion of the fields. +# If the effect is unknown, returns +# {killable Inf noCallFrame {} pure {}} +# which is the combination indicating 'no callframe effect' +# +# Side effects: +# If the effect is unknown, schedules the command instance for +# analysis. + +oo::define quadcode::specializer method frameEffect {q argTypes} { + + lassign $q opcode cfout cfin cmdName + if {[lindex $q 0] ne "invoke"} { + error "frameEffect called, but not invoking a command" + } + + # Make sure that the invoked command is known at compile time + lassign $cmdName kind cmd1 + if {$kind ne "literal"} { + return {reads 0 writes 0 readsNonLocal {} writesNonLocal {}} + } + set cmdName $cmd1 + set instance [list $cmdName $argTypes] + + # Handle builtins + + if {[dict exists $cmdAttr $cmdName]} { + set attrs [dict get $cmdAttr $cmdName] + if {[dict exists $attrs special]} { + set method frameEffect_[string map {:: __} $cmdName] + set attrs [my $method $q] + } + return $attrs + } + + # If we're not compiling this procedure, it might do anything to the + # frame + + if {![dict exists $database $cmdName]} { + return {reads 0 writes 0 readsNonLocal {} writesNonLocal {}} + } + + # If we've never seen this procedure before, we need to put it on the + # work list + + if {![dict exists $frameEffect $instance]} { + #puts "TEST: Adding to work list: $instance" + my AddToWorklist 0 {*}$instance + dict set frameEffect $instance \ + {killable Inf noCallFrame {} pure {}} + } + + # Return whatever type information we have available. + + return [dict get $frameEffect $instance] +} # quadcode::specializer method resultType -- # # Looks up the result type of a command. If the result type is # unknown, returns BOTTOM and schedules the command for analysis if @@ -304,10 +375,14 @@ oo::define quadcode::specializer method resultType {procName argTypes} { namespace upvar ::quadcode::dataType \ DOUBLE DOUBLE INT INT NUMERIC NUMERIC ZEROONE ZEROONE STRING STRING \ FAIL FAIL BOTTOM BOTTOM set instance [list $procName $argTypes] + + if {0 in $argTypes} { + return 0 + } # If we're not compiling this procedure, delegate to builtinCommandType if {![dict exists $database $procName]} { switch [lindex [builtinCommandType $procName] 1] { @@ -338,11 +413,15 @@ # If we've never seen this procedure before, we need to put it on the # work list if {![dict exists $returnType $instance]} { - #puts "TEST: Adding to work list: $instance" + my debug-specializer { + set argTypeNames [lmap x $argTypes {nameOfType $x}] + puts "getResultType: Adding to work list:\ + ${procName}($argTypeNames)" + } my AddToWorklist 0 {*}$instance dict set returnType $instance $BOTTOM } # Return whatever type information we have available. @@ -513,25 +592,37 @@ puts "INFERTYPES $procName ($argTypeNames):" } $inf inferTypes set rtype [$inf getReturnType] - # If return type has changed, we need to recalculate all this instance's + # Calculate the effect of the instance on the stack frame + my debug-specializer { + puts " UPVAR $procName ($argTypeNames):" + } + set feffect [$inf analyzeUpvar] + + # If return type or frame effect has changed, we need to + # recalculate all this instance's # dependents. Put them on the worklist. if {![dict exists $returnType $instance] - || $rtype != [dict get $returnType $instance]} { + || $rtype != [dict get $returnType $instance] + || ![dict exists $frameEffect $instance] + || $feffect != [dict get $frameEffect $instance]} { my debug-specializer { puts "INFERTYPES: return type of $procName ($argTypeNames)\ - changed to [nameOfType $rtype] ($rtype)" + changed to [nameOfType $rtype] ($rtype)\n \ + and frame effect changed to $feffect" } dict set returnType $instance $rtype + dict set frameEffect $instance $feffect if {[dict exists $dependents $instance]} { dict for {d -} [dict get $dependents $instance] { my AddToWorklist 0 {*}$d } } } + my AddToWorklist 1 $procName $argTypes } # quadcode::specializer method TidyInstance -- # @@ -595,206 +686,10 @@ } if {[$inf nodesplit]} { my AddToWorklist 0 $procName $argTypes } } - -# quadcode::specializer method variablesUsedBy -- -# -# Determines what variables are used by a given procedure invocation. -# -# Parameters: -# q - Quadcode instruction that invokes the procedure -# -# Results: -# Returns a two-element list. The first element is a Boolean indicating -# whether the set of consumed variables can be determined with certainty. -# The second element is the list of variables that are known to be -# consumed. - -oo::define quadcode::specializer method variablesUsedBy {q} { - - # The format of the 'invoke' instruction is: - # invoke callframeOut callframeIn command param1 param2 param3 ... - set params [lassign $q opcode cfOut cfIn command] - - # Not a command invocation - that's a bug in the caller - if {$opcode ne {invoke}} { - error [list $q is not an 'invoke'] - } - - lassign $command kind cmdName - if {$kind ne "literal"} { - return {0 {}}; # Command name is not known at compile time - } - - if {![dict exists $cmdAttr $cmdName]} { - return {0 {}}; # Callframe effect has not been characterized - } - - if {[dict exists $cmdAttr $cmdName special]} { - # Command requires special handling to determine its effect - regsub -all :: $cmdName __ cmdsub - tailcall my varreads_$cmdsub $q - } - - if {![dict exists $cmdAttr $cmdName reads]} { - return {1 {}}; # Command writes nothing - } - - set read {} - foreach ind [dict get $cmdAttr $cmdName reads] { - if {$ind == 0} { - return {0 {}}; # Anything might be read - } elseif {$ind > 0} { - if {[llength $params] >= $ind} { - set p [lindex $params [expr {$ind-1}]] - if {[lindex $p 0] eq "literal"} { - lappend read [lindex $p 1] - } else { - return {0 {}}; - } - } - } else { - set i [expr {-$ind}] - foreach p [lrange $params [expr {-1 - $ind}] end] { - if {[lindex $p 0] eq "literal"} { - lappend read [lindex $p 1] - } else { - return {0 {}}; - } - incr i - } - } - } - return [list 1 $read] - -} - -# quadcode::specializer method variablesProducedBy -- -# -# Determines what variables are produced by a given procedure invocation. -# -# Parameters: -# q - Quadcode instruction that invokes the procedure -# -# Results: -# Returns a two-element list. The first element is a Boolean indicating -# whether the set of modified variables can be determined with certainty. -# The second element is the list of variables that are known to be -# modified. - -oo::define quadcode::specializer method variablesProducedBy {q} { - - # The format of the 'invoke' instruction is: - # invoke callframeOut callframeIn command param1 param2 param3 ... - set params [lassign $q opcode cfOut cfIn command] - - # Not a command invocation - that's a bug in the caller - if {$opcode ne {invoke}} { - error [list $q is not an 'invoke'] - } - - lassign $command kind cmdName - if {$kind ne "literal"} { - return {0 {}}; # Command name is not known at compile time - } - - if {![dict exists $cmdAttr $cmdName]} { - return {0 {}}; # Callframe effect has not been characterized - } - - if {[dict exists $cmdAttr $cmdName special]} { - # Command requires special handling to determine its effect - regsub -all :: $cmdName __ cmdsub - tailcall my varwrites_$cmdsub $q - } - - if {![dict exists $cmdAttr $cmdName writes]} { - return {1 {}}; # Command writes nothing - } - - set written {} - foreach ind [dict get $cmdAttr $cmdName writes] { - if {$ind == 0} { - return {0 {}}; # Anything might be written - } elseif {$ind > 0} { - if {[llength $params] >= $ind} { - set p [lindex $params [expr {$ind-1}]] - if {[lindex $p 0] eq "literal"} { - lappend written [lindex $p 1] - } else { - return {0 {}}; - } - } - } else { - set i [expr {-$ind}] - foreach p [lrange $params [expr {-1 - $ind}] end] { - if {[lindex $p 0] eq "literal"} { - lappend written [lindex $p 1] - } else { - return {0 {}}; - } - incr i - } - } - } - return [list 1 $written] - -} - -# quadcode::specializer method canEliminateCallFrame -- -# -# Tests whether usage of a callframe can be eliminated entirely from -# the instruction that produced it. -# -# Parameters: -# q - Quadcode instruction that produces a callframe. -# -# Results: -# Returns 1 if the callframe definition and reference may be -# removed from the instruction (to be replaced with {} and Nothing -# respectively), and 0 otherwise. - -oo::define quadcode::specializer method canEliminateCallFrame {q} { - - set params [lassign $q opcode cfOut cfIn command] - - # Only 'invoke' instructions at present can have callframes eliminated - if {$opcode ne "invoke"} { - return 0 - } - - # If the command's effect on the callframe has not been characterized, - # quit. - lassign $command kind cmdName - if {$kind ne "literal" || ![dict exists $cmdAttr $cmdName]} { - return 0 - } - - # If the command cannot ever have its callframe eliminated, quit early. - if {![dict exists $cmdAttr $cmdName noCallFrame]} { - return 0 - } - - # We know that the callframe can be eliminated as long as the command - # does not reference variables explicitly. Figure out whether that's the - # case. - lassign [my variablesUsedBy $q] ok consumed - if {!$ok || [llength $consumed] > 0} { - return 0 - } - - # It would be tempting to eliminate the callframe if the produced variables - # are dead, but that would lead to overwriting variables of the same - # name in the next outer callframe, so can't be done safely. - - # If none of the above conditions hold, the callframe reference and - # definition can be removed safely from the quad. - - return 1 -} # quadcode::specializer method AddToWorklist -- # # Puts a procedure instance on the worklist of procedures to specialize. # @@ -817,10 +712,15 @@ oo::define quadcode::specializer method AddToWorklist {actNum procName argTy} { set prec [dict get $precedence $procName] set key [list $actNum $procName $argTy] + + if {0 in $argTy} { + return + # error "Trying to add an incomplete procedure $procName ($argTy) to the worklist" + } # If a procedure is already on the worklist, don't add it again. if {![dict exists $onWorklist $key]} { worklist add [::quadcode::AnalysisAction new \ Index: quadcode/transformer.tcl ================================================================== --- quadcode/transformer.tcl +++ quadcode/transformer.tcl @@ -126,11 +126,10 @@ variable bbcontent bbpred variable bbidom bbkids bblevel bbnlevels varcount variable duchain udchain variable varExists variable types - variable ptype ns_counters # Constructor - # # Keyword arguments (following the positional arguments): @@ -362,10 +361,11 @@ # Remove the split markers that were used to constrain node splitting my removeSplitMarkers # Remove any callframeNops that remain my removeCallFrameNop + my uselessphis # Remove the callframe usage if possible # TODO - Can we do this earlier? my eliminateCallFrame @@ -480,10 +480,21 @@ puts $channel "$pc: $q" incr pc } puts $channel [string repeat - 77] } + + # full-name -- + # + # Reports the full name of the current proc for debugging + # + # Results: + # Returns the name + + method full-name {} { + return "${originProc}([join [lmap t $ptype {quadcode::nameOfType $t}] ,])" + } # dump-bb -- # # Dumps the basic blocks on a specified channel for debugging # @@ -495,11 +506,11 @@ # # Side effects: # Spews data on the channel method dump-bb {{channel stdout}} { - puts $channel "Procedure: $originProc:" + puts $channel "Procedure: [my full-name]" set b 0 foreach qds $bbcontent { puts $channel "bb $b:" set i 0 foreach q $qds { @@ -565,11 +576,11 @@ # Remove useless data motion into callframes set changed [expr {[my cleanupMoveToCallFrame] || $changed}] # Remove any totally irrelevant callframe use/defs - set changed [expr {[my cleanupCallFrameUse] || $changed}] + set changed [expr {[my cleanupCallFrameUse] || [my deadvars] || $changed}] # Remove conditional jumps that depend on constants set changed [expr {[my deadjump] || $changed}] # Remove unreachable code and coalesce basic blocks where possible @@ -647,10 +658,11 @@ 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 varargs.tcl] source [file join $quadcode::libdir widen.tcl] #source [file join $quadcode::libdir exists.tcl] #source [file join $quadcode::libdir interval.tcl] Index: quadcode/translate.tcl ================================================================== --- quadcode/translate.tcl +++ quadcode/translate.tcl @@ -3,10 +3,11 @@ # Tcl bytecode to quadcode conversion code, plus basic (no reasoning # required) type assertions hooked off that generated quadcode. # # Copyright (c) 2014-2015 by Kevin B. Kenny # Copyright (c) 2015 by Donal K. Fellows +# Copyright (c) 2017 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. # #------------------------------------------------------------------------------ @@ -34,10 +35,11 @@ set IMPURE_NUMERIC [::quadcode::dataType::typeUnion \ $::quadcode::dataType::IMPURE \ $::quadcode::dataType::NUMERIC] set currentline 0 + set currentscript {} set originalscript [dict get $bytecode script] set quads {}; # List of instructions under construction set fixup {}; # Dictionary whose keys are jump targets ; # and the values are lists of quad program @@ -76,11 +78,11 @@ } dict unset fixup $pc } # Determine if the current source line has changed - set c {} + set c {} foreach cr [dict get $bytecode commands] { if {[dict get $cr codefrom] > $pc} continue if {[dict get $cr codeto] < $pc} continue set c $cr } @@ -91,14 +93,19 @@ # Add the location of the first line of the script within its # file, if that is known. if {[dict exists $bytecode initiallinenumber]} { incr line [dict get $bytecode initiallinenumber] } - # Issue the directive if there has been a change + # Issue the directive if there has been a change in line number if {$line != $currentline} { set currentline $line quads @debug-line {} [list literal $line] + } + # Issue the directive if there has been a change in script text + if {$currentscript ne [dict get $c script]} { + set currentscript [dict get $c script] + quads @debug-script {} [list literal [dict get $c script]] } } # Translate the current bytecode switch -exact -- [lindex $insn 0] { @@ -548,10 +555,68 @@ generate-arith-domain-check incr $delta quads purify {temp opd2} $delta error-quads dictIncr $ary $ary $idx {temp opd2} error-quads dictGet $res $ary $idx } + incrStkImm { + set var [list temp [incr depth -1]] + set delta [list literal [lindex $insn 1]] + # TODO: This assumes we're dealing with qualified names! + set val {temp opd2} + error-quads directGet $val $var + generate-arith-domain-check incr $val $delta + quads purify {temp opd0} $val + quads purify {temp opd1} $delta + quads add $val {temp opd0} {temp opd1} + error-quads directSet $var $var $val + } + incrStk { + set delta [list temp [incr depth -1]] + set var [list temp [incr depth -1]] + # TODO: This assumes we're dealing with qualified names! + set val {temp opd2} + error-quads directGet $val $var + generate-arith-domain-check incr $val $delta + quads purify {temp opd0} $val + quads purify {temp opd1} $delta + quads add $val {temp opd0} {temp opd1} + error-quads directSet $var $var $val + } + appendStk { + set delta [list temp [incr depth -1]] + set var [list temp [incr depth -1]] + # TODO: This assumes we're dealing with qualified names! + error-quads directAppend $var $var $delta + } + lappendStk { + set delta [list temp [incr depth -1]] + set var [list temp [incr depth -1]] + # TODO: This assumes we're dealing with qualified names! + error-quads directLappend $var $var $delta + } + existStk { + set var [list temp [incr depth -1]] + # TODO: This assumes we're dealing with qualified names! + quads directExists $var $var + } + loadStk { + set var [list temp [incr depth -1]] + # TODO: This assumes we're dealing with qualified names! + error-quads directGet $var $var + } + storeStk { + set value [list temp [incr depth -1]] + set var [list temp [incr depth -1]] + # TODO: This assumes we're dealing with qualified names! + error-quads directSet $var $var $value + } + unsetStk { + set flags [list literal [lindex $insn 1]] + set var [list temp [incr depth -1]] + # TODO: This assumes we're dealing with qualified names! + error-quads directUnset $var $var $flags + } dictGet { set idxNum [lindex $insn 1] set q {} for {set i 0} {$i < $idxNum} {incr i} { # NOTE: Reversed @@ -984,17 +1049,23 @@ variable { set var [index-to-var [lindex $insn 1]] set name [list temp [incr depth -1]] quads [lindex $insn 0] {temp @callframe} {temp @callframe} \ [list literal [lindex $var 1]] $name + quads retrieveResult {temp @error} {temp @callframe} + quads extractCallFrame {temp @callframe} {temp @callframe} + generate-jump [exception-target catch] maybe {temp @error} } nsupvar - upvar { set var [index-to-var [lindex $insn 1]] set name [list temp [incr depth -1]] set context [list temp [incr depth -1]] quads [lindex $insn 0] {temp @callframe} {temp @callframe} \ [list literal [lindex $var 1]] $context $name + quads retrieveResult {temp @error} {temp @callframe} + quads extractCallFrame {temp @callframe} {temp @callframe} + generate-jump [exception-target catch] maybe {temp @error} } default { # TODO - Many more instructions return -code error "I don't know yet what to do about $insn" } Index: quadcode/types.tcl ================================================================== --- quadcode/types.tcl +++ quadcode/types.tcl @@ -465,11 +465,11 @@ # Results: # Returns the deduced data type of q's left hand side oo::define quadcode::transformer method typeOfResult {q} { namespace upvar ::quadcode::dataType {*}{ - DOUBLE DOUBLE INT INT STRING STRING FAIL FAIL + DOUBLE DOUBLE INT INT STRING STRING FAIL FAIL EMPTY EMPTY BOOL_INT BOOL ENTIER ENTIER NUMERIC NUMERIC IMPURE IMPURE VOID VOID CALLFRAME CALLFRAME DICTITER DICTITER FOREACH FOREACH NEXIST NEXIST } @@ -633,13 +633,16 @@ set rtype [expr {$FAIL | $STRING}] } set inty [typeOfOperand $types [lindex $q 2]] return [expr {($inty & $CALLFRAME) | $rtype}] } - callFrameNop - nsupvar - upvar - variable { + callFrameNop - startCatch { return $CALLFRAME } + nsupvar - upvar - variable { + return [expr {$CALLFRAME | $BOOL | $FAIL}] + } retrieveResult { # Pull from the callframe of the earlier 'invoke' return [expr {[typeOfOperand $types [lindex $q 2]] & ~$CALLFRAME}] } extractCallFrame { @@ -678,10 +681,20 @@ resolveCmd { return $STRING } originCmd { return [expr {$STRING | $FAIL}] + } + directGet - directSet - directAppend - directLappend { + # Can't assume more; these may be touching traced variables + return [expr {$STRING | $FAIL}] + } + directExists { + return $BOOL + } + directUnset { + return [expr {$BOOL | $FAIL}] } default { error "Cannot infer type of result of $q" } } ADDED quadcode/upvar.tcl Index: quadcode/upvar.tcl ================================================================== --- /dev/null +++ quadcode/upvar.tcl @@ -0,0 +1,690 @@ +# upvar.tcl -- +# +# Methods to analyze the effect of [upvar] upon callers of a procedure. +# +# Copyright (c) 2017 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 analyzeUpvar -- +# +# Analyzes the effect that [upvar] will have on the callers of the +# procedure being compiled. +# +# Results: +# Returns the procedure's frame effect +# +# Preconditions: +# The quadcode must be in SSA form. The 'callframeMotion' pass must +# have installed the (possibly redundant) 'moveToCallFrame' and +# 'moveFromCallFrame' instructions. Copy propagation must have been +# performed. +# +# Side effects: +# Calls the specializer to set attributes of the current procedure: +# +# reads - List of parameters that contain argument positions +# of input variables passed by name. +# writes - List of parameters that contain argument positions +# of output variables passed by name. +# readsNamed - List of names of input variables passed implicitly +# writesNamed - List of names of output variables passed implicitly +# noCallFrame - Flag if it is permissible to eliminate the caller's +# callframe entirely. +# allCallFrames - Flag if all callers on the stack must have +# callframes (because, for instance, of an +# [upvar] to an unknown stack level). + +oo::define quadcode::transformer method analyzeUpvar {} { + + my debug-upvar { + puts "Before \[upvar\] analysis:" + my dump-bb + } + + # 1. Walk from the entry block, and analyze what variables contain + # the values of passed parameters. + + set argPos [my upvarAnalyzeArgs] + + # 2. Walk from the entry block, recording the state of [upvar] + # at each instruction that might change it. + + set upvarState [my upvarFindAliases $argPos] + + # 3. Walk 'moveToCallFrame', 'moveFromCallFrame' and 'invoke' to + # determine the procedure's effect on variables. + + set procEffect [my upvarProcEffect $upvarState] + + return $procEffect +} + +# quadcode::transformer method upvarAnalyzeArgs -- +# +# Determines what named variables in SSA-based quadcode are known to +# contain the values of passed parameters (with possible MAYBE and +# NEXIST monads eliminated). (TODO: It may in future also be necessary +# to look for widened or narrowed types.) +# +# Results: +# Returns a dictionary whose keys are SSA value names and whose values +# are the corresponding parameter positions. + +oo::define quadcode::transformer method upvarAnalyzeArgs {} { + + # Analyze the entry block, looking for 'param' instructions + + set worklist {} + set argPos {} + foreach q [lindex $bbcontent 0] { + if {[lindex $q 0] eq "param"} { + set var [lindex $q 1] + set argIdx [expr {[lindex $q 2 1] + 1}] + my debug-upvar { + puts "[lindex $q 1] is argument \#$argIdx]" + } + dict set argPos $var $argIdx + my addUsesToUpvarWorklist worklist $var + } + } + + # Propagate the identity of the parameters through copies, extracts, + # and type narrowing. + + while {[llength $worklist] > 0} { + set worklist [lassign $worklist b] + foreach q [lindex $bbcontent $b] { + switch -exact [lindex $q 0 0] { + copy - + extractExists - + extractMaybe - + narrowToType - + purify - + widenTo { + set var [lindex $q 1] + set invar [lindex $q 2] + if {![dict exists $argPos $var] + && [dict exists $argPos $invar]} { + set argIdx [dict get $argPos $invar] + my debug-upvar { + puts " $var also refers to arg $argIdx" + } + dict set argPos $var [dict get $argPos $invar] + my addUsesToUpvarWorklist worklist $var + } + } + } + } + } + + return $argPos +} + +# quadcode::transformer method upvarFindAliases -- +# +# Determines what variables in a procedure's callframe may alias +# what variables in the caller's frame. +# +# Parameters: +# +# argPos - +# Dictionary whose keys are the names of quadcode variables and +# whose values are positions in the argument list. The values +# in question are known always to contain the values of +# passed parameters; therefore, if they appear on 'upvar', they +# are variables passed by name +# +# +# Results: +# +# Returns a two-element list. +# +# The first element indicates whether all alias effects could be +# computed. If it is zero, the second element is a dictionary described +# below. If it is 1, there is at least one +# Returns a dictionary whose keys are the names +# of quadcode variables that contain callframes. Each value in the +# dictionary is a second-level dictionary whose keys are the names +# of variables in the callframe and whose values are chosen from +# among: +# +# {arg N} - The variable name is the Nth parameter of the +# current procedure (pass-by-name} +# {named N} - The variable name is constant (named variable +# in the caller's frame). +# {unknown} - The variable name is unknown, but is known +# at least to be in the caller's callframe, rather +# farther out on the stack. (The implication +# of {unknown} is that the variable may potentially +# alias any variable in the caller's frame.) +# {global} - The variable is known to be in global or +# namespace scope, not in the callframe. +# {nonlocal} - The variable may be in the callframe of an +# outer caller, so calling this procedure might +# have nonlocal effects. +# +# Operations that change the aliasing status of one or more variables: +# callFrameNop +# extractCallFrame +# moveToCallFrame +# Do noting about aliasing, simply copy the aliasing information from +# the source callframe to the destination callframe. +# entry - +# On entry, no variable is an alias +# invoke - +# Adjust aliasing according to what the invoked command does. +# nsupvar +# Indicate that the designated variable is global. (If the target +# variable name is nonconstant, error out). +# phi +# Set the aliases in the result callframe to the union of the aliases +# in the input callframes +# upvar +# Indicate that the designated variable is an arg, a name, or an unknown +# ref (Only cases handled are upvar 1 and upvar #0) +# variable +# Indicate that the designated variable is global. (If the name is +# nonconstant, error out + + +oo::define quadcode::transformer method upvarFindAliases {argPos} { + + # Trace data flows from the entry block. + set firstq [lindex $bbcontent 0 0] + if {[lindex $firstq 0] ne "entry" || [lindex $firstq 1] eq {}} { + # The procedure does not use the callframe + return {} + } + + set worklist {} + set entryFrame [lindex $firstq 1] + dict set aliasInfo $entryFrame {} + my addUsesToUpvarWorklist worklist $entryFrame + + # While there's analysis to be done, do it. + while {[llength $worklist] > 0} { + + # Find the next basic block to analyze and walk its instructions, + # unpacking opcode, result, and input callframe from each one. + set worklist [lassign $worklist b] + set bb [lindex $bbcontent $b] + set pc -1 + foreach q $bb { + incr pc + lassign $q opcode result arg1 arg2 + + # resFrame, if set is the alias info for the new quad. + unset -nocomplain resFrame + + # Analyze individual quads + switch -exact -- [lindex $opcode 0] { + callFrameNop - + extractCallFrame - + invoke - + startCatch { + + # These instructions do not change aliases, so copy + # the input frame to the result frame. + if {![dict exists $aliasInfo $arg1]} { + set resFrame {} + } else { + set resFrame [dict get $aliasInfo $arg1] + } + + } + moveToCallFrame { + + # If the variable isn't already upvar or global, + # this instruction will make it local. + if {![dict exists $aliasInfo $arg1]} { + set resFrame {} + } else { + set resFrame [dict get $aliasInfo $arg1] + } + if {[lindex $arg2 0] ne "literal"} { + return 1; # Local variable name not constant + } + foreach {localVar source} [lrange $q 3 end] { + if {[lindex $localVar 0] ne "literal"} { + error "cannot handle double-dereference" + } + set localVarName [lindex $localVar 1] + if {![dict exists $resFrame $localVarName]} { + dict set resFrame $localVarName local + } + } + + } + nsupvar - variable { + + # These instructions always make the local variable + # alias a namespace variable + + if {![dict exists $aliasInfo $arg1]} { + set resFrame {} + } else { + set resFrame [dict get $aliasInfo $arg1] + } + if {[lindex $arg2 0] ne "literal"} { + return 1; # Local variable name not constant" + } + set localVar [lindex $arg2 1] + if {[dict exists $resFrame $localVar] + && [dict get $resFrame $localVar] eq "local"} { + # TODO - How to report static errors? + error "$localVar is already defined" + } + dict set resFrame $localVar global + } + + phi { + set isCallframe 0 + if {![dict exists $aliasInfo $arg2]} { + set resFrame {} + } else { + set isCallframe 1 + set resFrame [dict get $aliasInfo $arg2] + } + foreach {- arg} [lrange $q 4 end] { + if {[dict exists $aliasInfo $arg]} { + set isCallframe 1 + set resFrame [my upvarPhi $resFrame \ + [dict get $aliasInfo $arg]] + } + } + if {!$isCallframe} { + unset resFrame + } + + } + + upvar { + if {![dict exists $aliasInfo $arg1]} { + set resFrame {} + } else { + set resFrame [dict get $aliasInfo $arg1] + } + if {[lindex $arg2 0] ne "literal"} { + return 1; # Local variable name not constant" + } + set localVar [lindex $arg2 1] + set level [lindex $q 4] + set remoteName [lindex $q 5] + if {[lindex $remoteName 0] eq "literal" + && [string first :: [lindex $remoteName 1]] >= 0} { + set status "global" + } elseif {[lindex $level 0] ne "literal"} { + set status "nonlocal" + } elseif {[lindex $level 1] eq "1"} { + if {[lindex $remoteName 0] eq "literal"} { + set status [list "named" [lindex $remoteName 1]] + } elseif {[dict exists $argPos $remoteName]} { + set status \ + [list "arg" [dict get $argPos $remoteName]] + } else { + set status "unknown" + } + } elseif {[lindex $level 1] eq "#0"} { + set status "global" + } else { + set status "nonlocal" + } + if {[dict exists $resFrame $localVar] + && [dict get $resFrame $localVar] eq "local"} { + # TODO - How to report static errors? + error "$localVar is already defined" + } + dict set resFrame $localVar $status + + } + } + + # If the state of the callframe at this point has changed, + # add the dependencies + + if {[info exists resFrame]} { + set resFrame [lsort -ascii -increasing -index 0 -stride 2 \ + $resFrame] + if {![dict exists $aliasInfo $result] + || $resFrame ne [dict get $aliasInfo $result]} { + my debug-upvar { + puts "$b:$pc: $q" + puts " -> $resFrame" + } + dict set aliasInfo $result $resFrame + my addUsesToUpvarWorklist worklist $result + } + } + } + } + + return $aliasInfo + +} + +# quadcode::transformer method upvarPhi -- +# +# Combines the aliasing information when callframes arrive at a phi. +# +# Parameters: +# f1 - First callframe's alias information +# f2 - Second callframe's variable +# +# Results: +# Returns a conservative estimate of the alias information after +# the phi. + +oo::define quadcode::transformer method upvarPhi {f1 f2} { + + # Walk the first dictionary and promote the values to the second + # dictionary's alias type if necessary. + + dict for {v a} $f1 { + if {[dict exists $f2 $v]} { + set b [dict get $f2 $v] + if {$a ne $b} { + if {$b eq "nonlocal"} { + dict set f1 $v $b + } elseif {$a eq "nonlocal"} { + } elseif {$b eq "unknown"} { + dict set f1 $v $b + } elseif {$a eq "unknown"} { + } elseif {$a eq "local"} { + dict set v1 $v $b + } elseif {$b eq "local"} { + } else { + # mismatched combination of named and arg + dict set v1 $v "unknown" + } + } + dict unset f2 $v + } + } + + return [dict merge $f1 $f2] + +} + +# quadcode::transformer method upvarProcEffect -- +# +# Determines the effect of a procedure on the outer callframes of +# the stack. +# +# Parameters: +# state - Dictionaries whose keys are the names of quadcode variables +# that designate callframes, and whose values are the possible +# aliases of the variables in outer frames. +# +# Results: +# Returns a dictionary that characterizes the code's effect. + +oo::define quadcode::transformer method upvarProcEffect {aliasInfo} { + + # All of the information should be in place to allow us simply to + # accumulate the effect of 'moveToCallFrame', 'moveFromCallFrame', + # and invoked commands. + + set result [dict create \ + killable Inf noCallFrame {} pure {} \ + reads {} writes {} \ + readsNamed {} writesNamed {} \ + readsAny 0 writesAny 0 \ + readsNonLocal 0 writesNonLocal 0] + + # Walk through the quadcode, analyzing instructions that get/set + # values in the callframe for their effects on potential aliases. + + set b -1 + foreach bb $bbcontent { + incr b + set pc -1 + foreach q $bb { + incr pc + + set did 0 + switch -exact -- [lindex $q 0] { + + "moveFromCallFrame" { + set did 1 + lassign $q opcode qcvar callframe cfvar + if {[lindex $cfvar 0] ne "literal"} { + error "Cannot handle double-dereference" + } else { + set cfvar [lindex $cfvar 1] + } + if {[dict exists $aliasInfo $callframe $cfvar]} { + my upvarRecordRead result \ + [dict get $aliasInfo $callframe $cfvar] + # must do: dict unset result pure + } + } + + "moveToCallFrame" { + set did 1 + set vs [lassign $q opcode cfout cfin] + foreach {cfvar qcvar} $vs { + if {[lindex $cfvar 0] ne "literal"} { + error "Cannot handle double-dereference" + } else { + set cfvar [lindex $cfvar 1] + } + if {[dict exists $aliasInfo $cfout $cfvar]} { + my upvarRecordWrite result \ + [dict get $aliasInfo $cfout $cfvar] + # must do: dict unset result pure; + # must do: dict unset result killable; + } + } + } + + "invoke" { + set did 1 + set argList [lassign $q opcode cfout cfin cmdName] + set typeList [lmap arg $argList {typeOfOperand $types $arg}] + set attrs [$specializer frameEffect $q $typeList] + my upvarInvoke result $aliasInfo $attrs $q $typeList + } + + } + + my debug-upvar { + if {$did} { + puts "$b:$pc: $q" + puts " effect changed to $result" + } + } + } + } + + my debug-upvar { + puts "Before rewrites: stack effect: $result" + } + + if {[dict get $result readsAny]} { + dict set result reads 0 + } else { + dict set result reads [dict keys [dict get $result reads]] + } + dict unset result readsAny + if {[dict get $result writesAny]} { + dict set result writes 0 + } else { + dict set result writes [dict keys [dict get $result writes]] + } + dict unset result writesAny + if {[llength [dict get $result reads]] == 0} { + dict unset result reads + } + if {[llength [dict get $result writes]] == 0} { + dict unset result writes + } + if {[dict size [dict get $result readsNamed]] == 0} { + dict unset result readsNamed + } else { + dict set result readsNamed [dict keys [dict get $result readsNamed]] + } + if {[dict size [dict get $result writesNamed]] == 0} { + dict unset result writesNamed + } else { + dict set result writesNamed [dict keys [dict get $result writesNamed]] + } + if {![dict get $result readsNonLocal]} { + dict unset result readsNonLocal + } + if {![dict get $result writesNonLocal]} { + dict unset result writesNonLocal + } + + if {[dict exists $result reads] + || [dict exists $result readsAny] + || [dict exists $result readsNonLocal]} { + dict unset result pure + dict unset result noCallFrame + } + if {[dict exists $result writes] + || [dict exists $result writesAny] + || [dict exists $result writesNonLocal]} { + dict unset result pure + dict unset result noCallFrame + dict unset result killable + } + + my debug-upvar { + puts "Stack effect calculated to be: $result" + } + return $result +} + +# quadcode::transformer method upvarInvoke -- +# +# Compute the callframe effect of an invoked command. +# +# Parameters: +# resultV - Name of a variable in caller's scope containing the +# callframe effect of the current command +# aliasInfo - Dictionary that identifies what callframe variables have +# aliases in the caller +# effect - Callframe effect of the invoked command. +# q - 'invoke' instruction being processed +# typeList - Types of the arguments to $q +# +# Results: +# None. +# +# Side effects: +# Records the effect of the 'invoke' on the current callframe. + +oo::define quadcode::transformer method upvarInvoke {resultV aliasInfo + effect q typeList} { + + upvar 1 $resultV result + + # Record purity + + if {![dict exists $effect pure]} { + dict unset result pure + } + + # Record nonlocal effects + + if {[dict exists $effect readsNonLocal]} { + dict set result readsNonLocal 1 + } + if {[dict exists $effect writesNonLocal]} { + dict set result writesNonLocal 1 + } + + # Defer to specializer for produced and consumed variables + + lassign [my variablesUsedBy $q $typeList] status varlist + if {$status} { + foreach v $varlist { + if {[dict exists $aliasInfo $v]} { + my recordRead [dict get $aliasInfo $v] + } + } + } else { + dict set result reads {0 {}} + } + lassign [my variablesProducedBy $q $typeList] status varlist + if {$status} { + foreach v $varlist { + if {[dict exists $aliasInfo $v]} { + my recordWrite [dict get $aliasInfo $v] + } + } + } else { + dict set result writes {0 {}} + } +} + +oo::define quadcode::transformer method upvarRecordRead {resultV alias} { + + upvar 1 $resultV result + if {$alias ni {"local" "global"}} { + dict unset result killable + dict unset result noCallFrame + } + my upvarRecordAction result $alias reads +} + + +oo::define quadcode::transformer method upvarRecordWrite {resultV alias} { + upvar 1 $resultV result + if {$alias ne "local"} { + dict unset result pure + dict unset result killable + dict unset result noCallFrame + } + my upvarRecordAction result $alias writes +} + +oo::define quadcode::transformer method upvarRecordAction {resultV alias act} { + + upvar 1 $resultV result + + switch -exact -- [lindex $alias 0] { + "arg" { + dict set result $act [lindex $alias 1] {} + } + "global" { + dict set result ${act}Global {} + } + "local" { + } + "named" { + dict set result ${act}Named [lindex $alias 1] {} + } + "nonlocal" { + dict set result ${act}NonLocal {} + } + "unknown" { + dict set result $act {0 {}} + } + default { + error "TODO - Handle alias type $alias" + } + } +} + + +oo::define quadcode::transformer method addUsesToUpvarWorklist {worklistVar v} { + upvar 1 $worklistVar worklist + if {[dict exists $duchain $v]} { + dict for {use -} [dict get $duchain $v] { + my addToUpvarWorklist worklist $use + } + } +} + +oo::define quadcode::transformer method addToUpvarWorklist {worklistVar item} { + upvar 1 $worklistVar worklist + set idx [lsearch -sorted -integer -increasing -bisect $worklist $item] + if {[lindex $worklist $idx] != $item} { + set worklist [linsert $worklist[set worklist {}] [expr {$idx+1}] $item] + } +} ADDED wordlist.txt Index: wordlist.txt ================================================================== --- /dev/null +++ wordlist.txt @@ -0,0 +1,1001 @@ +A +A'asia +A's +AA's +AB's +ABM's +AC's +ACTH's +AD's +ADP's +AEC's +AI's +AIDS's +ALGOL's +AM's +AMP's +AOL +AOL's +APC's +ASCII's +ASL's +ATM's +ATP's +AWOL's +AZ's +AZT's +Aachen +Aalborg +Aalesund +Aaliyah +Aaliyah's +Aalst +Aalto +Aarau +Aargau +Aarhus +Aaron +Aaronic +Aaronical +Aaronsburg +Aaronsburg's +Ab +Ab's +Abadan +Abaddon +Abba +Abbado +Abbado's +Abbas +Abbasid +Abbasids +Abbeville +Abbeville's +Abbevillean +Abbevillian +Abbotsford +Abbotsford's +Abbott +Abbott's +Abbottstown +Abbottstown's +Abby +Abby's +Abbyville +Abbyville's +Abderian +Abderian's +Abderite +Abderite's +Abdias +Abdul +Abdul's +Abdullah +Abdullah's +Abe +Abe's +Abednego +Abel +Abel's +Abelard +Abelian +Abell +Abell's +Abelson +Abelson's +Abenaki +Abenakis +Abeokuta +Abercrombie +Abercrombie's +Aberdare +Aberdeen +Aberdeen's +Aberdeenshire +Aberdeenshire's +Aberdonian +Aberdonians +Abernant +Abernant's +Abernathy +Abernathy's +Aberystwyth +Aberystwyth's +Abib +Abibs +Abidjan +Abidjan's +Abigail +Abilene +Abingdon +Abington +Abington's +Abiquiu +Abiquiu's +Abkhas +Abkhases +Abkhasian +Abkhasians +Abkhaz +Abkhazes +Abkhazia +Abkhazia's +Abkhazian +Abkhazians +Abnaki +Abnaki's +Abnakis +Abner +Abner's +Abo +Abo's +Abolitionist +Abolitionists +Aboriginal +Aboriginal's +Aboriginals +Aborigine +Aborigine's +Aborigines +Abos +Abraham +Abraham's +Abram +Abram's +Abrams +Abroma +Abroma's +Abrus +Abrus's +Abruzzi +Abruzzi's +Abs +Absalom +Absaraka +Absaraka's +Absaroke +Absarokee +Absarokee's +Absarokes +Absecon +Absecon's +Abuja +Abukir +Abydos +Abyssinia +Abyssinia's +Abyssinian +Abyssinian's +Abyssinians +Ac +Ac's +Acadia +Acadia's +Acadian +Acadian's +Acadians +Acalepha +Acalepha's +Acalephae +Acalephae's +Acampo +Acampo's +Acanthaceae +Acanthaceae's +Acanthocephala +Acanthocephala's +Acapulco +Acapulco's +Acarida +Acarida's +Acarina +Acarina's +Acarnanian +Acarnanians +Accad +Accadian +Accadians +Accenture +Accenture's +Accokeek +Accokeek's +Accolate +Accolates +Accomac +Accomac's +Accoville +Accoville's +Accra +Accra's +Accrington +Accrington's +Accutane +Accutanes +Aceldama +Aceldamas +Aceraceae +Aceraceae's +Acevedo +Acevedo's +Achaea +Achaean +Achaean's +Achaeans +Achaemenian +Achaemenians +Achaemenid +Achaemenidae +Achaemenids +Achaia +Achaia's +Achaian +Achaian's +Achaians +Achates +Achateses +Achebe +Achebe's +Achelous +Achernar +Acheron +Acheron's +Acherontic +Acherontic's +Acheson +Acheson's +Acheulean +Acheulian +Achille +Achille's +Achillean +Achilles +Achilles's +Achitophel +Achomawi +Achomawi's +Achomawis +Achromycin +Achromycin's +Achromycins +Achumawi +Achumawis +Acis +Ackerly +Ackerly's +Ackermanville +Ackermanville's +Ackworth +Ackworth's +Acoma +Acomas +Aconcagua +Aconcagua's +Acorus +Acorus's +Acosta +Acosta's +Acra +Acra's +Acre +Acre's +Acrilan +Acrilan's +Acrilans +Acropolis +Acrux +Acrux's +Act +Actaeon +Actinomyces +Actinomyces's +Actinozoa +Actinozoa's +Actium +Actium's +Activase +Activase's +Activases +ActiveX +ActiveX's +Acton +Acts +Acuff +Acuff's +Acushnet +Acushnet's +Acworth +Acworth's +Ada +Ada's +Adah +Adah's +Adairsville +Adairsville's +Adairville +Adairville's +Adam +Adam's +Adamic +Adamical +Adamite +Adamites +Adamitic +Adamitical +Adamitical's +Adamitism +Adamitism's +Adams +Adamsbasin +Adamsbasin's +Adamsburg +Adamsburg's +Adamstown +Adamstown's +Adamsville +Adamsville's +Adan +Adan's +Adana +Adansonia +Adansonia's +Adapa +Adapa's +Adar +Adar's +Adars +Addams +Adderley +Adderley's +Addie +Addie's +Addieville +Addieville's +Addington +Addison +Addisonian +Addressograph +Addressograph's +Addressographs +Addy +Addy's +Addyston +Addyston's +Adel +Adel's +Adela +Adela's +Adelaide +Adelaide's +Adelanto +Adelanto's +Adelbert +Adelbert's +Adele +Adele's +Adelie +Adelie's +Adelies +Adeline +Adeline's +Adell +Adell's +Adelphi +Adelphi's +Adelphia +Adelphia's +Aden +Aden's +Adena +Adena's +Adenauer +Adger +Adger's +Adhara +Adhara's +Adiantum +Adiantum's +Adidas +Adidas's +Adige +Adige's +Adigranth +Adin +Adin's +Adirondack +Adirondack's +Adirondacks +Adirondacks's +Adjuntas +Adjuntas's +Adkins +Adkins's +Adler +Adlerian +Adm +Admetus +Administration +Administrations +Admiral +Admiral's +Admiralties +Admiralty +Adna +Adna's +Adolf +Adolf's +Adolfo +Adolfo's +Adolph +Adolph's +Adona +Adona's +Adonai +Adonia +Adonia's +Adonic +Adonic's +Adonis +Adonis's +Adonises +Adoptianism +Adoptianisms +Adoptionism +Adoptionisms +Adoptionist +Adoptionists +Adowa +Adrastus +Adrenalin +Adrenalin's +Adrenalins +Adriamycin +Adriamycins +Adrian +Adriana +Adriana's +Adrianople +Adrianople's +Adriatic +Adriatic's +Adrienne +Adrienne's +Adullamite +Adullamite's +Aduwa +Advent +Advent's +Adventism +Adventism's +Adventisms +Adventist +Adventist's +Adventists +Advents +Advil +Advil's +Adzhar +Adzharian +Adzharians +Adzhars +Aegaeon +Aegean +Aegean's +Aegeus +Aegina +Aegina's +Aeginetan +Aeginetans +Aegir +Aegisthus +Aegospotami +Aegospotami's +Aegyptus +Aelfric +Aelfric's +Aeneas +Aeneas's +Aeneid +Aeneid's +Aeneolithic +Aeolia +Aeolia's +Aeolian +Aeolian's +Aeolians +Aeolic +Aeolic's +Aeolics +Aeolis +Aeolis's +Aeolus +Aeolus's +Aepyornis +Aepyornis's +Aeroflot +Aeroflot's +Aeschines +Aeschylean +Aeschylus +Aeschylus's +Aesculapian +Aesculapius +Aesculapius's +Aesculus +Aesculus's +Aesir +Aesir's +Aesop +Aesop's +Aesopian +Aesopic +Aethiopian +Aethiopian's +Aetna +Aetolia +Aetolian +Aetolians +Af +Afghan +Afghan's +Afghani +Afghani's +Afghanis +Afghanistan +Afghanistan's +Afghans +Aflex +Aflex's +Afr +Afric +Afric's +Africa +Africa's +African +African's +Africana +Africander +Africander's +Africanders +Africanisation +Africanisations +Africanise +Africanised +Africanises +Africanising +Africanism +Africanisms +Africanist +Africanists +Africanness +Africannesses +Africanoid +Africanoid's +Africans +Afrikaans +Afrikaans's +Afrikander +Afrikander's +Afrikanders +Afrikaner +Afrikaner's +Afrikanerdom +Afrikanerdoms +Afrikaners +Afro +Afro's +Afroasiatic +Afroasiatic's +Afrocentric +Afrocentrism +Afrocentrisms +Afrocentrist +Afrocentrists +Afros +Afton +Afton's +Ag +Ag's +Agada +Agadic +Agadic's +Agadir +Agadoth +Agamemnon +Agamemnon's +Agamidae +Agamidae's +Agana +Aganippe +Aganippe's +Agapemone +Agapemone's +Agar +Agar's +Agassi +Agassi's +Agassiz +Agassiz's +Agatha +Agatha's +Agawam +Agawam's +Age +Agee +Agee's +Ages +Aggada +Aggadah +Aggadahs +Aggadic +Aggadist +Aggadists +Aggadot +Aggadoth +Aggeus +Aggeus's +Aggie +Aggies +Agincourt +Agincourt's +Aglaia +Agnes +Agness +Agnew +Agnew's +Agni +Agni's +Agra +Agram +Agricola +Agrigento +Agrippa +Agrippa's +Agrippina +Agrippina's +Aguada +Aguada's +Aguadilla +Aguadilla's +Aguadulce +Aguadulce's +Aguanga +Aguanga's +Aguascalientes +Aguecheek +Aguecheek's +Aguila +Aguila's +Aguilar +Aguilar's +Aguinaldo +Aguinaldo's +Aguirre +Aguirre's +Agulhas +Agustin +Agustin's +Agutter +Agutter's +Ahab +Ahab's +Ahaggar +Ahaggar's +Ahasuerus +Ahern +Ahern's +Ahgwahching +Ahgwahching's +Ahithophel +Ahmad +Ahmad's +Ahmadabad +Ahmadinejad +Ahmadinejad's +Ahmed +Ahmed's +Ahmedabad +Ahmednagar +Ahmeek +Ahmeek's +Ahoskie +Ahoskie's +Ahriman +Ahriman's +Ahsahka +Ahsahka's +Ahuramazda +Ahuramazda's +Ahvenanmaa +Ahwahnee +Ahwahnee's +Ahwaz +Aibonito +Aibonito's +Aida +Aida's +Aidan +Aidan's +Aidoneus +Aidoneus's +Aiea +Aiea's +Aiken +Aileen +Aileen's +Ailey +Ailey's +Aimee +Aimee's +Aimwell +Aimwell's +Ain +Ainsworth +Ainsworth's +Aintab +Aintree +Aintree's +Ainu +Ainus +Airdrie +Aire +Aire's +Airedale +Airedale's +Airedales +Airville +Airville's +Aisha +Aisne +Aitken +Aitkin +Aitkin's +Aizoaceae +Aizoaceae's +Aizoon +Aizoon's +Ajaccio +Ajax +Ajax's +Ajmer +Ajo +Ajo's +Akaba +Akaba's +Akan +Akan's +Akans +Akaska +Akaska's +Akbar +Akela +Akela's +Akelas +Akeley +Akeley's +Akhenaton +Akhenaton's +Akhmatova +Akhmatova's +Akhnaton +Akhnaton's +Akiachak +Akiachak's +Akiak +Akiak's +Akihito +Akita +Akitas +Akiva +Akiva's +Akkad +Akkadian +Akkadian's +Akkadians +Akkerman +Akmolinsk +Akron +Akron's +Aksum +Akutan +Akutan's +Al +Al's +Ala +Alabama +Alabama's +Alabaman +Alabaman's +Alabamans +Alabamas +Alabamian +Alabamian's +Alabamians +Alachua +Alachua's +Aladdin +Aladdin's +Alagez +Alagoas +Alai +Alai's +Alakanuk +Alakanuk's +Alamance +Alamance's +Alamein +Alamine +Alamines +Alamo +Alamo's +Alamogordo +Alamogordo's +Alamosa +Alamosa's +Alamota +Alamota's +Alan +Alan's +Alana +Alana's +Alanbrooke +Alanbrooke's +Alanreed +Alanreed's +Alanson +Alanson's +Alapaha +Alapaha's +Alar +Alar's +Alaric +Alars +Alas +Alaska +Alaska's +Alaskan +Alaskan's +Alaskans +Alb +Alba +Albacete +Alban +Alban's +Albania +Albania's +Albanian +Albanian's +Albanians +Albany +Albany's +Albee +Albemarle +Albemarle's +Albeniz +Albeniz's +Alberich +Alberio +Alberio's +Albers +Albert +Alberta +Alberta's +Albertan +Albertans +Alberti +Albertist +Albertists +Albertlea +Albertlea's +Alberto +Alberto's +Alberton +Alberton's +Albertson +Albertson's +Albertville +Albertville's +Albi +Albia +Albia's +Albigenses +Albigensian +Albigensianism +Albigensianisms +Albigensians +Albin +Albin's +Albinoni +Albinoni's +Albinus +Albion +Albireo +Albireo's +Alboin +Alborg +Alborg's +Alborn +Alborn's +Albright +Albright's +Albuquerque +Albuquerque's +Albuquerquean +Albuquerqueans +Alburg +Alburg's +Alburnett +Alburnett's +Alburtis +Alburtis's +Alcaeus +Alcaeus's +Alcaic +Alcaic's +Alcaics +Alcalde +Alcalde's +Alcatraz +Alcelaphus +Alcelaphus's +Alceste +Alcester +Alcester's +Alcestis +Alcibiadean +Alcibiades +Alcidae +Alcidae's +Alcides +Alcides's +Alcindor +Alcindor's +Alcmena +Alcmena's +Alcmene +Alco +Alco's +Alcoa +Alcoa's +Alcock +Alcock's +Alcolu +Alcolu's +Alcor +Alcor's +Alcoran +Alcorans +Alcott +Alcova +Alcova's +Alcuin +Alcyonaria +Alcyonaria's +Alcyone +Alcyonium +Alcyonium's +Ald +Alda +Alda's +Aldabra +Aldabra's +Aldan +Aldebaran +Aldebaran's +Aldeburgh +Aldeburgh's +Alden +Aldenville +Aldenville's +Alderamin +Alderamin's +Aldermaston +Aldermaston's +Alderney +Alderneys +Aldershot +Alderson +Alderson's +Aldhelm +Aldhelm's +Aldiborontiphoscophornia +Aldiborontiphoscophornia's