tclquadcode: Artifact [47490ac3ae]

Artifact 47490ac3ae3458a592fd77e8de9e314f4d78dd3c:

File quadcode/translate.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: 43379) [more...]
# translate.tcl --
#
#	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.
#
#------------------------------------------------------------------------------

# bytecode-to-quads --
#
#	Translates Tcl bytecode to quadruples: three-address instructions.
#
# Parameters:
#	bytecodeVar - Name of a dictionary in caller's scope that contains
#		      a Tcl bytecode sequence as intrpreted by 
#		      tcl::unsupported::getbytecode
#
# Results:
#	Returns a dictionary. The dictionary will contain three keys:
#	quadcode: The value is a list of three-address instructions
#	links: Dictionary whose keys are variable names that may be
#	       linked by [variable], [upvar], [namespace upavar] and
#	       whose values are immaterial.
#	vars: List of variable names found in the quadcode.

proc bytecode-to-quads {bytecodeVar} {
    upvar 1 $bytecodeVar bytecode
    variable unreachablewarning

    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 
    ;				# counters that jump to them, used to fix up
    ;				# forward jumps.

    # Construct a header that sets parameters and provides a fake point
    # to which live-on-entry variables can be attached.

    set vars [lmap x [dict get $bytecode variables] {lindex $x 1}]
    quads entry {temp @callframe} [list literal $vars]

    set idx 0
    foreach v [dict get $bytecode variables] {
	if {{arg} in [lindex $v 0]} {
	    quads param [list var [lindex $v 1]] [list arg $idx]
	}
	incr idx
    }

    # Iterate the instruction list
    dict for {pc insn} [dict get $bytecode instructions] {
	if {![dict exists $bytecode stackState $pc]} {
	    if {$unreachablewarning} {
		puts "warning: unreachable: $pc: $insn"
	    }
	    continue
	}
	lassign [dict get $bytecode stackState $pc] state depth

	# Fix up any quads that jump to the current quad
	dict set quadindex $pc [llength $quads]
	if {[dict exists $fixup $pc]} {
	    foreach q [dict get $fixup $pc] {
		lset quads $q 1 [list pc [llength $quads]]
	    }
	    dict unset fixup $pc
	}

	# Determine if the current source line has changed
	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
	}
	if {$c ne ""} {
	    # Count the number of newlines up to the start of the command.
	    set line [regexp -all \n \
		    [string range $originalscript 0 [dict get $c scriptfrom]]]
	    # 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 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] {
	    add -
	    bitand -
	    bitor -
	    bitxor -
	    land -
	    lor -
	    lshift -
	    rshift -
	    mult -
	    sub {		# Binary ops
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		generate-arith-domain-check [lindex $insn 0] $v0 $v1
		quads purify {temp opd0} $v0
		quads purify {temp opd1} $v1
		quads [lindex $insn 0] $r {temp opd0} {temp opd1}
	    }
	    eq -
	    ge -
	    gt -
	    le -
	    lt -
	    neq {
		# Force string and numeric comparisons along different
		# branches. In most cases type checks will be
		# optimized away, but string and numeric equality will
		# be distinguished in the generated code. The advantage
		# is that the typecheck will become loop-invariant and
		# subject to code motion.
		set t [list temp $depth]
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		set op [lindex $insn 0]
		set n [llength $quads]
		# are both operands numeric?
		quads [list instanceOf $IMPURE_NUMERIC {IMPURE NUMERIC}] $t $v0
		;		# 0
		quads jumpFalse [list pc [expr {$n+8}]] $t; 		# 1
		quads [list instanceOf $IMPURE_NUMERIC {IMPURE NUMERIC}] $t $v1
		;		# 2
		quads jumpFalse [list pc [expr {$n+8}]] $t;		# 3
		# both operands are numeric
		quads purify {temp opd0} $v0;	    			# 4
		quads purify {temp opd1} $v1;				# 5
		quads $op $r {temp opd0} {temp opd1};			# 6
		quads jump [list pc [expr {$n+10}]];			# 7
		# at least one operand is not numeric
		quads strcmp $t $v0 $v1; 				# 8
		quads $op $r $t [list literal 0];			# 9
	    }
	    strcmp -
	    streq -
	    strfind -
	    strrfind {		# Binary ops that don't need type checks
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		quads [lindex $insn 0] $r $v0 $v1
	    }
	    uplus -
	    uminus -
	    bitnot {		# Unary ops
		set value [list temp [incr depth -1]]
		set r [list temp $depth]
		generate-arith-domain-check [lindex $insn 0] $value
		quads purify {temp opd0} $value
		set op [lindex $insn 0]
		quads $op $r {temp opd0}
	    }
	    listNotIn {
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		error-quads listIn $r $v0 $v1
		quads not $r $r
	    }
	    div - expon - mod {
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		generate-arith-domain-check [lindex $insn 0] $v0 $v1
		quads purify {temp opd0} $v0
		quads purify {temp opd1} $v1
		error-quads [lindex $insn 0] $r {temp opd0} {temp opd1}
	    }
	    listIn - strindex {
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		error-quads [lindex $insn 0] $r $v0 $v1
	    }
	    regexp {
		set flag [list literal [lindex $insn 1]]
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		error-quads regexp $r $flag $v0 $v1
	    }
	    lsetFlat {
		set old [list temp [incr depth -1]]
		set elem [list temp [incr depth -1]]
		set indices {}
		for {set i 0} {$i < [lindex $insn 1]-2} {incr i} {
		    lappend indices [list temp [incr depth -1]]
		}
		set new [list temp $depth]
		error-quads listSet $new $old $elem {*}[lreverse $indices]
	    }
	    lsetList {
		set old [list temp [incr depth -1]]
		set elem [list temp [incr depth -1]]
		set idx [list temp [incr depth -1]]
		set new [list temp $depth]
		error-quads listSet $new $old $elem $idx
	    }
	    strmatch {
		set flag [list literal [lindex $insn 1]]
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		quads [lindex $insn 0] $r $flag $v0 $v1
	    }
	    strneq {		# Negated binary ops
		set v1 [list temp [incr depth -1]]
		set v0 [list temp [incr depth -1]]
		set r $v0
		quads streq $r $v0 $v1
		quads not $r $r
	    }
	    strcaseUpper {
		set v [list temp [incr depth -1]]
		quads strcase $v $v [list literal 0]
	    }
	    strcaseLower {
		set v [list temp [incr depth -1]]
		quads strcase $v $v [list literal 1]
	    }
	    strcaseTitle {
		set v [list temp [incr depth -1]]
		quads strcase $v $v [list literal 2]
	    }
	    strclass {
		set v [list temp [incr depth -1]]
		set classes {
		    =alnum 0 =alpha 1 =ascii 2  =control 3
		    =digit 4 =graph 5 =lower 6  =print 7
		    =punct 8 =space 9 =upper 10 =word 11
		    =xdigit 12
		}
		quads strclass $v $v [list literal \
			[dict get $classes [lindex $insn 1]]]
	    }
	    strrangeImm {
		set i1 [string range [lindex $insn 1] 1 end]
		set i2 [string range [lindex $insn 2] 1 end]
		set v [list temp [incr depth -1]]
		error-quads strrange $v $v [list literal $i1] [list literal $i2]
	    }
	    strmap {
		set v3 [list temp [incr depth -1]]
		set v2 [list temp [incr depth -1]]
		set v1 [list temp [incr depth -1]]
		quads strmap $v1 $v1 $v2 $v3
	    }
	    strrange {
		set i2 [list temp [incr depth -1]]
		set i1 [list temp [incr depth -1]]
		set v [list temp [incr depth -1]]
		error-quads strrange $v $v $i1 $i2
	    }
	    strreplace {
		set substr [list temp [incr depth -1]]
		set i2 [list temp [incr depth -1]]
		set i1 [list temp [incr depth -1]]
		set v [list temp [incr depth -1]]
		error-quads strreplace $v $v $i1 $i2 $substr
	    }
	    strtrim {
		set chars [list temp [incr depth -1]]
		set v [list temp [incr depth -1]]
		quads strtrim $v $v $chars [list literal 0]
	    }
	    strtrimLeft {
		set chars [list temp [incr depth -1]]
		set v [list temp [incr depth -1]]
		quads strtrim $v $v $chars [list literal -1]
	    }
	    strtrimRight {
		set chars [list temp [incr depth -1]]
		set v [list temp [incr depth -1]]
		quads strtrim $v $v $chars [list literal 1]
	    }

	    done {		# End of bytecode
		set v [list temp [incr depth -1]]
		quads return {} {temp @callframe} $v
	    }
	    returnStk {
		# NOTE! Opposite order to 'returnImm'
		set v [list temp [incr depth -1]]
		set opt [list temp [incr depth -1]]
		set resultVar [list temp $depth]
		error-quads initException $resultVar $v $opt
	    }
	    break {
		generate-jump [exception-target loop break]
	    }
	    continue {
		generate-jump [exception-target loop continue]
	    }
	    returnImm - syntax {
		set code [expr [lindex $insn 1]]
		set level [expr [lindex $insn 2]]
		# NOTE! Opposite order to 'returnStk'
		set opt [list temp [incr depth -1]]
		set v [list temp [incr depth -1]]
		set resultVar [list temp $depth]
		# Optimizations
		switch $code,$level {
		    0,0 {
			quads copy $resultVar $v
			continue
		    }
		    3,0 {
			# TODO: Is this right?
			lappend quads [list setReturnCode {} {literal 3}]
			generate-jump [exception-target loop break]
			continue
		    }
		    4,0 {
			# TODO: Is this right?
			lappend quads [list setReturnCode {} {literal 4}]
			generate-jump [exception-target loop continue]
			continue
		    }
		}
		quads initException $resultVar $v $opt \
			[list literal $code] [list literal $level]
		if {$code == 1 && $level == 0} {
		    # Simplified case: we know this is an error
		    generate-jump [exception-target catch]
		} else {
		    generate-jump [exception-target catch] maybe $resultVar
		    quads extractMaybe $resultVar $resultVar
		}
	    }
	    reverse {
		set n [lindex $insn 1]
		set d $depth
		set tmps [set vs {}]
		for {set i 0} {$i < $n} {incr i;incr d} {
		    lappend vs [list temp [incr depth -1]]
		    lappend tmps [list temp $d]
		    quads copy [lindex $tmps end] [lindex $vs end]
		}
		for {set i 0} {$i < $n} {incr i} {
		    quads copy [lindex $vs end-$i] [lindex $tmps $i]
		}
	    }
	    foreach_start {
		# Split up like this so that the quadcode engine understands
		# all the assignments going on. This is a complex bytecode!
		set auxNum [string range [lindex $insn 1] 1 end]
		set aux [lindex [dict get $bytecode auxiliary] $auxNum]
		if {[dict exists $aux loop]} {
		    # Workaround for bug in Tcl; wrong aux type issued
		    # sometimes!
		    dict set aux jumpOffset [dict get $aux loop]
		}
		dict with aux {}
		set n [expr {$depth - [llength $assign] - 1}]
		set lists {}
		foreach group $assign {
		    lappend lists [list temp [incr n]]
		}
		set res [list temp $depth]
		error-quads foreachStart $res [list literal $assign] {*}$lists
		foreach list $lists {
		    quads unshareList $list $list
		}
		generate-jump [expr {$pc + 5 - $jumpOffset}]
	    }
	    foreach_step {
		# Split up like this so that the quadcode engine understands
		# all the assignments going on. This is a complex bytecode!
		set auxNum [lindex $insn 1]
		set aux [lindex [dict get $bytecode auxiliary] $auxNum]
		if {[dict exists $aux loop]} {
		    # Workaround for bug in Tcl; wrong aux type issued
		    # sometimes!
		    dict set aux jumpOffset [dict get $aux loop]
		}
		dict with aux {}
		set pair [list temp [expr {$depth - 2}]]
		set res [list temp $depth]
		quads foreachIter $res $pair
		set n [expr {$depth - [llength $assign] - 3}]
		set lists [lmap group $assign {
		    list temp [incr n]
		}]
		set idx [list temp [expr {$depth + 1}]]
		foreach varGroup $assign list $lists {
		    if {[llength $varGroup] == 1} {
			quads copy $idx $res
		    } else {
			quads mult $idx $res [list literal [llength $varGroup]]
		    }
		    foreach varIndex $varGroup {
			set var [index-to-var $varIndex]
			quads listIndex $var $list $idx
			quads extractMaybe $var $var
			quads add $idx $idx [list literal 1]
		    }
		}
		quads foreachMayStep $res $pair
		quads foreachAdvance $pair $pair
		set target [expr {$pc + $jumpOffset}]
		generate-jump $target true $res
	    }
	    foreach_end {
		# No special action needed; just a fancy pop, and that's
		# handled by the stack calculation code.
	    }
	    lmap_collect {
		set auxNum [lindex $insn 1]
		set aux [lindex [dict get $bytecode auxiliary] $auxNum]
		dict with aux {}
		set collector [list temp [expr {$depth - [llength $assign] - 4}]]
		set value [list temp [incr depth -1]]
		quads listAppend $collector $collector $value
		quads extractMaybe $collector $collector
	    }
	    dictFirst {
		set var [index-to-var [lindex $insn 1]]
		set dict [list temp [incr depth -1]]
		set value [list temp $depth]
		set key [list temp [incr depth]]
		set done [list temp [incr depth]]
		error-quads dictIterStart $var $dict
		quads dictIterKey $key $var
		quads dictIterValue $value $var
		quads dictIterDone $done $var
	    }
	    dictNext {
		set var [index-to-var [lindex $insn 1]]
		set value [list temp $depth]
		set key [list temp [incr depth]]
		set done [list temp [incr depth]]
		quads dictIterNext $var $var
		quads dictIterKey $key $var
		quads dictIterValue $value $var
		quads dictIterDone $done $var
	    }
	    dictUpdateStart {
		# Consider doing a special opcode for this, but that's not
		# necessary until we get [unset] working right.
		set var [index-to-var [lindex $insn 1]]
		set auxNum [string range [lindex $insn 2] 1 end]
		set aux [lindex [dict get $bytecode auxiliary] $auxNum]
		set mid [list temp $depth]
		set val [list temp [incr depth -1]]
		set idx 0
		foreach v [dict get $aux variables] {
		    set r [index-to-var $v]
		    error-quads listIndex $mid $val [list literal $idx]
		    error-quads dictGet $r $var $mid
		    incr idx
		}
	    }
	    dictUpdateEnd {
		# Consider doing a special opcode for this, but that's not
		# necessary until we get [unset] working right.
		set var [index-to-var [lindex $insn 1]]
		set auxNum [string range [lindex $insn 2] 1 end]
		set aux [lindex [dict get $bytecode auxiliary] $auxNum]
		set mid [list temp $depth]
		set mid2 [list temp [expr {$depth + 1}]]
		set val [list temp [incr depth -1]]
		set idx 0
		quads copy $mid2 $var
		foreach v [dict get $aux variables] {
		    set r [index-to-var $v]
		    error-quads listIndex $mid $val [list literal $idx]
		    error-quads dictSet $mid2 $mid2 $r $mid
		}
		quads copy $var $mid2
	    }
	    unsetScalar {
		set var [index-to-var [lindex $insn 2]]
		quads unset $var
	    }
	    dictDone {
		# Do nothing; general free will clean up.
	    }
	    verifyDict {
		set r [list temp [incr depth -1]]
		error-quads dictSize $r $r
		# The result will be discarded
	    }
	    incrScalar1Imm {
		set result [list temp $depth]
		set var [index-to-var [lindex $insn 1]]
		set delta [lindex $insn 2]
		quads initIfNotExists $var $var {literal 0}
	        quads copy $result [list literal $delta]
		generate-arith-domain-check incr $var $result
		quads purify {temp opd0} $var
		quads purify {temp opd1} $result
		quads add $var {temp opd0} {temp opd1}
		quads copy $result $var
	    }
	    incrScalar1 {
		set result [list temp $depth]
		set val [list temp [incr depth -1]]
		set var [index-to-var [lindex $insn 1]]
		quads initIfNotExists $var $var {literal 0}
		generate-arith-domain-check incr $var $val
		quads purify {temp opd0} $var
		quads purify {temp opd1} $val
		quads add $var {temp opd0} {temp opd1}
		quads copy $result $var
	    }
	    incrArray1Imm {
		set tmp [list temp $depth]
		set idx [list temp [incr depth -1]]
		set ary [index-to-var [lindex $insn 1]]
		set delta [list literal [lindex $insn 2]]
		quads initIfNotExists $ary $ary {literal {}}
		quads copy $tmp $delta
		set res $idx
		generate-arith-domain-check incr $tmp
		quads purify {temp opd2} $tmp
		error-quads dictIncr $ary $ary $idx {temp opd2}
		error-quads dictGet $res $ary $idx
	    }
	    incrArray1 {
		set delta [list temp [incr depth -1]]
		set idx [list temp [incr depth -1]]
		set ary [index-to-var [lindex $insn 1]]
		quads initIfNotExists $ary $ary {literal {}}
		set res $idx
		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
		    lappend q [list temp [incr depth -1]]
		}
		set val [list temp [incr depth -1]]
		set r [list temp $depth]
		error-quads dictGet $r $val {*}[lreverse $q]
	    }
	    dictExists {
		set idxNum [lindex $insn 1]
		set q {}
		for {set i 0} {$i < $idxNum} {incr i} {
		    # NOTE: Reversed
		    lappend q [list temp [incr depth -1]]
		}
		set val [list temp [incr depth -1]]
		set r [list temp $depth]
		quads dictExists $r $val {*}[lreverse $q]
	    }
	    dictSet {
		set idxNum [expr [lindex $insn 1]]
		set var [index-to-var [lindex $insn 2]]
		set val [list temp [incr depth -1]]
		set q {}
		for {set i 0} {$i < $idxNum} {incr i} {
		    # NOTE: Reversed
		    lappend q [list temp [incr depth -1]]
		}
		set r [list temp $depth]
		quads initIfNotExists $var $var {literal {}}
		error-quads dictSet $r $var $val {*}[lreverse $q]
		quads copy $var $r
	    }
	    dictUnset {
		set idxNum [expr [lindex $insn 1]]
		set var [index-to-var [lindex $insn 2]]
		set q {}
		for {set i 0} {$i < $idxNum} {incr i} {
		    # NOTE: Reversed
		    lappend q [list temp [incr depth -1]]
		}
		set r [list temp $depth]
		quads initIfNotExists $var $var {literal {}}
		error-quads dictUnset $r $var {*}[lreverse $q]
		quads copy $var $r
	    }
	    dictAppend - dictLappend {
		set var [index-to-var [lindex $insn 1]]
		set val [list temp [incr depth -1]]
		set key [list temp [incr depth -1]]
		set res [list temp $depth]
		quads initIfNotExists $var $var {literal {}}
		error-quads [lindex $insn 0] $res $var $key $val
		quads copy $var $res
	    }
	    dictIncrImm {
		set delta [list literal [lindex $insn 1]]
		set var [index-to-var [lindex $insn 2]]
		set key [list temp [incr depth -1]]
		set res [list temp $depth]
		quads initIfNotExists $var $var {literal {}}
		error-quads dictIncr $res $var $key $delta
		quads copy $var $res
	    }
	    list {
		set acount [lindex $insn 1]
		set depth [expr {$depth - $acount}]
		set result [list temp $depth]
		set qd {}
		for {set i 0} {$i < $acount} {incr i} {
		    lappend qd [list temp [expr {$depth + $i}]]
		}
		quads list $result {*}$qd
	    }
	    listIndexImm {
		set idx [list literal [string range [lindex $insn 1] 1 end]]
		set val [list temp [incr depth -1]]
		error-quads listIndex $val $val $idx
	    }
	    listIndex {
		set idx [list temp [incr depth -1]]
		set val [list temp [incr depth -1]]
		error-quads listIndex $val $val $idx
	    }
	    lindexMulti {
		set n [lindex $insn 1]
		set val [list temp [incr depth -$n]]
		for {set i 1} {$i < $n} {incr i} {
		    error-quads listIndex $val $val [list temp [incr depth]]
		}
		# Should we do this as a single operation? c.f. TclLindexFlat
	    }
	    listRangeImm {
		set from [list literal [string range [lindex $insn 1] 1 end]]
		set to [list literal [string range [lindex $insn 2] 1 end]]
		set val [list temp [incr depth -1]]
		error-quads listRange $val $val $from $to
	    }
	    listLength {
		set value [list temp [incr depth -1]]
		set r [list temp $depth]
		error-quads [lindex $insn 0] $r $value
	    }
	    invokeReplace {
		set acount [lindex $insn 1]
		set rcount [lindex $insn 2]
		set depth [expr {$depth - $acount - 1}]
		set result [list temp $depth]
		# FIXME - Simply do the replacement in place for
		#         now. We will probably eventually want the
		#	  mechanism to rewrite the error stack if
		#	  the invoked procedure raises an error
		set qd [list [list temp [expr {$depth + $acount}]]]
		for {set i $rcount} {$i < $acount} {incr i} {
		    lappend qd [list temp [expr {$depth + $i}]]
		}
		generate-function-param-check $qd
		# generate the call itself
		quads invoke {temp @callframe} {temp @callframe} {*}$qd
		quads retrieveResult $result {temp @callframe}
		quads extractCallFrame {temp @callframe} {temp @callframe}
		generate-jump [exception-target catch] maybe $result
		quads extractMaybe $result $result
	    }
	    invokeStk1 - invokeStk4 {
		set acount [lindex $insn 1]
		set depth [expr {$depth - $acount}]
		set result [list temp $depth]
		set qd {}
		for {set i 0} {$i < $acount} {incr i} {
		    lappend qd [list temp [expr {$depth + $i}]]
		}
		generate-function-param-check $qd
		# generate the call itself
		quads invoke {temp @callframe} {temp @callframe} {*}$qd
		quads retrieveResult $result {temp @callframe}
		quads extractCallFrame {temp @callframe} {temp @callframe}
		generate-jump [exception-target catch] maybe $result
		quads extractMaybe $result $result
	    }
	    jump1 - jump4 {
		switch -exact -- [lindex $insn 1 0] {
		    pc {
			set to_pc [lindex $insn 1 1]
			generate-jump $to_pc
		    }
		    default {
			return -code error "I don't know what to do with\
                               [lindex $insn 1 0] as a jump target."
		    }
		}
	    }
	    jumpFalse1 -
	    jumpFalse4 {	# Conditional jump
		incr depth -1
		switch -exact -- [lindex $insn 1 0] {
		    pc {
			set to_pc [lindex $insn 1 1]
			set to_test [list temp $depth]
			generate-jump $to_pc false $to_test
		    }
		    default {
			return -code error "I don't know what to do with\
                               [lindex $insn 1 0] as a jump target."
		    }
		}
	    }
	    jumpTrue1 -
	    jumpTrue4 {		# Conditional jump
		incr depth -1
		switch -exact -- [lindex $insn 1 0] {
		    pc {
			set to_pc [lindex $insn 1 1]
			set to_test [list temp $depth]
			generate-jump $to_pc true $to_test
		    }
		    default {
			return -code error "I don't know what to do with\
                               [lindex $insn 1 0] as a jump target."
		    }
		}
	    }
	    returnCodeBranch {
		incr depth -1
		set to_test [list temp $depth]
		set test [list temp [expr {$depth + 1}]]
		for {set i 1} {$i <= 4} {incr i} {
		    quads eq $test $to_test [list literal $i]
		    set to_pc [expr {$pc + $i*2 - 1}]
		    generate-jump $to_pc true $test
		}
		set to_pc [expr {$pc + 9}]
		generate-jump $to_pc
	    }
	    jumpTable {
		set jumpTableNum [string range [lindex $insn 1] 1 end]
		set jumpTable [dict get [lindex \
			[dict get $bytecode auxiliary] $jumpTableNum] mapping]
		incr depth -1
		set to_test [list temp $depth]
		set test [list temp [expr {$depth + 1}]]
		set offsets [dict values $jumpTable]
		lappend offsets 1
		set notThere [expr {[tcl::mathfunc::min {*}$offsets] - 1}]
		quads maptoint $to_test $to_test [list literal $jumpTable] \
		    [list literal $notThere]
		dict for {val offset} $jumpTable {
		    quads eq $test $to_test [list literal $offset]
		    set to_pc [expr {$pc + $offset}]
		    generate-jump $to_pc true $test
		}
	    }
	    existScalar {
		set result [list temp $depth]
		set var [index-to-var [lindex $insn 1]]
		quads exists $result $var
	    }
	    loadScalar1 -
	    loadScalar4 {	# Load a variable
		set result [list temp $depth]
		set var [index-to-var [lindex $insn 1]]
		generate-existence-check $var
		quads copy $result $var
	    }
	    loadArray1 -
	    loadArray4 {	# Load from an array
		set idx [list temp [incr depth -1]]
		set ary [index-to-var [lindex $insn 1]]
		generate-existence-check $ary
		set res $idx
		error-quads dictGet $res $ary $idx
	    }
	    nop {
	    }
	    pop - expandDrop {	# Pop and expandDrop generate no code, but
				# only adjust stack
	    }
	    beginCatch4 - endCatch {
		# These generate no code; the exception stack is resolved
		# entirely at compile time.
	    }
	    push1 -
	    push4 {		# Push a constant
		set litIdx [string range [lindex $insn 1] 1 end]
		set literal [lindex [dict get $bytecode literals] $litIdx]
		set result [list temp $depth]
		quads copy $result [list literal $literal]
	    }
	    pushResult - pushReturnCode {
		# Push bits and pieces of interpreter state
		quads [string map {pushR r} $insn] \
		    [list temp $depth] {temp @callframe}
	    }
	    pushReturnOpts {
		set v [list temp $depth]
		quads returnCode $v {temp @callframe}
		quads returnOptions $v {temp @callframe} $v
	    }
	    dup {		# Duplicate value on stack
		set d [expr {$depth - 1}]
		quads copy [list temp $depth] [list temp $d]
	    }
	    over {		# Duplicate value from deeper in stack
		set d [expr {$depth - 1 - [lindex $insn 1]}]
		quads copy [list temp $depth] [list temp $d]
	    }
	    startCommand {
		# For now, startCommand does nothing
		# lappend quads startCommand
	    }
	    storeScalar1 -
	    storeScalar4 {	# Store a variable
		incr depth -1
		set var [index-to-var [lindex $insn 1]]
		quads copy $var [list temp $depth]
	    }
	    storeArray1 -
	    storeArray4 {	# Store into an array
		set val [list temp [incr depth -1]]
		set idx [list temp [incr depth -1]]
		set ary [index-to-var [lindex $insn 1]]
		set res $idx
		quads initIfNotExists $ary $ary {literal {}}
		error-quads dictSet $ary $ary $val $idx
		quads copy $res $val
	    }
	    tryCvtToNumeric {	# No effect on value
	    }
	    tryCvtToBoolean {	# Push whether we're dealing with a boolean
		set val [list temp [expr {$depth - 1}]]
		set res [list temp $depth]
		quads isBoolean $res $val
	    }
	    numericType -
	    resolveCmd -
	    strlen {		# Unary operations
		set v0 [list temp [incr depth -1]]
		set r $v0
		quads [lindex $insn 0] $r $v0
	    }
	    originCmd {
		set v0 [list temp [incr depth -1]]
		set r $v0
		error-quads [lindex $insn 0] $r $v0
	    }
	    stringIsDouble -
	    stringIsDoubleStrict -
	    stringIsEntier -
	    stringIsEntierStrict -
	    stringIsInt -
	    stringIsIntStrict -
	    stringIsWide -
	    stringIsWideStrict {
		regexp {^stringIs(Double|Entier|Int|Wide)((?:Strict)?)$} \
		    [lindex $insn 0] -> type strict
		switch -exact $type {
		    Double {
			set typecode $quadcode::dataType::NUMERIC
		    }
		    Entier {
			set typecode $quadcode::dataType::ENTIER
		    }
		    Wide {
			set typecode $quadcode::dataType::INT
		    }
		    Int {
			set typecode $quadcode::dataType::INT32
		    }
		}
		set typecode [quadcode::dataType::typeUnion \
				  $quadcode::dataType::IMPURE $typecode]
		if {$strict ne "Strict"} {
		    set typecode [quadcode::dataType::typeUnion \
				      $quadcode::dataType::EMPTY $typecode]
		}
		set v0 [list temp [incr depth -1]]
		set r $v0
		quads [list instanceOf $typecode \
			   [quadcode::nameOfType $typecode]] $r $v0
	    }
	    not {
		set v0 [list temp [incr depth -1]]
		set r $v0
		error-quads [lindex $insn 0] $r $v0
	    }
	    appendScalar1 - appendScalar4 {
		set val [list temp [incr depth -1]]
		set var [index-to-var [lindex $insn 1]]
		quads initIfNotExists $var $var {literal {}}
		set result [list temp $depth]
		quads strcat $var $var $val
		quads copy $result $var
	    }
	    appendArray1 - appendArray4 {
		set val [list temp [incr depth -1]]
		set idx [list temp [incr depth -1]]
		set ary [index-to-var [lindex $insn 1]]
		set res [list temp $depth]
		quads initIfNotExists $ary $ary {literal {}}
		error-quads dictGet $res $ary $idx
		quads strcat $res $res $val
		error-quads dictSet $ary $ary $res $idx
	    }
	    strcat - concatStk {
		lassign $insn op count
		set strcatvals {}
		for {set i 0} {$i < $count} {incr i} {
		    lappend strcatvals [list temp [incr depth -1]]
		}
		set result [list temp $depth]
		if {$op eq "concatStk"} {
		    set op "concat"
		}
		quads $op $result {*}[lreverse $strcatvals]
	    }
	    lappendScalar1 - lappendScalar4 {
		set val [list temp [incr depth -1]]
		set var [index-to-var [lindex $insn 1]]
		set res [list temp $depth]
		quads initIfNotExists $var $var {literal {}}
		error-quads listAppend $res $var $val
		quads copy $var $res
	    }
	    lappendList {
		set val [list temp [incr depth -1]]
		set var [index-to-var [lindex $insn 1]]
		set res [list temp $depth]
		quads initIfNotExists $var $var {literal {}}
		error-quads listConcat $res $var $val
		quads copy $var $res
	    }
	    lappendArray1 - lappendArray4 {
		set val [list temp [incr depth -1]]
		set idx [list temp [incr depth -1]]
		set ary [index-to-var [lindex $insn 1]]
		set res [list temp $depth]
		quads initIfNotExists $var $var {literal {}}
		error-quads dictGet $res $ary $idx
		error-quads listAppend $res $res $val
		error-quads dictSet $ary $ary $res $idx
	    }
	    lappendListArray {
		set val [list temp [incr depth -1]]
		set idx [list temp [incr depth -1]]
		set ary [index-to-var [lindex $insn 1]]
		set res [list temp $depth]
		quads initIfNotExists $ary $ary {literal {}}
		error-quads dictGet $res $ary $idx
		error-quads listConcat $res $res $val
		error-quads dictSet $ary $ary $res $idx
	    }
	    listConcat {
		set list2 [list temp [incr depth -1]]
		set list1 [list temp [incr depth -1]]
		set res [list temp $depth]
		error-quads listConcat $res $list1 $list2
	    }
	    arrayExistsImm {
		set ary [index-to-var [lindex $insn 1]]
		set res [list temp $depth]
		set tmp [list temp [expr {$depth + 1}]]
		quads initIfNotExists $tmp $ary {literal \uf8ff}
		quads dictExists $res $tmp
	    }
	    arrayMakeImm {
		set ary [index-to-var [lindex $insn 1]]
		quads initIfNotExists $ary $ary {literal {}}
	    }
	    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"
	    }
	}
    }

    if {[dict exists $fixup -1]} {
	foreach q [dict get $fixup -1] {
	    lset quads $q 1 [list pc [llength $quads]]
	}
	# let the flow analysis figure out whether this is confluent!
	# lappend quads confluence
	quads returnCode [set code [list temp 0]] {temp @callframe}
	quads returnException {} {temp @callframe} $code
	dict unset fixup -1
    }
    if {[dict size $fixup] > 0} {
	error "Failed to fix jumps at [join [dict keys $fixup] ,]"
    }

    return [dict create \
		quadcode $quads \
		links [dict get $bytecode links] \
	        vars [lmap v $vars {list var $v}]]
}

##############################################################################
#
# HELPER PROCEDURES FOR bytecode-to-quads
#

# index-to-var --
#
#	Translates an index into Tcl's bytecode LVT into a quadcode variable
#	reference. Assumes it is being called from [bytecode-to-quads]. Note
#	that this handles nameless temporaries by creating variables with
#	"illegal" names; merely using the empty string does not work because
#	that ends up conflating temporaries when there are multiple in use at
#	once (e.g., in [try] or with nested code).
#
# Parameters:
#	varIndex -
#		The index into the LVT. May be preceded by a "%" character.
#
# Results:
#	Quadcode variable name; a two element list with the first being "var"
#	and the second being the actual name of the variable.

proc index-to-var {varIndex} {
    upvar 1 bytecode bytecode
    if {[string match "%*" $varIndex]} {
	set varIndex [string range $varIndex 1 end]
    }
    lassign [lindex [dict get $bytecode variables] $varIndex] flags name
    if {"temp" in $flags} {
	# Variable name is not legal for Tcl scalar local variables
	return [list var ($varIndex)]
    }
    return [list var $name]
}

# exception-target --
#
#	Locate where an exception should go to from the current PC. Do not
#	call from anywhere other than bytecode-to-quads!
#
# Parameters:
#	exceptionType - The type of exception that we are looking up. Should
#			be 'catch' or 'loop'.
#	exceptionField - The subtype of exception that we are looking up.
#			Defaults to 'catch' which is the correct value for
#			'catch' exceptions; must be set to 'break' or
#			'continue' for 'loop' exceptions.
#
# Results:
#	Returns the address that we should jump to on the given kind of
#	exception, or -1 if we should jump to the generic exception handler.

proc exception-target {exceptionType {exceptionField "catch"}} {
    upvar 1 bytecode bytecode pc pc
    set to_pc -1
    foreach exnRange [dict get $bytecode exception] {
	dict with exnRange {}
	if {$from > $pc} break
	set field $exceptionField
	if {($type eq $exceptionType || $type eq "catch") && $to >= $pc} {
	    set to_pc [expr {
		$type eq $exceptionType
		    ? [set $exceptionField]
		    : $catch
	    }]
	}
    }
    return $to_pc
}

# generate-jump --
#
#	Generates a jump instruction and appends it to the list of quadcodes
#	being built. Do not call from anywhere other than bytecode-to-quads!
# 
#	Example uses:
#		generate-jump $targetPC
#		generate-jump $targetPC true $testVar
#		generate-jump $targetPC false $testVar
#		generate-jump $exceptionPC maybe $maybeVar
#
# Parameters:
#	target -	The absolute PC in the bytecode that we are jumping
#			to.
#	jumpType -	The type of jump we are creating. Should be omitted
#			when just generating a simple jump.
#	conditionVar -	The variable that is used to decide whether to jump or
#			not. The decision to use based on the variable depends
#			on the jumpType. Should be omitted when generating a
#			simple jump.
#
# Results:
#	None.

proc generate-jump {target args} {
    upvar 1 quadindex quadindex fixup fixup quads quads
    if {[dict exists $quadindex $target]} {
	set target [list pc [dict get $quadindex $target]]
    } else {
	dict lappend fixup $target [llength $quads]
	set target {}
    }
    if {[llength $args] == 2} {
	lassign $args type var
	quads jump[string totitle $type] $target $var
    } else {
	quads jump $target
    }
}

# generate-existence-check --
#
#	Generates a check to make sure that a variable exists, and
#	appends it to the list of quadcodes being built. Do not call from
#	anywhere but bytecode-to-quads!
#
# Parameters;
#	var    - The variable being tested for existence
#
# Results:
#	None.
#
# Side effects:
#	Emits a sequence including 'throwIfNotExists' and instructions that
#	adjust the variable's type on the two paths.

proc generate-existence-check {var} {
    upvar 1 quadindex quadindex fixup fixup quads quads
    set target [uplevel 1 {exception-target catch}]
    if {[dict exists $quadindex $target]} {
	set tgt [list pc [dict get $quadindex $target]]
    } else {
	dict lappend fixup $target [llength $quads]
	set tgt {}
    }
    quads throwIfNotExists $tgt $var [lreplace $var 0 0 literal]
    # The narrowing pass will insert any necessary 'extractExists'
    # instructions
}

# generate-arith-domain-check --
#
#	Generates a check to make sure that a value is NUMERIC or INT
#	for the instructions that require such a value.  Do not call from
#	anywhere but bytecode-to-quads!
#
# Parameters:
#	q - The quadruple that will consume the value
#
# Results:
#	None.
#
# Side effects:
#	Emits a sequence including 'checkArithDomain' and instructions that
#	adjust the value's type on the two paths. Note that the path on which
#	the exception is thrown will most likely yield a value represented
#	as a string; nevertheless, knowing that it is NOT a numeric value
#	or an integer may yield useful clues for further analyis.

# TODO: bitand, bitor, bitxor, lshift, rshift, mod and bitnot should be
#       restricted to ENTIER (and the shift count on lshift/rshift should
#	be INT). This will depend on an implementation of ENTIER.

variable operator_info \
    [dict create \
	 incr	[list incr INT] \
	 add    [list +  NUMERIC] \
	 div    [list /  NUMERIC] \
	 expon  [list ** NUMERIC] \
	 mult   [list *  NUMERIC] \
	 sub	[list -  NUMERIC] \
	 uplus  [list +  NUMERIC] \
	 uminus [list -  NUMERIC] \
	 bitand [list &  INT] \
	 bitor  [list |  INT] \
	 bitxor [list ^  INT] \
	 mod    [list %  INT] \
	 lshift [list << INT] \
	 rshift [list << INT] \
	 bitnot [list ~  INT]]
proc generate-arith-domain-check {operator args} {
    variable operator_info
    upvar 1 quadindex quadindex fixup fixup quads quads
    set target [uplevel 1 {exception-target catch}]
    if {![dict exists $operator_info $operator]} return
    lassign [dict get $operator_info $operator] opname typename
    namespace upvar quadcode::dataType $typename typecode
    namespace upvar quadcode::dataType IMPURE impure
    set impureTC [quadcode::dataType::typeUnion $typecode $impure]
    set impureTN [list IMPURE $typename]
    foreach val $args {
	if {[dict exists $quadindex $target]} {
	    set tgt [list pc [dict get $quadindex $target]]
	} else {
	    dict lappend fixup $target [llength $quads]
	    set tgt {}
	}
	quads [list checkArithDomain $impureTC $impureTN] \
	    $tgt $val [list literal $opname]
	# A later pass will add type narrowing operations on both
	# branches, after copy propagation has had a chance to run.
    }
}

# generate-function-param-check --
#
#	Generates a check to make sure that a value conforms with a function's
#	requirement for its parameter type. Do not call from anywhere but
#	bytecode-to-quads!
#
# Parameters:
#	q - The quadruple that will consume the value
#
# Results:
#	None.
#
# Side effects:
#	Inserts a parameter type checking sequence.
#
# Unfortunately, when we are doing this, we don't actually know what
# that type is, so we emit a placeholder sequence for each parameter $i:
#
#	   {checkFunctionParam $i} {pc A} $functionName $value
#	   {narrowToParamType $i} $value $functionName $value
#       A: jump {pc B}
#	   {narrowToNotParamType $i} $value $functionName $value
#	   jump {pc $catch}
#       B: (next instruction)
#
# If, later on, we decide that we know what the parameters and result of
# $functionName are, we replace 'checkFunctionParam' with 'checkArithDomain',
# and 'narrowToParamType' and 'narrowToNotParamType' with the appropriate
# 'narrowToType' operations. If, instead, we cannot find the function or we
# find that it accepts STRING, we remove the check and the narrowing operations.

proc generate-function-param-check {q} {
    upvar 1 quadindex quadindex fixup fixup quads quads

    set argv [lassign $q functionName]
    set target [uplevel 1 {exception-target catch}]
    set i -1
    foreach val $argv {
	incr i
	if {[dict exists $quadindex $target]} {
	    set tgt [list pc [dict get $quadindex $target]]
	} else {
	    dict lappend fixup $target [llength $quads]
	    set tgt {}
	}
	quads [list checkFunctionParam $i] [list pc $target] $functionName $val
	# A later pass will insert the narrowing operations
#	quads [list narrowToParamType $i] $val $functionName $val;	# 1
#	quads jump [list pc [expr {[llength $quads] + 3}]];		# 2
#	quads [list narrowToNotParamType $i] $val $functionName $val;	# 3
#	uplevel 1 [list generate-jump $target];				# 4
#	# next instruction is position 5. 0 jumps to 3, 2 jumps to 5.
    }
}

# quads --
#
#	Generate the given quadcode.
#
# Parameters:
#	opcode - The name of the quadcode opcode to generate.
#	result - The "stack location" to write the result of the opcode.
#	args - The arguments to the opcode.
#
# Results:
#	None.

proc quads {opcode result args} {
    upvar 1 quads quads
    lappend quads [list $opcode $result {*}$args]
    return
}

# error-quads --
#
#	Generate the given quadcode and its error interception sequence.
#
# Parameters:
#	opcode - The name of the quadcode opcode to generate.
#	result - The "stack location" to write the result of the opcode.
#	args - The inputs to the quadcode.
#
# Results:
#	None.

proc error-quads {opcode result args} {
    upvar 1 quads quads
    lappend quads [list $opcode $result {*}$args]
    set target [uplevel 1 {exception-target catch}]
    uplevel 1 [list generate-jump $target maybe $result]
    lappend quads [list extractMaybe $result $result]
    return
}

# interp alias {} tcl::mathfunc::istype {} ::dataType::isa

# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# End: