# 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:
|