# bytecode.tcl --
#
#	Tcl bytecode analysis code to support quadcode.tcl
#
# Copyright (c) 2015 by Kevin B. Kenny
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------

# bytecode-length --
#
#	Calculate the lengths of bytecodes, and record for each bytecode,
#	the program counter of the instruction following.
#
# Parameters:
#	bytecodeVar - Name of a dictionary in caller's scope that contains
#		      a Tcl bytecode sequence as interpreted by 
#		      tcl::unsupported::getbytecode
#
# Results:
#	None.
#
# Side effects:
#	Adds to the bytecode dictionary another element, whose key is
#	'insnFollowing', and whose value is a dictionary that maps program
#	counters to the program counters of the following instructions.

proc bytecode-length {bytecodeVar} {
    upvar 1 $bytecodeVar bytecode
    set pcwas -1
    dict for {pc insn} [dict get $bytecode instructions] {
	if {$pcwas >= 0} {
	    dict set bytecode insnFollowing $pcwas $pc
	}
	set pcwas $pc
    }
    incr pc
    dict set bytecode insnFollowing $pcwas $pc
}

# bytecode-links --
#
#	Analyzes which variables in a bytecode sequence may be links
#	(because of appearing in 'nsupvar', 'upvar' or 'variable').
#
# Parameters:
#	bytecodeVar - Name of a dictionary in caller's scope that contains
#		      a Tcl bytecode sequence as intrpreted by 
#		      tcl::unsupported::getbytecode
#
# Results:
#	None.
#
# Side effects:
#
#	Augments the dictionary with an element, 'links', that contains a
#	dictionary whose keys are local variable names and whose values are
#	immaterial. A variable is a possible link if it is present in the
#	dictionary.

proc bytecode-links {bytecodeVar} {
    upvar 1 $bytecodeVar bytecode
    set links {}
    dict for {pc insn} [dict get $bytecode instructions] {
	if {[lindex $insn 0] in {"nsupvar" "upvar" "variable"}} {
	    dict set links [index-to-var [lindex $insn 1]] {}
	}
    }
    dict set bytecode links $links
}

# bytecode-stack-state --
#
#	Analyzes the stack effects of bytecode
#
# Parameters:
#	bytecodeVar - Name of a dictionary in caller's scope that contains
#		      a Tcl bytecode sequence as intrpreted by 
#		      tcl::unsupported::getbytecode
#
# Results:
#	None.
#
# Side effects:
#	Adds to the bytecode dictionary an element 'stackState', whose
#	keys are program counter values and whose values are the
#	state of the execution stack on entry to the instructions given by
#	the keys. The stack states are lists: the last element of the list
#	is the number of elements pushed to the stack since the last
#	significant event, and the earlier element(s) specify the events.
#
# Incomplete:
#	The representation of the events is as yet unspecified. Aspirationally,
#	the events that must be represented are procedure entry, exception
#	ranges, beginning of argument expansion, expansion of individual
#	parameters, and INVOKE_EXPANDED, caught exceptions (and perhaps
#	one or two other things).

proc bytecode-stack-state {bytecodeVar} {
    upvar 1 $bytecodeVar bytecode
    dict set bytecode stackState {}

    # We need to keep track of the stack state for the alternative exits
    # of exception ranges. This state will be equal to the state at the
    # start of the range.

    set excepts {}
    foreach range [dict get $bytecode exception] {
	set from [dict get $range from]
	# This should include break and continue, but their stack states
	# are all messed up and I don't know how they get repaired.
	foreach key {catch} {
	    if {[dict exists $range $key]} {
		set tgt [dict get $range $key]
		if {$tgt >= 0} {
		    dict lappend excepts $from $tgt
		}
	    }
	}
    }
    dict set bytecode exceptlinks $excepts

    bytecode-stack-state-worker bytecode 0 0 0
    return
}
proc bytecode-stack-state-worker {bytecodeVar pc head depth} {
    upvar 1 $bytecodeVar bytecode

    # pc is the current program counter
    # head is the current significant event
    # depth is the stack depth beyond 'head'

    # If the stack state for the current instruction is known, check
    # that the current code path reaches it in the same state.
    if {[dict exists $bytecode stackState $pc]} {
	if {[dict get $bytecode stackState $pc] ne [list $head $depth]} {
	    error "inconsistent stack, pc=$pc is [list $head $depth]\
                   should be [dict get $bytecode stackState $pc]"
	}
    } else {

	# Record the current stack state
	dict set bytecode stackState $pc [list $head $depth]

	# Mark stack effects of unusual exist
	if {[dict exists $bytecode exceptlinks $pc]} {
	    foreach target [dict get $bytecode exceptlinks $pc] {
		bytecode-stack-state-worker bytecode $target $head $depth
	    }
	}

	# Calculate the stack effect of the current instruction, and
	# the PC values that the instruction flows to.
	set insn [dict get $bytecode instructions $pc]
	switch -exact [lindex $insn 0] {
	    jump1 - jump4 {
		set target [lindex $insn 1 1]; # I assume jump1 {pc ###}
		# Short-circuit tailcall into the "branch taken" for
		# unconditional jumps
		tailcall bytecode-stack-state-worker bytecode \
		    $target $head $depth
	    }
	    jumpFalse1 - jumpFalse4 - jumpTrue1 - jumpTrue4 {
		incr depth -1
		set target [lindex $insn 1 1]; # I assume jump1 {pc ###}
		# Conditional jumps need to analyze the branch-taken
		# and branch-not-taken paths. Recurse to analyze branch-taken.
		bytecode-stack-state-worker bytecode \
		    $target $head $depth
		# fallthrough to do the 'branch not taken'
	    }
	    jumpTable {
		incr depth -1
		set aux [lindex [dict get $bytecode auxiliary] \
			  [string range [lindex $insn 1] 1 end]]
		foreach target [dict values [dict get $aux mapping]] {
		    # Conditional jumps need to analyze the branch-taken and
		    # branch-not-taken paths. Recurse to analyze branch-taken.
		    bytecode-stack-state-worker bytecode \
			[expr {$pc + $target}] $head $depth
		}
		# fallthrough to do the 'branch not taken'
	    }
	    returnCodeBranch {
		incr depth -1
		foreach target {1 3 5 7 9} {
		    # Conditional jumps need to analyze the branch-taken and
		    # branch-not-taken paths. Recurse to analyze branch-taken.
		    bytecode-stack-state-worker bytecode \
			[expr {$pc + $target}] $head $depth
		}
		return
	    }
	    startCommand {
		# Special kind of conditional jump. Assume that it is *not*
		# taken; if the fallback case were to happen, we'd be in a bad
		# state anyway.
	    }
	    beginCatch4 {
		# Not a jump, but if the exception branch is taken, the stack
		# depth will be reset to the depth at this point.
		set exns [dict get $bytecode exception]
		set target [dict get [lindex $exns [lindex $insn 1]] catch]
		bytecode-stack-state-worker bytecode $target $head $depth
	    }
	    add -
	    appendArray1 -
	    appendArray4 -
	    appendStk -
	    bitand -
	    bitor -
	    bitxor -
	    dictAppend -
	    dictLappend -
	    dictUpdateEnd -
	    div -
	    eq -
	    existArrayStk -
	    expon -
	    ge -
	    gt -
	    incrArray1 -
	    incrArrayStkImm -
	    incrScalarStk -
	    incrStk -
	    land -
	    lappendArray1 -
	    lappendArray4 -
	    lappendListArray -
	    lappendListStk -
	    lappendStk -
	    le -
	    listConcat -
	    listIn -
	    listIndex -
	    listNotIn -
	    loadArrayStk -
	    lor -
	    lshift -
	    lt -
	    mod -
	    mult -
	    neq -
	    nsupvar -
	    pop -
	    regexp -
	    rshift -
	    storeArray1 -
	    storeArray4 -
	    storeScalarStk -
	    storeStk -
	    strcmp -
	    streq -
	    strfind -
	    strindex -
	    strmatch -
	    strneq -
	    strrfind -
	    strtrim -
	    strtrimLeft -
	    strtrimRight -
	    sub -
	    unsetArray -
	    unsetStk -
	    upvar -
	    variable -
	    verifyDict {
		incr depth -1
	    }
	    appendArrayStk -
	    dicrRecombineImm -
	    incrArrayStk -
	    lappendArrayStk -
	    lappendListArrayStk -
	    lsetList -
	    storeArrayStk -
	    strmap -
	    strrange -
	    unsetArrayStk {
		incr depth -2
	    }
	    dictRecombineStk -
	    strreplace {
		incr depth -3
	    }
	    arrayExistsImm -
	    currentNamespace -
	    dup -
	    existScalar -
	    incrScalar1Imm -
	    infoLevelNumber -
	    loadScalar1 -
	    loadScalar4 -
	    over -
	    push1 -
	    push4 -
	    pushResult -
	    pushReturnCode -
	    pushReturnOpts -
	    tclooSelf -
	    tryCvtToBoolean {
		incr depth
	    }
	    done {
		return
	    }
	    returnImm -
	    returnStk -
	    syntax {
		# Special case...
		set prevPc [expr {$pc - 1}]
		if {
		    [dict exists $bytecode instructions $prevPc] &&
		    [lindex [dict get $bytecode instructions $prevPc] 0]
			eq "returnCodeBranch"
		} then {
		    return
		}
		incr depth -1
		if {[lindex $insn 0] ne "returnStk" &&
			[expr [lindex $insn 1]] > 0 && [lindex $insn 2] == 0} {
		    return
		}
	    }
	    dictFirst {
		incr depth 2
	    }
	    dictNext {
		incr depth 3
	    }
	    foreach_start {
		set aux [lindex [dict get $bytecode auxiliary] \
			  [string range [lindex $insn 1] 1 end]]
		if {[dict exists $aux loop]} {
		    # Workaround for bug in Tcl; wrong aux type issued
		    # sometimes!
		    dict set aux jumpOffset [dict get $aux loop]
		}
		incr depth 2
		tailcall bytecode-stack-state-worker bytecode \
		    [expr {$pc + 5-[dict get $aux jumpOffset]}] $head $depth
	    }
	    foreach_step {
		# Need to get the aux info so that the compiler sees it.
		# Fortunately, we can get it by just scanning backwards.
		set foreachdepth 0
		for {set i $pc} {$i >= 0} {incr i -1} {
		    if {![dict exists $bytecode instructions $i]} continue
		    set inst [dict get $bytecode instructions $i]
		    switch [lindex $inst 0] {
			foreach_step {incr foreachdepth}
			foreach_start {
			    set aux [lindex [dict get $bytecode auxiliary] \
				    [string range [lindex $inst 1] 1 end]]
			    if {[dict exists $aux loop]} {
				# Workaround for bug in Tcl; wrong aux type
				# issued sometimes!
				dict set aux jumpOffset [dict get $aux loop]
			    }
			    if {[incr foreachdepth -1] == 0} break
			}
		    }
		}
		if {$i >= 0} {
		    lappend insn [string range [lindex $inst 1] 1 end]
		    dict set bytecode instructions $pc $insn
		}
		bytecode-stack-state-worker bytecode \
		    [expr {$pc + [dict get $aux jumpOffset]}] $head $depth
	    }
	    lmap_collect {
		# Need to get the aux info so that the compiler sees it.
		# Fortunately, we can get it by just scanning backwards.
		set foreachdepth 1
		for {set i $pc} {$i >= 0} {incr i -1} {
		    if {![dict exists $bytecode instructions $i]} continue
		    set inst [dict get $bytecode instructions $i]
		    switch [lindex $inst 0] {
			foreach_step {incr foreachdepth}
			foreach_start {
			    set aux [lindex [dict get $bytecode auxiliary] \
				    [string range [lindex $inst 1] 1 end]]
			    if {[dict exists $aux loop]} {
				# Workaround for bug in Tcl; wrong aux type
				# issued sometimes!
				dict set aux jumpOffset [dict get $aux loop]
			    }
			    if {[incr foreachdepth -1] == 0} break
			}
		    }
		}
		if {$i >= 0} {
		    lappend insn [string range [lindex $inst 1] 1 end]
		    dict set bytecode instructions $pc $insn
		}
		incr depth -1
	    }
	    foreach_end {
		# Need to get the aux info to compute the stack depth change.
		# Fortunately, we can get it by just scanning backwards.
		set foreachdepth 0
		for {set i $pc} {$i >= 0} {incr i -1} {
		    if {![dict exists $bytecode instructions $i]} continue
		    set inst [dict get $bytecode instructions $i]
		    switch [lindex $inst 0] {
			foreach_step {incr foreachdepth}
			foreach_start {
			    set aux [lindex [dict get $bytecode auxiliary] \
				    [string range [lindex $inst 1] 1 end]]
			    if {[incr foreachdepth -1] == 0} break
			}
		    }
		}
		if {$i < 0} {
		    error "STACK UNCALCULABLE FOR foreach_end"
		} else {
		    incr depth [expr {-(2+[llength [dict get $aux assign]])}]
		}
	    }
	    foreach_start4 {
		set aux [lindex [dict get $bytecode auxiliary] \
			  [string range [lindex $insn 1] 1 end]]
	    }
	    foreach_step4 {
		set aux [lindex [dict get $bytecode auxiliary] \
			  [string range [lindex $insn 1] 1 end]]
		incr depth
	    }
	    appendScalar1 -
	    appendScalar4 -
	    arrayMakeImm -
	    arrayExistsStk -
	    bitnot -
	    dictDone -
	    dictIncrImm -
	    dictUpdateStart -
	    endCatch -
	    evalStk -
	    existArray -
	    existStk -
	    exprStk -
	    foreach_step -
	    incrArray1Imm -
	    incrScalar1 -
	    incrScalarStkImm -
	    incrStkImm -
	    infoLevelArgs -
	    lappendList -
	    lappendScalar1 -
	    lappendScalar4 -
	    listIndexImm -
	    listLength -
	    listRangeImm -
	    loadArray1 -
	    loadArray4 -
	    loadScalarStk -
	    loadStk -
	    nop -
	    not -
	    numericType -
	    originCmd -
	    resolveCmd -
	    reverse -
	    storeScalar1 -
	    storeScalar4 -
	    strcaseLower -
	    strcaseTitle -
	    strcaseUpper -
	    strclass -
	    stringIsDouble -
	    stringIsDoubleStrict -
	    stringIsEntier -
	    stringIsEntierStrict -
	    stringIsInt -
	    stringIsIntStrict -
	    stringIsWide -
	    stringIsWideStrict -
	    strlen -
	    strrangeImm -
	    tclooClass -
	    tclooIsObject -
	    tclooNamespace -
	    tryCvtToNumeric -
	    uminus -
	    unsetScalar -
	    uplus {
		# No stack depth change
	    }
	    dictExists -
	    dictSet -
	    dictGet -
	    invokeReplace {
		incr depth [expr {-[lindex $insn 1]}]
	    }
	    concatStk -
	    dictUnset -
	    invokeStk1 -
	    invokeStk4 -
	    lindexMulti -
	    list -
	    lsetFlat -
	    strcat -
	    tclooNext -
	    tclooNextClass {
		incr depth [expr {1-[lindex $insn 1]}]
	    }
	    default {
		# TODO - Many more operations to add, including
		#        operations with unusual stack effect
		error "I don't know stack effect of $insn"
	    }
	}
	tailcall bytecode-stack-state-worker bytecode \
	    [dict get $bytecode insnFollowing $pc] \
	    $head \
	    $depth
    }
}

# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# End:
