tclquadcode: Artifact [ad030c24b9]

Artifact ad030c24b96b163b55c0c8d41481da9852a15d2b:

File codegen/compile.tcl — part of check-in [1b5ad48130] at 2017-09-17 22:14:49 on branch namespace-variables — Direct variable access: merge in dkf-direct-variables, make varframe.tcl not crash. Need code and test cases for spoliation of local may-alias vars when direct vars are updated. (user: kbk size: 66288) [more...]
# compile.tcl --
#
#	Engine that handles compiling and issuing code for a single Tcl
#	procedure. Note that this needs to be done within the context of an
#	LLVM module (which is approximately the same concept as a compilation
#	unit in a language like C).
#
# Copyright (c) 2014-2017 by Donal K. Fellows
# Copyright (c) 2014-2015 by Kevin B. Kenny
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------

# Class TclCompiler --
#
#	This class compiles a function derived from Tcl bytecode.
#
# Construction Parameters:
#	none
#
# Public properties:
#	none

oo::class create TclCompiler {
    superclass llvmEntity
    variable bytecode cmd func quads paramTypes returnType vtypes variables
    variable m b pc errorCode currentline currentscript
    variable bytecodeVars namespace

    constructor {} {
	next
	namespace import \
	    ::quadcode::nameOfType \
	    ::quadcode::typeOfLiteral \
	    ::quadcode::typeOfOperand \
	    ::quadcode::dataType::mightbea
	namespace eval tcl {
	    namespace eval mathfunc {
		proc literal {descriptor} {
		    string equal [lindex $descriptor 0] "literal"
		}
		proc refType {type} {
		    expr {
			[uplevel 1 [list my ReferenceType? $type]]
			&& "CALLFRAME" ni $type
		    }
		}
		proc failType {type} {
		    uplevel 1 [list my FailureType? $type]
		}
		proc operandType {operand} {
		    uplevel 1 [list my OperandType $operand]
		}
		proc consumed {var search} {
		    uplevel 1 [list my IsConsumed $var $search]
		}
		proc callframe {operand} {
		    uplevel 1 [list my IsCallFrame $operand]
		}
	    }
	}
    }

    # TclCompiler:ByteCode --
    #
    #	Sets the bytecode description dictionary that this compiler code
    #	generator will work with. Used for a number of things.
    #
    # Parameters:
    #	command -
    #		The name of the command being compiled.
    #	bytecode -
    #		The bytecode description dictionary being compiled.
    #
    # Results:
    #	None

    method ByteCode {command bytecodeDict} {
	set cmd $command
	set bytecode $bytecodeDict
	catch {
	    dict set bytecode argumentDefaults [lmap v [info args $cmd] {
		set def ""
		list $v [info default $cmd $v def] $def
	    }]
	}
	set bytecodeVars [dict get $bytecode variables]
	set namespace [dict get $bytecode namespace]
	return
    }

    # TclCompiler:InitTypeInfo --
    #
    #	Sets the argument types, result type, and variable-type mapping for
    #	the quadcode.
    #
    # Parameters:
    #	argumentTypes -
    #		The Tcl list of typecodes, representing the arguments to the
    #		function in order.
    #	resultType -
    #		The typecode of the return type.
    #	typeMap -
    #		The variable-typecode mapping dictionary used to describe what
    #		the type of each variable in the quadcode is.
    #
    # Results:
    #	None

    method InitTypeInfo {argumentTypes resultType typeMap} {
	set vtypes $typeMap
	set paramTypes $argumentTypes
	set returnType $resultType
	return
    }

    # TclCompiler:PrintTypedQuads --
    #
    #	Print the sequence of typed quadcodes that the type inference engine
    #	has transformed the procedure into.
    #
    # Parameters:
    #	channel -
    #		Where to write the message.
    #	qs -	The quadcode to print.
    #
    # Results:
    #	None.

    method PrintTypedQuads {channel qs} {
	set idx -1
	set descriptions [lmap q $qs {
	    concat "[incr idx]:" $q ":" [linsert [lmap arg [lrange $q 1 end] {
		try {
		    if {$arg eq ""} {
			string cat VOID
		    } elseif {[string match {pc *} $arg]} {
			string cat BLOCK
		    } else {
			my ValueTypes $arg
		    }
		} on error {} {
		    string cat VOID
		}
	    }] 1 \u21d0]
	}]
	if {$channel eq ""} {
	    return [format "%s------>\n%s" $cmd [join $descriptions \n]]
	} else {
	    puts $channel [format "%s------>\n%s" $cmd [join $descriptions \n]]
	}
    }

    # TclCompiler:generateDeclaration --
    #
    #	Generate the declaration for the function that we are transforming the
    #	Tcl code into.
    #
    # Parameters:
    #	module -
    #		The module reference (i.e., instance of Module class) to
    #		generate the function within.
    #
    # Results:
    #	The function reference (i.e., instance of Function class) that we have
    #	generated. Note that this will be an unimplemented function at this
    #	stage.

    method generateDeclaration {module} {
	set m $module

	##############################################################
	#
	# Compute the argument types
	#

	set argl {}
	set argn {}
	foreach typecode $paramTypes {
	    set type [nameOfType $typecode]
	    lappend argn $type
	    lappend argl [Type $type]
	}

	##############################################################
	#
	# Compute the return type
	#

	set rtype [nameOfType $returnType]
	set returntype [Type $rtype]

	##############################################################
	#
	# Construct the function signature type and the function object.
	#

	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]} {
	    return -code error "duplicate $cmd"
	}

	set func [$m function.create $realname $ft]
	return $func
    }

    # TclCompiler:Compile --
    #
    #	Generate the body for the function that we are transforming the Tcl
    #	code into.
    #
    # Parameters:
    #	quadcode -
    #		The quadcode that defines the Tcl code we are translating.
    #
    # Results:
    #	The LLVM function reference that we have generated.

    method Compile {quadcode} {
	set quads $quadcode
	namespace upvar ::quadcode::dataType STRING STRING

	##############################################################
	#
	# Create builder, basic blocks and error code context
	#

	set b [$m builder]
	if {[dict exists $bytecode sourcefile]} {
	    $m debug file [dict get $bytecode sourcefile]
	}
	$func setAsCurrentDebuggingScope

	lassign [my GenerateBasicBlocks $quads] blockDict ipathDict pred
	array set block $blockDict
	array set ipath $ipathDict

	# NB: block(-1) is the function entry block. It's supposed to be
	# almost entirely optimized out.
	$block(-1) build-in $b
	$b @location 0
	set errorCode [$b alloc int "tcl.errorCode"]
	set curr_block $block(-1)
	set 0 [$b int 0]

	##############################################################
	#
	# Create stubs for variables in LLVM; because of loops, uses may occur
	# before a variable is written to.
	#

	dict for {name typecode} $vtypes {
	    lassign $name kind formalname origin
	    set type [nameOfType $typecode]

	    # Make the debugging information for the variable provided it is a
	    # variable as perceived from the Tcl level. "Internal" temporary
	    # variables aren't nearly so interesting.

	    if {$kind eq "var"} {
		if {[lindex $quads $origin 0] eq "param"} {
		    set idx [lsearch $bytecodeVars \
			[list "scalar arg" $formalname]]
		    if {$idx < 0} {
			return -code error \
			    "unmapped formal variable name: $formalname ($name)"
		    }
		    if {[catch {
			$func param $idx $formalname
		    }]} {
			# Not actually a parameter, because of default
			# arguments; set up the debugging metadata as a local
			# variable.
			$func localvar $formalname $type
		    }
		} else {
		    # Not a parameter; set up the debugging metadata as a
		    # local variable.
		    $func localvar $formalname $type
		}
	    }

	    # This is awful, but these *must* be unique things to replace, so
	    # we make them be individual loads of a memory location that has
	    # never been written to. This prevents them from being coalesced
	    # too early by the constant management engine; merely using an
	    # undef would make disparate values become unified.
	    #
	    # It is a major problem if any of these actually survives the
	    # optimisation phase.
	    #
	    # This cannot be left until the first reference to the variable;
	    # that might be from a phi, and those must be first in their basic
	    # blocks.

	    if {![info exist undefs($type)]} {
		set tycode [expr {$type eq "VOID" ? "void*" : $type}]
		set undefs($type) [$b alloc $tycode "undef.$type"]
	    }
	    set variables($name) [$b load $undefs($type) "undef.$formalname"]
	}

	##############################################################
	#
	# Convert Tcl parse output, one instruction at a time.
	#

	set pc -1
	set ERROR_TEMPLATE "\n    (compiling \"%s\" @ pc %d: %s)"
	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)
		set consumed {}
	    }
	    unset -nocomplain tgt

	    ##########################################################
	    #
	    # Issue the code for a single quadcode instruction.
	    #

	    try {
	    $b @location $currentline
	    switch -exact -- [lindex $l 0 0] {
		"entry" {
		    lassign [my IssueEntry $l] \
			theframe thevarmap syntheticargs
		}
		"confluence" - "unset" {
		    # Do nothing; required for SSA computations only
		}
		"@debug-line" {
		    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
		    # a variable" is good enough anyway, and that is handled
		    # in TclCompiler:StoreResult.
		    my Warn "unexpected @debug-value opcode at ${cmd}:$pc"
		}
		"param" {
		    lassign $l opcode tgt src
		    set idx [lindex $src 1]
		    set name [lindex $tgt 1]
		    set type [my OperandType $tgt]
		    set ftype [GetElementType [$func type]]
		    if {$idx >= [CountParamTypes $ftype]} {
			set defaultdict [dict get $bytecode argumentDefaults]
			set defaultvalue [lindex $defaultdict $idx 2]
			my Warn "default injection for parameter %d of '%s'; injecting '%s'" \
			    $idx [GetValueName [$func ref]] $defaultvalue
			set var [my LoadTypedLiteral $defaultvalue $type]
		    } else {
			set var [$func param $idx $name]
		    }
		    set variables($tgt) $var
		    if {[regexp {^IMPURE } $type]} {
			set var [$b stringifyImpure $var]
			set type STRING
		    }
		    if {refType($type)} {
			$b printref $var "param:"
			$b addReference($type) $var
			$b assume [$b shared $var]
		    }
		}
		"moveToCallFrame" {
		    set mapping [lassign $l opcode tgt src]
		    if {callframe($src)} {
			foreach {name value} $mapping {
			    set name [lindex $name 1]
			    set var [dict get $thevarmap $name]
			    if {$value ne "Nothing"} {
				set op frame.store([my ValueTypes $value])
				set value [my LoadOrLiteral $value]
				$b $op $value $theframe $var $name
			    } else {
				$b frame.unset $theframe $var $name
			    }
			}
		    }
		    my StoreResult $tgt [my LoadOrLiteral $src]
		}
		"retrieveResult" {
		    lassign $l opcode tgt src
		    if {[my ValueTypes $src] eq "CALLFRAME"} {
			set value [$b undef NOTHING]
		    } elseif {"CALLFRAME" in [my ValueTypes $src]} {
			set value [$b frame.value [my LoadOrLiteral $src]]
		    } else {
			set value [my LoadOrLiteral $src]
			my Warn "retrieveResult from non-callframe"
		    }
		    my StoreResult $tgt $value
		}
		"extractCallFrame" {
		    lassign $l opcode tgt src
		    if {callframe($src)} {
			set value [my LoadOrLiteral $src]
			if {[my ValueTypes $src] ne "CALLFRAME"} {
			    set name [my LocalVarName $tgt]
			    set value [$b frame.frame $value $name]
			}
		    } else {
			set value $theframe
		    }
		    my StoreResult $tgt $value
		}
		"moveFromCallFrame" {
		    lassign $l opcode tgt src varname
		    if {callframe($src)} {
			set name [my LocalVarName $tgt]
			set vname [lindex $varname 1]
			set var [dict get $thevarmap $vname]
			my StoreResult $tgt \
			    [$b frame.load $theframe $var $vname $name]
		    }
		}
		"returnOptions" - "result" {
		    set srcs [lassign $l opcode tgt]
		    set name [my LocalVarName $tgt]
		    set srctype [my ValueTypes [lindex $srcs 0]]
		    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" - "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]
		}
		"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}]
		    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] ,]
		    set srcs [lmap s $srcs {my LoadOrLiteral $s}]
		    my StoreResult $tgt [$b list $srcs $types $name]
		}
		"strindex" {
		    set srcs [lassign $l opcode tgt]
		    set name [my LocalVarName $tgt]
		    set srcs [my ConvertIndices 0 strlen 1]
		    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]
		    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}]
		    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]
		}
		"initException" {
		    my IssueException $l
		}
		"setReturnCode" {
		    lassign $l opcode - src
		    $b store [$b getInt32 [my LoadOrLiteral $src]] $errorCode
		}
		"dictExists" {
		    my IssueDictExists $l
		}
		"dictGet" - "dictUnset" - "listIndex" {
		    set srcs [lassign $l opcode tgt srcObj]
		    set name [my LocalVarName $tgt]
		    if {[llength $srcs] == 1} {
			# Simple case
			set srcs [list $srcObj {*}$srcs]
			append opcode ( [my ValueTypes {*}$srcs] )
			set srcs [lmap s $srcs {my LoadOrLiteral $s}]
			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]
			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}]
			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}]
			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]
		    set name [my LocalVarName $tgt]
		    SetValueName $value $name
		    if {refType($type)} {
			$b addReference($type) $value
			$b printref $value "copy:"
		    }
		    my StoreResult $tgt $value
		}
		"maptoint" {
		    lassign $l opcode tgt src map def
		    set map [lindex $map 1]
		    set def [lindex $def 1]
		    set name [my LocalVarName $tgt]
		    append opcode ( [my ValueTypes $src] )
		    set src [my LoadOrLiteral $src]
		    my StoreResult $tgt [$b $opcode $src $map $def $name]
		}
		"extractExists" - "extractMaybe" {
		    my IssueExtract $l
		}
		"purify" {
		    lassign $l opcode tgt src
		    set value [my LoadOrLiteral $src]
		    if {![regexp {^IMPURE} [my OperandType $src]]} {
			return -code error \
			    "Trying to purify something that is not impure"
		    }
		    set name [my LocalVarName $tgt]
		    set value [$b impure.value $value $name]
		    set type [my OperandType $tgt]
		    if {refType($type)} {
			$b addReference($type) $value
			$b printref $value "purify:"
		    }
		    my StoreResult $tgt $value
		}
		"free" {
		    lassign $l opcode tgt src
		    set type [my OperandType $src]
		    if {$src ni $consumed} {
			if {$type eq "VOID"} {
			    # VOID is trivial to free
			} elseif {refType($type)} {
			    $b printref $variables($src) "free:"
			    $b dropReference([my ValueTypes $src]) $variables($src)
			}
			lappend consumed $src
		    }
		}
		"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
		}
		"jumpMaybe" {
		    lassign $l opcode tgt src
		    set tgt [lindex $tgt 1]
		    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
		    set tgt [lindex $tgt 1]
		    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
		    set name [my LocalVarName $src]
		    set tgt [lindex $tgt 1]
		    set neq neq([my ValueTypes $src],INT)
		    set test [$b $neq [my LoadOrLiteral $src] $0 test_$name]
		    $b condBr $test $block($tgt) $ipath($pc)
		}
		"jumpFalse" {
		    lassign $l opcode tgt src
		    set name [my LocalVarName $src]
		    set tgt [lindex $tgt 1]
		    set neq neq([my ValueTypes $src],INT)
		    set test [$b $neq [my LoadOrLiteral $src] $0 test_$name]
		    $b condBr $test $ipath($pc) $block($tgt)
		}
		"jump" {
		    $b br $block([lindex $l 1 1])
		}
		"return" {
		    lassign $l opcode -> frame src
		    set vt [my ValueTypes $src]
		    set val [my LoadOrLiteral $src]
		    if {"CALLFRAME" in $vt} {
			set val [$b frame.value $val]
		    }
		    set type [nameOfType $returnType]
		    if {refType($type)} {
			$b printref $val "ret:"
			if {literal($src)} {
			    $b addReference($type) $val
			}
		    }
		    if {$theframe ne "" && ![IsNull $theframe]} {
			$b frame.release $theframe $syntheticargs
		    }
		    $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 {
			$b ret [$b fail [nameOfType $returnType] $code]
		    }
		}
		"phi" {
		    set values {}
		    set sources {}
		    foreach {var origin} [lassign $l opcode tgt] {
			set spc [lindex $origin end]
			while {![info exists block($spc)]} {incr spc -1}
			set s $block($spc)
			if {$s ni [dict get $pred $curr_block]} {
			    my Warn "%s not predecessor to %s in %s; skipping..." \
				[$s name] [$curr_block name] $cmd
			    continue
			}
			lappend sources $s
			lappend values [my LoadOrLiteral $var]
		    }
		    set name phi_[my LocalVarName $tgt]
		    set value [$b phi $values $sources $name]
		    my StoreResult $tgt $value "phi"
		    if {[lindex $quads [expr {$pc+1}] 0 0] ne "phi"} {
			foreach {name value} $phiAnnotations {
			    my AnnotateAssignment $name $value
			}
			set phiAnnotations {}
		    }
		}
		"invoke" {
		    set arguments [my IssueInvoke $theframe $l]
		    foreach aa $arguments {
			set arguments [lassign $arguments a]
			if {$a ni $arguments && consumed($a, $pc + 1)} {
			    lappend consumed $a
			}
		    }
		}
		"strcat" {
		    set srcs [lassign $l opcode tgt src1]
		    set name [my LocalVarName $tgt]
		    set type [my OperandType $src1]
		    set val [my LoadOrLiteral $src1]
		    if {!refType($type)} {
			set result [$b stringify($type) $val $name]
			$b addReference(STRING) $result
		    } elseif {$src1 ni $srcs && consumed($src1, $pc + 1)} {
			set result [$b unshare($type) $val $name]
			lappend consumed $src1
		    } else {
			set result [$b unshareCopy($type) $val $name]
		    }
		    $b printref $result "cat:"
		    foreach src $srcs {
			set val [my LoadOrLiteral $src]
			$b appendString([my ValueTypes $src]) $val $result
		    }
		    my StoreResult $tgt $result
		}
		"concat" {
		    set srcs [lassign $l opcode tgt]
		    # Need to construct the variadic vector
		    set vectortypes [lmap s $srcs {my ValueTypes $s}]
		    set vector [$b buildVector $vectortypes \
			    [lmap s $srcs {my LoadOrLiteral $s}]]
		    set name [my LocalVarName $tgt]
		    set result [$b concat() $vector $name]
		    my StoreResult $tgt $result
		    $b clearVector $srcs $vector $vectortypes
		}
		"foreachStart" {
		    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" -
		"dictIterNext" {
		    lassign $l opcode tgt src
		    set name [my LocalVarName $tgt]
		    set result [$b $opcode [my LoadOrLiteral $src] $name]
		    my StoreResult $tgt $result
		}
		"widenTo" {
		    lassign $l opcode tgt src
		    my IssueWiden $l
		}
		"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]
		    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
		    set name [my LocalVarName $tgt]
		    set type2 [my OperandType $src]
		    if {$type eq $type2} {
			if {$opcode eq "instanceOf"} {
			    set value [$b int 1]
			} else {
			    set value [my LoadOrLiteral $src]
			    if {refType($type)} {
				$b printref $value "trivial-narrow:"
				$b addReference($type) $value
			    }
			}
		    } elseif {"NOTHING" in $type} {
			# Should be an unreachable path
			set value [$b undef $type]
		    } else {
			set type [string map {" " _} $type]
			append opcode . $type ( $type2 )
			set value [$b $opcode [my LoadOrLiteral $src] $name]
		    }
		    my StoreResult $tgt $value
		}
		"checkArithDomain" {
		    lassign $l opcode tgt src opname
		    lassign $opcode opcode - type
		    set tgt [lindex $tgt 1]
		    set msg [format \
			"can't use non-numeric string as operand of \"%s\"" \
			[my LiteralValue $opname]]
		    set exn "ARITH DOMAIN {non-numeric string}"
		    set type2 [my OperandType $src]
		    if {$type eq $type2} {
			$b br $ipath($pc)
		    } else {
			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
		    set msg [format \
			"can't use non-numeric string as operand of \"%s\"" \
			[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" {
		    # These are supposed to never reach here; assert it
		    return -code error \
			"opcode '[lindex $opcode 0]' sent to code issuer"
		}

		default {
		    return -code error "$cmd: unknown opcode '[lindex $l 0 0]' in '$l'"
		}
	    }
	    } on error {msg opts} {
		dict append opts -errorinfo \
		    [format $ERROR_TEMPLATE $cmd $pc $l]
		return -options $opts $msg
	    } on return {msg opts} {
		if {[dict get $opts -code] == 1} {
		    dict set opts -errorinfo $msg
		    dict append opts -errorinfo \
			[format $ERROR_TEMPLATE $cmd $pc $l]
		}
		return -options $opts $msg
	    }
	}
	$b @loc {}

	##############################################################
	#
	# Set increment paths, so that where we have a basic block that just
	# falls through to its successor (not permitted in LLVM IR) we convert
	# it to an explicit jump.
	#

	set maxpc $pc
	foreach {pc blk} [array get block] {
	    if {[$blk terminated]} continue
	    while {[incr pc] <= $maxpc} {
		if {[info exists block($pc)]} {
		    $blk build $b {
			$b br $block($pc)
		    }
		    break
		}
	    }
	}

	##############################################################
	#
	# Cleanup and return
	#

	$func verify
	return [$func ref]
    }

    # TclCompiler:GenerateBasicBlocks --
    #
    #	Generate the basic blocks for a function being compiled from Tcl
    #	code. Called from compile.
    #
    # Parameters:
    #	quads -	The quadcode describing the function to compile.
    #
    # Results:
    #	A list of three dictionaries. The first dictionary maps program
    #	counters to basic blocks (using the PC that corresponds to the first
    #	instruction in the basic block; -1 designates the special "function
    #	entry" block that is reserved for the code issuer). The second
    #	dictionary says which block contains the next instruction (necessary
    #	for forking jumps); i.e., the Instruction Path. The third says which
    #	blocks are the predecessors of the current block.

    method GenerateBasicBlocks {quads} {
	# Instructions that will always jump.
	set JUMPS {jump throwNotExists throwArithDomainError}
	# Instructions that can go to either the next instruction OR the named
	# instruction.
	set FORKJUMPS {
	    jumpFalse jumpTrue
	    jumpMaybe jumpMaybeNot
	    checkArithDomain
	    throwIfNotExists
	}
	# Instructions that terminate execution of the function.
	set EXITS {return returnException}

	##############################################################
	#
	# Create basic blocks
	#

	set block(-1) [$func block]
	set next_is_ipath 1
	set pc -1
	foreach q $quads {
	    incr pc
	    set opcode [lindex $q 0 0]
	    if {$next_is_ipath >= 0} {
		if {![info exists block($pc)]} {
		    set block($pc) [$func block "pc.$pc"]
		}
		set ipath($next_is_ipath) $pc
		set next_is_ipath -1
	    }
	    if {$opcode in $JUMPS || $opcode in $FORKJUMPS} {
		# opcode {pc addr} ...
		set tgt [lindex $q 1 1]
		if {![info exists block($tgt)]} {
		    set block($tgt) [$func block "pc.$tgt"]
		}
		set next_is_ipath $pc
	    } elseif {$opcode in $EXITS} {
		set next_is_ipath $pc
	    }
	}

	##############################################################
	#
	# Compute the predecessors of each basic block
	#

	set pc -1
	set pred {}
	set cb $block(-1)
	foreach q $quads {
	    incr pc
	    if {![info exist cb]} {
		set cb $block($pc)
	    } elseif {[info exist block($pc)]} {
		dict lappend pred $block($pc) $cb
		set cb $block($pc)
	    }
	    set opcode [lindex $q 0 0]
	    if {$opcode in $JUMPS} {
		dict lappend pred $block([lindex $q 1 1]) $cb
		unset cb
	    } elseif {$opcode in $FORKJUMPS} {
		dict lappend pred $block([lindex $q 1 1]) $cb
		dict lappend pred $block([expr {$pc + 1}]) $cb
		unset cb
	    } elseif {$opcode in $EXITS} {
		unset cb
	    }
	}

	##############################################################
	#
	# Dereference the ipaths.
	#

	set idict {}
	foreach pc [array names ipath] {
	    dict set idict $pc $block($ipath($pc))
	}

	list [array get block] $idict $pred
    }

    # TclCompiler:IssueEntry --
    #
    #	Generate the code for creating a callframe at the start of a function.
    #	Must only be called from the 'compile' method.
    #
    # Parameters:
    #	quad -	The 'entry' quadcode, including its parameters.
    #
    # Results:
    #	A triple of the callframe, the local variable mapping, and a list
    #	saying which elements in the callframe are synthetic (i.e., have no
    #	existing string representation) and need to be released on function
    #	exit.

    method IssueEntry {quad} {
	lassign $quad opcode tgt vars

	# When no frame is wanted
	if {$tgt eq {}} {
	    return [list [$b null CALLFRAME] {} {}]
	}

	# Store the fact that we must generate complex metadata for this
	# function/command, and the variable where this metadata will be
	# stored.
	if {![dict exists $bytecode procmeta]} {
	    dict set bytecode procmeta \
		[$m variable [list procmeta $cmd] Proc* [$b null Proc*]]
	    dict set bytecode localcache \
		[$m variable [list localcache $cmd] LocalCache* \
		     [$b null LocalCache*]]
	}

	# Build the argument list. First, we get the Tcl descriptors of the
	# arguments, their types, etc.
	set varmeta [dict get $bytecode variables]
	set argtypes {STRING}
	set arguments [list [list literal $cmd]]
	foreach vinfo $varmeta {
	    if {"arg" in [lindex $vinfo 0]} {
		set vname [list var [lindex $vinfo 1] [llength $arguments]]
		lappend arguments $vname
		lappend argtypes [my ValueTypes $vname]
	    }
	}

	# Now we allocate the storage for the argument list
	set argc [Const [llength $arguments]]
	set argv [$b alloc [Type array{Tcl_Obj*,[llength $arguments]}] argv]

	# Store the arguments in the argument list
	set cell [$b gep $argv 0 0]
	$b store [Const $cmd STRING] $cell
	set idx -1
	set drop 0
	foreach v $arguments t $argtypes {
	    if {[incr idx]} {
		set val [$b stringify($t) [$func param [expr {$idx-1}]]]
		$b store $val [$b gep $argv 0 $idx]
		lappend drop [expr {!refType($t)}]
	    }
	}

	# Create the stack frame
	set procmeta [dict get $bytecode procmeta]
	set localcache [dict get $bytecode localcache]
	lassign [$b frame.create $varmeta $argc $argv \
			[$b load $procmeta "proc.metadata"] \
			[$b load $localcache "proc.localcache"]] \
	    theframe thevarmap
	my StoreResult $tgt $theframe
	return [list $theframe $thevarmap $drop]
    }

    # TclCompiler:IssueInvoke --
    #
    #	Generate the code for invoking another Tcl command. Must only be
    #	called from the 'compile' method.
    #
    # Parameters:
    #	callframe -
    #		The callframe.
    #	operation -
    #		The quadcode descriptor for the instruction.
    #
    # Results:
    #	The set of arguments that might have been consumed in the operation
    #	(for cleanup by the caller of this method).

    method IssueInvoke {callframe operation} {
	set arguments [lassign $operation opcode tgt thecallframe origname]
	set vname [my LocalVarName $tgt]
	set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING}

	# Is this a literal name for a function we already know the signature
	# of? If so, we can use a direct call. To work this out, we need to
	# resolve the command within the namespace context of the procedure.

	if {literal($origname)} {
	    # Resolve the name.
	    set name [my FuncName [lindex $origname 1]]
	    set fullname [my GenerateFunctionName $name arguments $arguments]
	    if {[$m function.defined $fullname]} {
		set called [[$m function.get $fullname] ref]
		set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
		my IssueInvokeFunction $tgt $called $argvals $vname
		return {}
	    }
	    if {[dict exist $vtypes $tgt]} {
		set type [nameOfType [dict get $vtypes $tgt]]
		if {"FAIL" ni $type || "STRING" ni $type} {
		    my Warn "didn't find implementation of '$fullname'"
		}
	    }
	    set origname [list literal $name]
	}

	set arguments [list $origname {*}$arguments]
	set argvals [lmap s $arguments {my LoadOrLiteral $s}]

	# Dynamic dispatch via direct call is OK, *provided* someone has
	# fetched the function reference for us.

	if {[TypeOf [lindex $argvals 0]] ne [Type STRING]} {
	    set argvals [lassign $argvals called]
	    my IssueInvokeFunction $tgt $called $argvals $vname
	    return {}
	}

	# Must dispatch via the Tcl command API. This is the slowest option
	# with the least type inference possible (everything goes as a
	# STRING) but it is a reasonable fallback if nothing else works.

	my IssueInvokeCommand $tgt $arguments $argvals $vname
	return $arguments
    }

    method IssueInvokeFunction {tgt func arguments vname} {
	upvar 1 callframe callframe thecallframe thecallframe
	set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING}

	set result [$b call $func $arguments $vname]
	if {[my ValueTypes $tgt] eq "FAIL"} {
	    # 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]
	}
	my StoreResult $tgt $result
    }

    method IssueInvokeCommand {tgt arguments argvals vname} {
	upvar 1 callframe callframe thecallframe thecallframe

	set types [lmap s $arguments {my ValueTypes $s}]
	set vector [$b buildVector $types $argvals]

	# TODO: Pass in the resolution context (namespace ref).
	# TODO: Make the invoke do something sensible with that namespace
	# 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
    }

    # TclCompiler:IssueWiden --
    #
    #	Generate the code for widening the type of a value. Must only be
    #	called from the 'compile' method.
    #
    # Parameters:
    #	operation -
    #		The quadcode descriptor for the instruction.
    #
    # Results:
    #	none

    method IssueWiden {operation} {
	lassign $operation opcode tgt src
	set name [my LocalVarName $tgt]
	set srctype [my ValueTypes $src]
	set tgttype [lindex $opcode 2]
	if {$tgttype eq ""} {
	    set tgttype [my OperandType $tgt]
	}
	if {$srctype in {"VOID" "NOTHING" "NEXIST"}} {
	    switch -glob -- $tgttype {
		"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 {}"]
		}
		default {
		    # Should be unreachable in practice
		    set value [$b undef $tgttype]
		}
	    }
	} else {
	    set value [my LoadOrLiteral $src]
	    set value [my WidenedComplexValue $value $srctype $tgttype]
	}
	SetValueName $value $name
	if {refType($tgttype)} {
	    $b addReference($tgttype) $value
	    $b printref $value "widen:"
	}
	my StoreResult $tgt $value
	return
    }

    # Handles the type modifiers CALLFRAME, FAIL and NEXIST
    method WidenedComplexValue {value srctype tgttype {name ""}} {
	# Handle CALLFRAME-extended types
	if {"CALLFRAME" eq $srctype && "CALLFRAME" in $tgttype} {
	    set frame $value
	    set value [$b undef [lrange $tgttype 1 end]]
	    return [$b frame.pack $frame $value $name]
	} elseif {"CALLFRAME" in $srctype && "CALLFRAME" in $tgttype} {
	    set frame [$b frame.frame $value]
	    set value [$b frame.value $value]
	    set srctype [lrange $srctype 1 end]
	    set tgttype [lrange $tgttype 1 end]
	    set value [my WidenedComplexValue $value $srctype $tgttype]
	    return [$b frame.pack $frame $value $name]
	} elseif {"CALLFRAME" in $tgttype} {
	    error "callframe injection"
	}

	# Handle FAIL-extended types
	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 ok $value $name]
	} elseif {"FAIL" in $tgttype} {
	    set tgttype [lrange $tgttype 1 end]
	    set value [my WidenedComplexValue $value $srctype $tgttype]
	    return [$b ok $value $name]
	}

	# Handle NEXIST-extended types
	if {"NEXIST" in $srctype && "NEXIST" 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]
	} elseif {"NEXIST" in $tgttype} {
	    set tgttype [lrange $tgttype 1 end]
	    set value [my WidenedComplexValue $value $srctype $tgttype]
	    return [$b just $value $name]
	}

	# Delegate to the inner value handler
	tailcall my WidenedValue $value $srctype $tgttype $name
    }

    # Handle widening of basic values
    method WidenedValue {value srctype tgttype {name ""}} {
	if {$srctype eq $tgttype} {
	    return $value
	}
	if {$srctype eq "ZEROONE" && "ZEROONE" ni $tgttype} {
	    set value [$b cast(BOOLEAN) $value]
	    set srctype INT
	}

	# IMPURE to IMPURE - Copy the string value, and promote the
	# inner value

	if {[lindex $tgttype 0] eq "IMPURE" 
		&& [lindex $srctype 0] eq "IMPURE"} {
	    set itgttype [lrange $tgttype 1 end]
	    set isrctype [lrange $srctype 1 end]
	    set ivalue [my WidenedValue [$b impure.value $value] \
			    $isrctype $itgttype]
	    set svalue [$b impure.string $value]
	    set value [$b impure $itgttype $svalue $ivalue $name]
	} elseif {[lindex $srctype 0] eq "IMPURE" && "STRING" in $tgttype} {
	    set value [$b stringifyImpure $value $name]
	} elseif {[regexp {^IMPURE (.*)$} $tgttype -> innertype]} {
	    set widened [my WidenedValue $value $srctype $innertype]
	    set value [$b packImpure($innertype) $widened $name]
	} elseif {$tgttype eq "ZEROONE BOOLEAN"} {
	    if {$srctype in {"ZEROONE" "BOOLEAN"}} {
		# do nothing - the internal reps are the same
	    }
	} elseif {refType($tgttype) != refType($srctype)} {
	    # TODO: handle other kinds of reference types
	    set value [$b stringify($srctype) $value $name]
	} elseif {$tgttype eq "DOUBLE"} {
	    set value [$b cast(DOUBLE) $value $name]
	} elseif {$tgttype eq "NUMERIC"} {
	    if {$srctype eq "DOUBLE"} {
		set value [$b packNumericDouble $value $name]
	    } else {
		set value [$b packNumericInt $value $name]
	    }
	} elseif {$srctype eq "EMPTY" && $tgttype eq "STRING"} {
	    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
    }

    # TclCompiler:IssueDictExists --
    #
    #	Generate the code for testing whether an element of a dictionary
    #	exists. Must only be called from the 'compile' method. Includes some
    #	special hacks to handle bootstrapping arrays.
    #
    # Parameters:
    #	operation -
    #		The quadcode descriptor for the instruction.
    #
    # Results:
    #	none

    method IssueDictExists {operation} {
	set srcs [lassign $operation opcode tgt srcDict]

	# Simple, common case
	if {[llength $srcs] == 1} {
	    set srcs [list $srcDict {*}$srcs]
	    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]
	    return
	}

	# Verification of basic literal; two special cases
	if {[llength $srcs] == 0 && $srcDict eq "literal {}"} {
	    my StoreResult $tgt [my LoadOrLiteral "literal 1"]
	    return
	} elseif {[llength $srcs] == 0 && $srcDict eq "literal \uf8ff"} {
	    my StoreResult $tgt [my LoadOrLiteral "literal 0"]
	    return
	}

	# Need to construct the variadic vector
	set types [lmap s $srcs {my ValueTypes $s}]
	set vector [$b buildVector $types \
		      [lmap s $srcs {my LoadOrLiteral $s}]]
	set name [my LocalVarName $tgt]
	append opcode ( [my ValueTypes $srcDict] )
	set srcDict [my LoadOrLiteral $srcDict]
	my StoreResult $tgt [$b $opcode $srcDict $vector $name]
	$b clearVector $srcs $vector $types
	return
    }

    # TclCompiler:IssueExtract --
    #
    #	Generate the code for exactracting the value of a variable which
    #	contains a "possibly-existing" value. Must only be called from the
    #	'compile' method.
    #
    # Parameters:
    #	operation -
    #		The quadcode descriptor for the instruction.
    #
    # Results:
    #	none

    method IssueExtract {operation} {
	lassign $operation opcode tgt src
	set name [my LocalVarName $tgt]
	set tgttype [my OperandType $tgt]
	set srctype [my OperandType $src]

	# How to do the extraction depends on the type
	if {$tgttype eq "NOTHING"} {
	    set value [Const 0 bool]
	} elseif {failType($srctype)} {
	    set value [my LoadOrLiteral $src]
	    if {$tgttype ne $srctype} {
		set value [$b unmaybe $value $name]
	    }
	} else {
	    set value [my LoadOrLiteral $src]
	}

	if {refType($tgttype)} {
	    $b printref $value "extract:"
	    $b addReference($tgttype) $value
	}
	my StoreResult $tgt $value
	return
    }

    # TclCompiler:IssueValueInit --
    #
    #	Generate the code for initialising a value from a constant if it is
    #	not already set by another route. Must only be called from the
    #	'compile' method.
    #
    # Parameters:
    #	operation -
    #		The quadcode descriptor for the instruction.
    #
    # Results:
    #	none

    method IssueValueInit {operation} {
	lassign $operation opcode tgt src def
	set type [my OperandType $src]

	# Types may make this simple.
	if {$type eq "NEXIST"} {
	    set value [my LoadOrLiteral $def]
	} elseif {!failType($type)} {
	    set value [my LoadOrLiteral $src]
	} else {
	    # Nope; do it at run-time.
	    set test [$b exists [my LoadOrLiteral $src]]
	    set stype [lrange $type 1 end]
	    set value [$b select [$b expect $test true] \
			   [$b unmaybe [my LoadOrLiteral $src]] \
			   [my LoadTypedLiteral [lindex $def 1] $stype]]
	}

	set type [my OperandType $tgt]
	if {refType($type)} {
	    $b printref $value "init:"
	    $b addReference($type) $value
	}
	my StoreResult $tgt $value
	return
    }

    # TclCompiler:IssueThrowIfNEXIST --
    #
    #	Generate the code for creating an exception if the value given to it
    #	indicates something that doesn't exist (e.g., that corresponds to an
    #	unset Tcl variable). Must only be called from the 'compile' method.
    #
    # Parameters:
    #	operation -
    #		The quadcode descriptor for the instruction.
    #
    # Results:
    #	LLVM int1 that is true if the target of the branch is to be taken.

    method IssueThrowIfNEXIST {operation} {
	upvar 1 tgt tgtPC
	lassign $operation opcode branchTarget src varname

	set name [my LiteralValue $varname]
	set msg "can't read \"$name\": no such variable"
	set exn [list TCL LOOKUP VARNAME $name]
	set type [my OperandType $src]
	set tgtPC [lindex $branchTarget 1]

	# Types may make this simple.
	if {$type eq "NEXIST"} {
	    set msg [Const $msg STRING]
	    set exn [Const $exn STRING]
	    $b initException $exn $msg $errorCode
	    return [Const 1 bool]
	} elseif {!failType($type)} {
	    return [Const 0 bool]
	} else {
	    # Nope, do it at run-time.
	    set msg [Const $msg STRING]
	    set exn [Const $exn STRING]
	    return [my Unlikely existsOrError [my LoadOrLiteral $src] \
		    $msg $exn $errorCode]
	}
    }

    # TclCompiler:IssueException --
    #
    #	Generate the code for creating a general exception (e.g., from
    #	[error], [throw] or [return] with options. Must only be called from
    #	the 'compile' method.
    #
    # Parameters:
    #	operation -
    #		The quadcode descriptor for the instruction.
    #
    # Results:
    #	none

    method IssueException {operation} {
	upvar 1 errorCode errorCode
	set srcs [lassign $operation opcode tgt src]
	set src2 [lindex $srcs 0]
	set maintype [my ValueTypes $src]
	set name [my LocalVarName $tgt]
	append opcode ( [my ValueTypes {*}$srcs] )
	set value [my LoadOrLiteral $src]

	# Check if we can issue more efficient code by understanding the
	# literals provided (if everything is non-literal, we can't do much).
	if {[llength $srcs] == 3 && literal($src2)} {
	    catch {
		set dlen -1
		set s2lit [lindex $src2 1]
		set dlen [dict size $s2lit]
	    }
	    if {$dlen == 1 && [dict exists $s2lit -errorcode]
		    && $maintype eq "STRING"
		    && 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 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] {
		    my LoadOrLiteral $s
		}] 0 [$b null STRING]]
	    }
	} elseif {[llength $srcs] == 1 && literal($src2)} {
	    my Warn "need to analyse options: %s" [lindex $src2 1]
	}

	# No special instruction sequence; pass it all through to the
	# lower-level code issuers.
	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 --
    #
    #	Issue a (boolean-returning) instruction and mark it as being expected
    #	to produce a false.
    #
    # Parameters:
    #	args -	The words to use when passing to the builder object to issue
    #		the instruction.
    #
    # Results:
    #	The int1 LLVM value reference.

    method Unlikely args {
	return [$b expect [$b {*}$args] false]
    }

    # TclCompiler:OperandType --
    #
    #	Get the typecode of a particular operand.
    #
    # Parameters:
    #	operand -
    #		The operand to get the typecode of.
    #
    # Results:
    #	The typecode.

    method OperandType {operand} {
	nameOfType [typeOfOperand $vtypes $operand]
    }

    # TclCompiler:IsCallFrame --
    #
    #	Get whether a particular operand is a CALLFRAME.
    #
    # Parameters:
    #	operand -
    #		The operand to test the type of.
    #
    # Results:
    #	A Tcl boolean value.

    method IsCallFrame {operand} {
	variable ::quadcode::dataType::CALLFRAME

	return [expr {[lindex $operand 0] in {"var" "temp"}
		      && ([typeOfOperand $vtypes $operand] & $CALLFRAME) != 0}]
    }

    # TclCompiler:ValueTypes --
    #
    #	Convert the sequence of arguments (to an opcode) into the type
    #	signature tuple to use with the name of the method in the Build class
    #	to enable automatic type widening.
    #
    # Parameters:
    #	args... -
    #		The list of quadcode argument descriptors.
    #
    # Results:
    #	The comma-separated type descriptor list.

    method ValueTypes {args} {
	return [join [lmap val $args {
	    my OperandType $val
	}] ","]
    }

    # TclCompiler:FuncName --
    #
    #	Get the actual name of a command that might be called, taking into
    #	account tricky things like the resolution context.
    #
    # Parameters:
    #	name -	The name of the command to be called.
    #
    # Results:
    #	The fully-qualified command name.

    method FuncName {name} {
	namespace eval $namespace [list namespace which $name]
    }

    # TclCompiler:LocalVarName --
    #
    #	Get the suggested name for a local variable used in issued code. This
    #	is based on the name in the source material. Note that coincident
    #	names are OK; the names are DISTINCT from their identity (and will be
    #	uniqued by LLVM internally, probably by adding a number to the end).
    #
    # Parameters:
    #	desc -	The descriptor of the variable concerned.
    #	suffix (optional) -
    #		Some extra parts to add to the name to help make it unique.
    #		Only rarely used, in situations where derived names are
    #		necessary.
    #
    # Results:
    #	The fully-qualified command name.

    method LocalVarName {desc {suffix ""}} {
	set name [lindex $desc 1]
	if {[string is integer $name]} {
	    set name tmp.$name
	}
	if {$suffix ne ""} {
	    append name . $suffix
	}
	return $name
    }

    # TclCompiler:LoadOrLiteral --
    #
    #	Generate the code to create a LLVM value reference, given the
    #	descriptor of what the variable should be.
    #
    # Parameters:
    #	desc -	The descriptor of the variable or literal concerned.
    #
    # Results:
    #	The name.

    method LoadOrLiteral {desc} {
	if {[info exist variables($desc)]} {
	    return $variables($desc)
	}
	lassign $desc kind value
	if {$kind ne "literal"} {
	    return -code error "unsubstitutable argument: $desc"
	}
	set type [nameOfType [typeOfLiteral $value]]
	return [my LoadTypedLiteral $value $type]
    }

    # TclCompiler:LoadTypedLiteral --
    #
    #	Generate the code to create a LLVM value reference, given the
    #	descriptor of what the variable should be.
    #
    # Parameters:
    #	value -	The Tcl value that we are creating a literal for.
    #	type -	The quadcode type that we are going to produce.
    #
    # Results:
    #	The name.
    #
    # Maintainer note:
    #	DO NOT do reference count management in this function! It makes things
    #	leak or triggers use-after-free crashes. Leave that to the main
    #	compiler engine (and the STRING allocator) as that gets it right.

    method LoadTypedLiteral {value type} {
	if {[lindex $type 0] eq "IMPURE"} {
	    set sval [my LoadTypedLiteral $value STRING]
	    set itype [lrange $type 1 end]
	    set tval [my LoadTypedLiteral $value $itype]
	    return [$b impure $itype $sval $tval]
	} elseif {$type eq "DOUBLE"} {
	    return [ConstReal [Type $type] $value]
	} elseif {$type in {"ZEROONE" "BOOLEAN" "ZEROONE BOOLEAN"}} {
	    return [Const [expr {$value}] bool]
	} elseif {$type in {"INT" "ENTIER"}} {
	    return [$b int [expr {entier($value)}]]
	} elseif {$type in {"STRING" "EMPTY"}} {
	    set result [Const $value STRING]
	    $b assume [$b shared $result]
	    return $result
	} else {
	    return -code error \
		"unhandled type for literal \"${value}\": \"$type\""
	}
    }

    # TclCompiler:StoreResult --
    #
    #	Store the result of a (translated) quadcode operation in a variable.
    #	The variable must have been initialised previously. (It is RECOMMENDED
    #	that a 'load' from a variable of a suitable type be used, as those are
    #	trivially unique from one another.)
    #
    # Parameters:
    #	desc -	The descriptor of the variable that the value will be written
    #		to.
    #	value -	The LLVM value reference to the value to place in the variable
    #		named by the 'desc' argument.
    #	opcode (optional) -
    #		The quadcode opcode for which we are issuing this store. Only
    #		currently useful for enabling a different sort of debugging
    #		behaviour with phi nodes, as those must not be interleaved
    #		with debugging intrinsics (unlike with other result-producing
    #		operations).
    #
    # Results:
    #	None.

    method StoreResult {desc value {opcode ""}} {
	if {[lindex $desc 0] eq "literal"} {
	    return -code error "cannot store into literal; it makes no sense"
	}
	if {[info exist variables($desc)]} {
	    set targetType [TypeOf $variables($desc)]
	    if {$targetType ne [TypeOf $value]} {
		my Warn "variable is of type %s and assigned value (to '%s') is %s" \
		    [PrintTypeToString $targetType] \
		    $desc [PrintValueToString $value]
	    }
	}
	if {[lindex $desc 0] eq "var"} {
	    if {$opcode eq "phi"} {
		upvar 1 phiAnnotations todo
		lappend todo [lindex $desc 1] $value
	    } else {
		my AnnotateAssignment [lindex $desc 1] $value
	    }
	}
	if {[info exist variables($desc)]} {
	    if {$targetType ne [TypeOf $value]} {
		return -code error [format \
			"type mismatch: variable {%s} of type '%s' but was assigned value of type '%s'" \
			$desc [PrintTypeToString [TypeOf $variables($desc)]] \
			[PrintTypeToString [TypeOf $value]]]
	    }
	    ReplaceAllUsesWith $variables($desc) $value
	}
	set variables($desc) $value
	return
    }

    # TclCompiler:AnnotateAssignment --
    #
    #	Annotate an assignment to a named Tcl variable with debug metadata
    #	stating as such. Note that this does not guarantee to perform the
    #	annotation; the debugging info for the variable must have been created
    #	first.
    #
    # Parameters:
    #	name -	The name of the Tcl variable, as extracted from a descriptor.
    #	value -	The LLVM value reference to the value that was assigned.
    #
    # Results:
    #	None.
    #
    # Side effects:
    #	May issue instructions. Do not use between phi nodes.

    method AnnotateAssignment {name value} {
	if {$value ne "Nothing"} {
	    [$func module] debug value $value [$func getvardb $name]
	}
	return
    }

    # TclCompiler:ReferenceType? --
    #
    #	Test if a particular type code is a reference type or not. Reference
    #	types need extra care when managing the lifetime of.
    #
    # Parameters:
    #	type -	The type code to look at.
    #
    # Results:
    #	Boolean, true if the type is a reference type.

    method ReferenceType? {type} {
	if {[string is entier -strict $type]} {
	    set type [nameOfType $type]
	}
	foreach piece $type {
	    if {$piece in {IMPURE DICTITER EMPTY STRING ENTIER}} {
		return 1
	    }
	}
	return 0
    }

    # TclCompiler:FailureType? --
    #
    #	Test if a particular type code is a failure type or not. There are
    #	several different sorts of failure type.
    #
    # Parameters:
    #	type -	The type code to look at.
    #
    # Results:
    #	Boolean, true if the type is a failure type.

    method FailureType? {type} {
	if {[string is entier -strict $type]} {
	    set type [nameOfType $type]
	}
	foreach piece $type {
	    if {$piece in {FAIL NEXIST}} {
		return 1
	    }
	}
	return 0
    }

    # TclCompiler:IsConsumed --
    #
    #	Determine if a (reference) value is consumed by this basic block. A
    #	value is consumed if there is a 'free' of the value occurs later in
    #	the block with no other uses before then. If so, this allows us to
    #	generate more efficient code in some cases.
    #
    # Parameters:
    #	var -	The variable we are asking about.
    #	search -
    #		The PC to start searching from (generally one later than the
    #		instruction being compiled).
    #
    # Results:
    #	The PC at which the 'free' occurs, or 0 if the value isn't consumed
    #	(there is never a free as the first instruction in a function, so this
    #	may be used as a boolean).

    method IsConsumed {var search} {
	while 1 {
	    switch [lindex $quads $search 0] {
		"free" {
		    if {[lindex $quads $search 2] eq $var} {
			return $search
		    }
		}
		"jump" - "jumpFalse" - "jumpTrue" - "return" -
		"jumpMaybe" - "jumpMaybeNot" - "returnException" {
		    return 0
		}
		default {
		    if {$var in [lindex $quads $search]} {
			return 0
		    }
		}
	    }
	    incr search
	}
    }

    # TclCompiler:ConvertIndices --
    #
    #	Convert the most common cases of literal end-based indexing into forms
    #	that can actually be processed by the low-level code issuer.
    #
    # Parameters:
    #	valuePosition -
    #		The position in the argument list that the string that is
    #		being indexed into is located at.
    #	lengthOp -
    #		The operation to use for getting the length of the thing being
    #		indexed into.
    #	args -
    #		The positions that are to be adjusted.
    #
    # Results:
    #	The list of arguments to be passed to the low-level opcode method.

    method ConvertIndices {valuePosition lengthOp args} {
	upvar 1 opcode opcode srcs srcs
	set s2 $srcs
	set s3 [lmap s $srcs {my LoadOrLiteral $s}]
	set worthMapping 1
	set INDEX_RE {^(?:\d+|end(?:-\d+))$}
	foreach indexPosition $args {
	    set index [lindex $s2 $indexPosition]
	    if {!literal($index) || ![regexp $INDEX_RE [lindex $index 1]]} {
		set worthMapping 0
		break
	    }
	}
	if {$worthMapping} {
	    foreach indexPosition $args {
		set index [lindex $s2 $indexPosition 1]
		if {$index eq "end"} {
		    lset s2 $indexPosition "literal 0"
		    if {![info exist length]} {
			set length [$b ${lengthOp}(STRING) [lindex $s3 0]]
		    }
		    lset s3 $indexPosition $length
		} elseif {[string match "end*" $index]} {
		    lset s2 $indexPosition "literal 0"
		    if {![info exist length]} {
			set length [$b ${lengthOp}(STRING) [lindex $s3 0]]
		    }
		    set delta [list literal [string range $index 3 end]]
		    lset s3 $indexPosition \
			[$b add(INT,INT) $length [my LoadOrLiteral $delta]]
		}
	    }
	}
	append opcode ( [my ValueTypes {*}$s2] )
	return $s3
    }

    # TclCompiler:LiteralValue --
    #
    #	Extract the value of a quadcode literal, verifying that the value
    #	actually is a literal.
    #
    # Parameters:
    #	qcval -	The quadcode value to extract from.
    #
    # Results:
    #	The Tcl value inside the quadcode value.

    method LiteralValue {qcval} {
	lassign $qcval key value
	if {$key ne "literal"} {
	    return -code error "assumption that '$qcval' is literal not met"
	}
	return $value
    }
}

# Class TclInterproceduralCompiler --
#
#	This class compiles a single Tcl procedure within the overall
#	framework of the tclquadcode type specializer.
#
# Construction Parameters:
#	specializer -
#		The TclOO handle to the type specializer.
#	command -
#		The fully-qualified name of the procedure to compile.
#	argumentTypes -
#		The Tcl list of quadcode typecodes for the arguments to this
#		procedure.
#
# Public properties:
#	commandName -
#		The human-readable name of the function we are compiling/have
#		compiled. Note that this is not necessarily the same as the
#		name of the function in the code *or* the name of the Tcl
#		command that will be replaced by this function.

oo::class create TclInterproceduralCompiler {
    superclass TclCompiler
    variable quadcode cmd bytecode readableName func

    constructor {specializer command argumentTypes} {
	next
	my ByteCode $command [::tcl::unsupported::getbytecode proc $command]
	set info [$specializer makeInstance $command $argumentTypes]
	lassign $info rt ats tmap quadcode
	my InitTypeInfo $ats $rt $tmap
	set ats [lmap t $ats {nameOfType $t}]
	set readableName ${cmd}([string map {" " .} [join $ats ,]])
    }

    # TclInterproceduralCompiler:commandName (property) --
    #
    #	Get the human-readable name of the function we are compiling/have
    #	compiled. Note that this is not necessarily the same as the name of
    #	the function in the code *or* the name of the Tcl command that will be
    #	replaced by this function.

    method commandName {} {
	return $readableName
    }

    # TclInterproceduralCompiler:compile --
    #
    #	Generate the body for the function that we are transforming the Tcl
    #	code into. The function's declaration must have already been
    #	generated.
    #
    # Parameters:
    #	none
    #
    # Results:
    #	The LLVM function reference that we have generated. Note that this
    #	will be an unoptimised function at this stage.

    method compile {} {
	try {
	    my Compile $quadcode
	} on error {msg opts} {
	    dict append opts -errorinfo \
		"\n    (compiling code for \"$cmd\")"
	    return -options $opts $msg
	}
    }

    # TclInterproceduralCompiler:generateThunk --
    #
    #	Generate the binding into Tcl of the function that we transformed the
    #	procedure into.
    #
    # Parameters:
    #	thunkBuilder -
    #		The API binding class instance.
    #
    # Results:
    #	The function reference (i.e., instance of Function class) for the
    #	binding function. (Not the bound function, which this class made.)

    method generateThunk {thunkBuilder} {
	if {[dict exists $bytecode procmeta]} {
	    $thunkBuilder buildProcedureMetadata $cmd $bytecode \
		[dict get $bytecode procmeta]
	    dict unset bytecode procmeta
	}
	$thunkBuilder thunk $cmd $bytecode $func
    }

    # TclInterproceduralCompiler:printTypedQuads --
    #
    #	Print the sequence of typed quadcodes that the type inference engine
    #	has transformed the procedure into.
    #
    # Parameters:
    #	channel (optional) -
    #		Where to write the message. If not supplied, returns the the
    #		string that would have been printed instead.
    #
    # Results:
    #	The string if a channel is not supplied, otherwise none.

    method printTypedQuads {{channel ""}} {
	my PrintTypedQuads $channel $quadcode
    }
}

# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# buffer-file-coding-system: utf-8-unix
# End: