diff options
Diffstat (limited to 'generic/tclAssembly.c')
| -rw-r--r-- | generic/tclAssembly.c | 4325 |
1 files changed, 4325 insertions, 0 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c new file mode 100644 index 0000000..d1866c8 --- /dev/null +++ b/generic/tclAssembly.c @@ -0,0 +1,4325 @@ +/* + * tclAssembly.c -- + * + * Assembler for Tcl bytecodes. + * + * This file contains the procedures that convert Tcl Assembly Language (TAL) + * to a sequence of bytecode instructions for the Tcl execution engine. + * + * Copyright (c) 2010 by Ozgur Dogan Ugurlu. + * Copyright (c) 2010 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. + */ + +/*- + *- THINGS TO DO: + *- More instructions: + *- done - alternate exit point (affects stack and exception range checking) + *- break and continue - if exception ranges can be sorted out. + *- foreach_start4, foreach_step4 + *- returnImm, returnStk + *- expandStart, expandStkTop, invokeExpanded, expandDrop + *- dictFirst, dictNext, dictDone + *- dictUpdateStart, dictUpdateEnd + *- jumpTable testing + *- syntax (?) + *- returnCodeBranch + *- tclooNext, tclooNextClass + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include "tclOOInt.h" + +/* + * Structure that represents a range of instructions in the bytecode. + */ + +typedef struct CodeRange { + int startOffset; /* Start offset in the bytecode array */ + int endOffset; /* End offset in the bytecode array */ +} CodeRange; + +/* + * State identified for a basic block's catch context. + */ + +typedef enum BasicBlockCatchState { + BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ + BBCS_NONE, /* Block is outside of any catch */ + BBCS_INCATCH, /* Block is within a catch context */ + BBCS_CAUGHT /* Block is within a catch context and + * may be executed after an exception fires */ +} BasicBlockCatchState; + +/* + * Structure that defines a basic block - a linear sequence of bytecode + * instructions with no jumps in or out (including not changing the + * state of any exception range). + */ + +typedef struct BasicBlock { + int originalStartOffset; /* Instruction offset before JUMP1s were + * substituted with JUMP4's */ + int startOffset; /* Instruction offset of the start of the + * block */ + int startLine; /* Line number in the input script of the + * instruction at the start of the block */ + int jumpOffset; /* Bytecode offset of the 'jump' instruction + * that ends the block, or -1 if there is no + * jump. */ + int jumpLine; /* Line number in the input script of the + * 'jump' instruction that ends the block, or + * -1 if there is no jump */ + struct BasicBlock* prevPtr; /* Immediate predecessor of this block */ + struct BasicBlock* predecessor; + /* Predecessor of this block in the spanning + * tree */ + struct BasicBlock* successor1; + /* BasicBlock structure of the following + * block: NULL at the end of the bytecode + * sequence. */ + Tcl_Obj* jumpTarget; /* Jump target label if the jump target is + * unresolved */ + int initialStackDepth; /* Absolute stack depth on entry */ + int minStackDepth; /* Low-water relative stack depth */ + int maxStackDepth; /* High-water relative stack depth */ + int finalStackDepth; /* Relative stack depth on exit */ + enum BasicBlockCatchState catchState; + /* State of the block for 'catch' analysis */ + int catchDepth; /* Number of nested catches in which the basic + * block appears */ + struct BasicBlock* enclosingCatch; + /* BasicBlock structure of the last startCatch + * executed on a path to this block, or NULL + * if there is no enclosing catch */ + int foreignExceptionBase; /* Base index of foreign exceptions */ + int foreignExceptionCount; /* Count of foreign exceptions */ + ExceptionRange* foreignExceptions; + /* ExceptionRange structures for exception + * ranges belonging to embedded scripts and + * expressions in this block */ + JumptableInfo* jtPtr; /* Jump table at the end of this basic block */ + int flags; /* Boolean flags */ +} BasicBlock; + +/* + * Flags that pertain to a basic block. + */ + +enum BasicBlockFlags { + BB_VISITED = (1 << 0), /* Block has been visited in the current + * traversal */ + BB_FALLTHRU = (1 << 1), /* Control may pass from this block to a + * successor */ + BB_JUMP1 = (1 << 2), /* Basic block ends with a 1-byte-offset jump + * and may need expansion */ + BB_JUMPTABLE = (1 << 3), /* Basic block ends with a jump table */ + BB_BEGINCATCH = (1 << 4), /* Block ends with a 'beginCatch' instruction, + * marking it as the start of a 'catch' + * sequence. The 'jumpTarget' is the exception + * exit from the catch block. */ + BB_ENDCATCH = (1 << 5) /* Block ends with an 'endCatch' instruction, + * unwinding the catch from the exception + * stack. */ +}; + +/* + * Source instruction type recognized by the assembler. + */ + +typedef enum TalInstType { + ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */ + ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be + * converted to appropriate exception + * ranges */ + ASSEM_BOOL, /* One Boolean operand */ + ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */ + ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must + * be strictly positive, consumes N, produces + * 1 */ + ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 + * operands, produces 1, N > 0 */ + ASSEM_DICT_SET, /* specifies key count and LVT index, consumes + * N+1 operands, produces 1, N > 0 */ + ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes + * N operands, produces 1, N > 0 */ + ASSEM_END_CATCH, /* End catch. No args. Exception range popped + * from stack and stack pointer restored. */ + ASSEM_EVAL, /* 'eval' - evaluate a constant script (by + * compiling it in line with the assembly + * code! I love Tcl!) */ + ASSEM_INDEX, /* 4 byte operand, integer or end-integer */ + ASSEM_INVOKE, /* 1- or 4-byte operand count, must be + * strictly positive, consumes N, produces + * 1. */ + ASSEM_JUMP, /* Jump instructions */ + ASSEM_JUMP4, /* Jump instructions forcing a 4-byte offset */ + ASSEM_JUMPTABLE, /* Jumptable (switch -exact) */ + ASSEM_LABEL, /* The assembly directive that defines a + * label */ + ASSEM_LINDEX_MULTI, /* 4-byte operand count, must be strictly + * positive, consumes N, produces 1 */ + ASSEM_LIST, /* 4-byte operand count, must be nonnegative, + * consumses N, produces 1 */ + ASSEM_LSET_FLAT, /* 4-byte operand count, must be >= 3, + * consumes N, produces 1 */ + ASSEM_LVT, /* One operand that references a local + * variable */ + ASSEM_LVT1, /* One 1-byte operand that references a local + * variable */ + ASSEM_LVT1_SINT1, /* One 1-byte operand that references a local + * variable, one signed-integer 1-byte + * operand */ + ASSEM_LVT4, /* One 4-byte operand that references a local + * variable */ + ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1, + * produces N+2 */ + ASSEM_PUSH, /* one literal operand */ + ASSEM_REGEXP, /* One Boolean operand, but weird mapping to + * call flags */ + ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N, + * produces N */ + ASSEM_SINT1, /* One 1-byte signed-integer operand + * (INCR_STK_IMM) */ + ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by + * LVT entry. Fixed arity */ +} TalInstType; + +/* + * Description of an instruction recognized by the assembler. + */ + +typedef struct TalInstDesc { + const char *name; /* Name of instruction. */ + TalInstType instType; /* The type of instruction */ + int tclInstCode; /* Instruction code. For instructions having + * 1- and 4-byte variables, tclInstCode is + * ((1byte)<<8) || (4byte) */ + int operandsConsumed; /* Number of operands consumed by the + * operation, or INT_MIN if the operation is + * variadic */ + int operandsProduced; /* Number of operands produced by the + * operation. If negative, the operation has a + * net stack effect of -1-operandsProduced */ +} TalInstDesc; + +/* + * Structure that holds the state of the assembler while generating code. + */ + +typedef struct AssemblyEnv { + CompileEnv* envPtr; /* Compilation environment being used for code + * generation */ + Tcl_Parse* parsePtr; /* Parse of the current line of source */ + Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose + * values are 'label' objects storing the code + * offsets of the labels. */ + int cmdLine; /* Current line number within the assembly + * code */ + int* clNext; /* Invisible continuation line for + * [info frame] */ + BasicBlock* head_bb; /* First basic block in the code */ + BasicBlock* curr_bb; /* Current basic block */ + int maxDepth; /* Maximum stack depth encountered */ + int curCatchDepth; /* Current depth of catches */ + int maxCatchDepth; /* Maximum depth of catches encountered */ + int flags; /* Compilation flags (TCL_EVAL_DIRECT) */ +} AssemblyEnv; + +/* + * Static functions defined in this file. + */ + +static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*, + BasicBlock*); +static BasicBlock * AllocBB(AssemblyEnv*); +static int AssembleOneLine(AssemblyEnv* envPtr); +static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, + int produced); +static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblIdx, + int count); +static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx, + int opnd, int count); +static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, + int opnd, int count); +static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, + int param, int count); +static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, + int count); +static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); +static int CalculateJumpRelocations(AssemblyEnv*, int*); +static int CheckForUnclosedCatches(AssemblyEnv*); +static int CheckForThrowInWrongContext(AssemblyEnv*); +static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*); +static int BytecodeMightThrow(unsigned char); +static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*); +static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, + int); +static int CheckNonNegative(Tcl_Interp*, int); +static int CheckOneByte(Tcl_Interp*, int); +static int CheckSignedOneByte(Tcl_Interp*, int); +static int CheckStack(AssemblyEnv*); +static int CheckStrictlyPositive(Tcl_Interp*, int); +static ByteCode * CompileAssembleObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); +static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, + const TalInstDesc*); +static int DefineLabel(AssemblyEnv* envPtr, const char* label); +static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); +static void DupAssembleCodeInternalRep(Tcl_Obj* src, + Tcl_Obj* dest); +static void FillInJumpOffsets(AssemblyEnv*); +static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, + Tcl_Obj* jumpTable); +static int FindLocalVar(AssemblyEnv* envPtr, + Tcl_Token** tokenPtrPtr); +static int FinishAssembly(AssemblyEnv*); +static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); +static void FreeAssemblyEnv(AssemblyEnv*); +static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); +static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); +static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); +static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); +static void LookForFreshCatches(BasicBlock*, BasicBlock**); +static void MoveCodeForJumps(AssemblyEnv*, int); +static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int, + int); +static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); +static int ProcessCatches(AssemblyEnv*); +static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, + BasicBlock*, enum BasicBlockCatchState, int); +static void ResetVisitedBasicBlocks(AssemblyEnv*); +static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*); +static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*, + Tcl_Obj*); +static void RestoreEmbeddedExceptionRanges(AssemblyEnv*); +static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, + BasicBlock *, int); +static BasicBlock* StartBasicBlock(AssemblyEnv*, int fallthrough, + Tcl_Obj* jumpLabel); +/* static int AdvanceIp(const unsigned char *pc); */ +static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, + BasicBlock *, int); +static int StackCheckExit(AssemblyEnv*); +static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int, + BasicBlock**, int*); +static void SyncStackDepth(AssemblyEnv*); +static int TclAssembleCode(CompileEnv* envPtr, const char* code, + int codeLen, int flags); +static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, + BasicBlock**, int*); + +/* + * Tcl_ObjType that describes bytecode emitted by the assembler. + */ + +static const Tcl_ObjType assembleCodeType = { + "assemblecode", + FreeAssembleCodeInternalRep, /* freeIntRepProc */ + DupAssembleCodeInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* + * Source instructions recognized in the Tcl Assembly Language (TAL) + */ + +static const TalInstDesc TalInstructionTable[] = { + /* PUSH must be first, see the code near the end of TclAssembleCode */ + {"push", ASSEM_PUSH, (INST_PUSH1<<8 + | INST_PUSH4), 0, 1}, + + {"add", ASSEM_1BYTE, INST_ADD, 2, 1}, + {"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8 + | INST_APPEND_SCALAR4),1, 1}, + {"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8 + | INST_APPEND_ARRAY4), 2, 1}, + {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1}, + {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, + {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1}, + {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1}, + {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0}, + {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0}, + {"beginCatch", ASSEM_BEGIN_CATCH, + INST_BEGIN_CATCH4, 0, 0}, + {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, + {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, + {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, + {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, + {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, + {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, + {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, + {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, + {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, + {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, + {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, + {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, + {"dictIncrImm", ASSEM_SINT4_LVT4, + INST_DICT_INCR_IMM, 1, 1}, + {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, + {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, + {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0}, + {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, + {"dictUnset", ASSEM_DICT_UNSET, + INST_DICT_UNSET, INT_MIN,1}, + {"div", ASSEM_1BYTE, INST_DIV, 2, 1}, + {"dup", ASSEM_1BYTE, INST_DUP, 1, 2}, + {"endCatch", ASSEM_END_CATCH,INST_END_CATCH, 0, 0}, + {"eq", ASSEM_1BYTE, INST_EQ, 2, 1}, + {"eval", ASSEM_EVAL, INST_EVAL_STK, 1, 1}, + {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, + {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1}, + {"existArray", ASSEM_LVT4, INST_EXIST_ARRAY, 1, 1}, + {"existArrayStk", ASSEM_1BYTE, INST_EXIST_ARRAY_STK, 2, 1}, + {"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1}, + {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1}, + {"expr", ASSEM_EVAL, INST_EXPR_STK, 1, 1}, + {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, + {"ge", ASSEM_1BYTE, INST_GE, 2, 1}, + {"gt", ASSEM_1BYTE, INST_GT, 2, 1}, + {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, 1, 1}, + {"incrArray", ASSEM_LVT1, INST_INCR_ARRAY1, 2, 1}, + {"incrArrayImm", ASSEM_LVT1_SINT1, + INST_INCR_ARRAY1_IMM, 1, 1}, + {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1}, + {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, + {"incrImm", ASSEM_LVT1_SINT1, + INST_INCR_SCALAR1_IMM, 0, 1}, + {"incrStk", ASSEM_1BYTE, INST_INCR_STK, 2, 1}, + {"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1}, + {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, + {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, + {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 + | INST_INVOKE_STK4), INT_MIN,1}, + {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, + {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, + {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, + {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, + {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, + {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, + {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, + {"label", ASSEM_LABEL, 0, 0, 0}, + {"land", ASSEM_1BYTE, INST_LAND, 2, 1}, + {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 + | INST_LAPPEND_SCALAR4), + 1, 1}, + {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 + | INST_LAPPEND_ARRAY4),2, 1}, + {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, + {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, + {"le", ASSEM_1BYTE, INST_LE, 2, 1}, + {"lindexMulti", ASSEM_LINDEX_MULTI, + INST_LIST_INDEX_MULTI, INT_MIN,1}, + {"list", ASSEM_LIST, INST_LIST, INT_MIN,1}, + {"listConcat", ASSEM_1BYTE, INST_LIST_CONCAT, 2, 1}, + {"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1}, + {"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1}, + {"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1}, + {"listLength", ASSEM_1BYTE, INST_LIST_LENGTH, 1, 1}, + {"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1}, + {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8 + | INST_LOAD_SCALAR4), 0, 1}, + {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 + | INST_LOAD_ARRAY4), 1, 1}, + {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, + {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, + {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, + {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, + {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, + {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, + {"lt", ASSEM_1BYTE, INST_LT, 2, 1}, + {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, + {"mult", ASSEM_1BYTE, INST_MULT, 2, 1}, + {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, + {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, + {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, + {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, + {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1}, + {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, + {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, + {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, + {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, + {"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS, + 0, 1}, + {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1}, + {"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1}, + {"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1}, + {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0}, + {"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1}, + {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8 + | INST_STORE_SCALAR4), 1, 1}, + {"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8 + | INST_STORE_ARRAY4), 2, 1}, + {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, + {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, + {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, + {"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, + {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, + {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, + {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, + {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, + {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, + {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, + {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, + {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, + {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, + {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, + {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, + {"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1}, + {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1}, + {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, + {"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1}, + {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, + {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, + {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, + {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, + {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, + {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2}, + {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, + {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, + {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, + {"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0}, + {"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0}, + {"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0}, + {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, + {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1}, + {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0}, + {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0}, + {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1}, + {NULL, 0, 0, 0, 0} +}; + +/* + * List of instructions that cannot throw an exception under any + * circumstances. These instructions are the ones that are permissible after + * an exception is caught but before the corresponding exception range is + * popped from the stack. + * The instructions must be in ascending order by numeric operation code. + */ + +static const unsigned char NonThrowingByteCodes[] = { + INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ + INST_JUMP1, INST_JUMP4, /* 34-35 */ + INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ + INST_LIST, /* 79 */ + INST_OVER, /* 95 */ + INST_PUSH_RETURN_OPTIONS, /* 108 */ + INST_REVERSE, /* 126 */ + INST_NOP, /* 132 */ + INST_STR_MAP, /* 143 */ + INST_STR_FIND, /* 144 */ + INST_COROUTINE_NAME, /* 149 */ + INST_NS_CURRENT, /* 151 */ + INST_INFO_LEVEL_NUM, /* 152 */ + INST_RESOLVE_COMMAND, /* 154 */ + INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ + INST_CONCAT_STK, /* 169 */ + INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ + INST_NUM_TYPE /* 180 */ +}; + +/* + * Helper macros. + */ + +#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2 +#define DEBUG_PRINT(...) fprintf(stderr, ##__VA_ARGS__);fflush(stderr) +#elif defined(__GNUC__) && __GNUC__ > 2 +#define DEBUG_PRINT(...) /* nothing */ +#else +#define DEBUG_PRINT /* nothing */ +#endif + +/* + *----------------------------------------------------------------------------- + * + * BBAdjustStackDepth -- + * + * When an opcode is emitted, adjusts the stack information in the basic + * block to reflect the number of operands produced and consumed. + * + * Results: + * None. + * + * Side effects: + * Updates minimum, maximum and final stack requirements in the basic + * block. + * + *----------------------------------------------------------------------------- + */ + +static void +BBAdjustStackDepth( + BasicBlock *bbPtr, /* Structure describing the basic block */ + int consumed, /* Count of operands consumed by the + * operation */ + int produced) /* Count of operands produced by the + * operation */ +{ + int depth = bbPtr->finalStackDepth; + + depth -= consumed; + if (depth < bbPtr->minStackDepth) { + bbPtr->minStackDepth = depth; + } + depth += produced; + if (depth > bbPtr->maxStackDepth) { + bbPtr->maxStackDepth = depth; + } + bbPtr->finalStackDepth = depth; +} + +/* + *----------------------------------------------------------------------------- + * + * BBUpdateStackReqs -- + * + * Updates the stack requirements of a basic block, given the opcode + * being emitted and an operand count. + * + * Results: + * None. + * + * Side effects: + * Updates min, max and final stack requirements in the basic block. + * + * Notes: + * This function must not be called for instructions such as REVERSE and + * OVER that are variadic but do not consume all their operands. Instead, + * BBAdjustStackDepth should be called directly. + * + * count should be provided only for variadic operations. For operations + * with known arity, count should be 0. + * + *----------------------------------------------------------------------------- + */ + +static void +BBUpdateStackReqs( + BasicBlock* bbPtr, /* Structure describing the basic block */ + int tblIdx, /* Index in TalInstructionTable of the + * operation being assembled */ + int count) /* Count of operands for variadic insts */ +{ + int consumed = TalInstructionTable[tblIdx].operandsConsumed; + int produced = TalInstructionTable[tblIdx].operandsProduced; + + if (consumed == INT_MIN) { + /* + * The instruction is variadic; it consumes 'count' operands. + */ + + consumed = count; + } + if (produced < 0) { + /* + * The instruction leaves some of its variadic operands on the stack, + * with net stack effect of '-1-produced' + */ + + produced = consumed - produced - 1; + } + BBAdjustStackDepth(bbPtr, consumed, produced); +} + +/* + *----------------------------------------------------------------------------- + * + * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 -- + * + * Emit the opcode part of an instruction, or the entirety of an + * instruction with a 1- or 4-byte operand, and adjust stack + * requirements. + * + * Results: + * None. + * + * Side effects: + * Stores instruction and operand in the operand stream, and adjusts the + * stack. + * + *----------------------------------------------------------------------------- + */ + +static void +BBEmitOpcode( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Table index in TalInstructionTable of op */ + int count) /* Operand count for variadic ops */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr = assemEnvPtr->curr_bb; + /* Current basic block */ + int op = TalInstructionTable[tblIdx].tclInstCode & 0xff; + + /* + * If this is the first instruction in a basic block, record its line + * number. + */ + + if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) { + bbPtr->startLine = assemEnvPtr->cmdLine; + } + + TclEmitInt1(op, envPtr); + TclUpdateAtCmdStart(op, envPtr); + BBUpdateStackReqs(bbPtr, tblIdx, count); +} + +static void +BBEmitInstInt1( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Index in TalInstructionTable of op */ + int opnd, /* 1-byte operand */ + int count) /* Operand count for variadic ops */ +{ + BBEmitOpcode(assemEnvPtr, tblIdx, count); + TclEmitInt1(opnd, assemEnvPtr->envPtr); +} + +static void +BBEmitInstInt4( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Index in TalInstructionTable of op */ + int opnd, /* 4-byte operand */ + int count) /* Operand count for variadic ops */ +{ + BBEmitOpcode(assemEnvPtr, tblIdx, count); + TclEmitInt4(opnd, assemEnvPtr->envPtr); +} + +/* + *----------------------------------------------------------------------------- + * + * BBEmitInst1or4 -- + * + * Emits a 1- or 4-byte operation according to the magnitude of the + * operand. + * + *----------------------------------------------------------------------------- + */ + +static void +BBEmitInst1or4( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int tblIdx, /* Index in TalInstructionTable of op */ + int param, /* Variable-length parameter */ + int count) /* Arity if variadic */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr = assemEnvPtr->curr_bb; + /* Current basic block */ + int op = TalInstructionTable[tblIdx].tclInstCode; + + if (param <= 0xff) { + op >>= 8; + } else { + op &= 0xff; + } + TclEmitInt1(op, envPtr); + if (param <= 0xff) { + TclEmitInt1(param, envPtr); + } else { + TclEmitInt4(param, envPtr); + } + TclUpdateAtCmdStart(op, envPtr); + BBUpdateStackReqs(bbPtr, tblIdx, count); +} + +/* + *----------------------------------------------------------------------------- + * + * Tcl_AssembleObjCmd, TclNRAssembleObjCmd -- + * + * Direct evaluation path for tcl::unsupported::assemble + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Assembles the code in objv[1], and executes it, so side effects + * include whatever the code does. + * + *----------------------------------------------------------------------------- + */ + +int +Tcl_AssembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + /* + * Boilerplate - make sure that there is an NRE trampoline on the C stack + * because there needs to be one in place to execute bytecode. + */ + + return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv); +} + +int +TclNRAssembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + ByteCode *codePtr; /* Pointer to the bytecode to execute */ + Tcl_Obj* backtrace; /* Object where extra error information is + * constructed. */ + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); + return TCL_ERROR; + } + + /* + * Assemble the source to bytecode. + */ + + codePtr = CompileAssembleObj(interp, objv[1]); + + /* + * On failure, report error line. + */ + + if (codePtr == NULL) { + Tcl_AddErrorInfo(interp, "\n (\""); + Tcl_AppendObjToErrorInfo(interp, objv[0]); + Tcl_AddErrorInfo(interp, "\" body, line "); + backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp)); + Tcl_AppendObjToErrorInfo(interp, backtrace); + Tcl_AddErrorInfo(interp, ")"); + return TCL_ERROR; + } + + /* + * Use NRE to evaluate the bytecode from the trampoline. + */ + + return TclNRExecuteByteCode(interp, codePtr); +} + +/* + *----------------------------------------------------------------------------- + * + * CompileAssembleObj -- + * + * Sets up and assembles Tcl bytecode for the direct-execution path in + * the Tcl bytecode assembler. + * + * Results: + * Returns a pointer to the assembled code. Returns NULL if the assembly + * fails for any reason, with an appropriate error message in the + * interpreter. + * + *----------------------------------------------------------------------------- + */ + +static ByteCode * +CompileAssembleObj( + Tcl_Interp *interp, /* Tcl interpreter */ + Tcl_Obj *objPtr) /* Source code to assemble */ +{ + Interp *iPtr = (Interp *) interp; + /* Internals of the interpreter */ + CompileEnv compEnv; /* Compilation environment structure */ + register ByteCode *codePtr = NULL; + /* Bytecode resulting from the assembly */ + Namespace* namespacePtr; /* Namespace in which variable and command + * names in the bytecode resolve */ + int status; /* Status return from Tcl_AssembleCode */ + const char* source; /* String representation of the source code */ + int sourceLen; /* Length of the source code in bytes */ + + + /* + * Get the expression ByteCode from the object. If it exists, make sure it + * is valid in the current context. + */ + + if (objPtr->typePtr == &assembleCodeType) { + namespacePtr = iPtr->varFramePtr->nsPtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; + if (((Interp *) *codePtr->interpHandle == iPtr) + && (codePtr->compileEpoch == iPtr->compileEpoch) + && (codePtr->nsPtr == namespacePtr) + && (codePtr->nsEpoch == namespacePtr->resolverEpoch) + && (codePtr->localCachePtr + == iPtr->varFramePtr->localCachePtr)) { + return codePtr; + } + + /* + * Not valid, so free it and regenerate. + */ + + FreeAssembleCodeInternalRep(objPtr); + } + + /* + * Set up the compilation environment, and assemble the code. + */ + + source = TclGetStringFromObj(objPtr, &sourceLen); + TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0); + status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT); + if (status != TCL_OK) { + /* + * Assembly failed. Clean up and report the error. + */ + TclFreeCompileEnv(&compEnv); + return NULL; + } + + /* + * Add a "done" instruction as the last instruction and change the object + * into a ByteCode object. Ownership of the literal objects and aux data + * items is given to the ByteCode object. + */ + + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &assembleCodeType; + TclFreeCompileEnv(&compEnv); + + /* + * Record the local variable context to which the bytecode pertains + */ + + codePtr = objPtr->internalRep.twoPtrValue.ptr1; + if (iPtr->varFramePtr->localCachePtr) { + codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; + codePtr->localCachePtr->refCount++; + } + + /* + * Report on what the assembler did. + */ + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ + + return codePtr; +} + +/* + *----------------------------------------------------------------------------- + * + * TclCompileAssembleCmd -- + * + * Compilation procedure for the '::tcl::unsupported::assemble' command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Puts the result of assembling the code into the bytecode stream in + * 'compileEnv'. + * + * This procedure makes sure that the command has a single arg, which is + * constant. If that condition is met, the procedure calls TclAssembleCode to + * produce bytecode for the given assembly code, and returns any error + * resulting from the assembly. + * + *----------------------------------------------------------------------------- + */ + +int +TclCompileAssembleCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; /* Token in the input script */ + + int numCommands = envPtr->numCommands; + int offset = envPtr->codeNext - envPtr->codeStart; + int depth = envPtr->currStackDepth; + + /* + * Make sure that the command has a single arg that is a simple word. + */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + + /* + * Compile the code and convert any error from the compilation into + * bytecode reporting the error; + */ + + if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, + tokenPtr[1].size, TCL_EVAL_DIRECT)) { + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.*s\" body, line %d)", + parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + Tcl_GetErrorLine(interp))); + envPtr->numCommands = numCommands; + envPtr->codeNext = envPtr->codeStart + offset; + envPtr->currStackDepth = depth; + TclCompileSyntaxError(interp, envPtr); + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * TclAssembleCode -- + * + * Take a list of instructions in a Tcl_Obj, and assemble them to Tcl + * bytecodes + * + * Results: + * Returns TCL_OK on success, TCL_ERROR on failure. If 'flags' includes + * TCL_EVAL_DIRECT, places an error message in the interpreter result. + * + * Side effects: + * Adds byte codes to the compile environment, and updates the + * environment's stack depth. + * + *----------------------------------------------------------------------------- + */ + +static int +TclAssembleCode( + CompileEnv *envPtr, /* Compilation environment that is to receive + * the generated bytecode */ + const char* codePtr, /* Assembly-language code to be processed */ + int codeLen, /* Length of the code */ + int flags) /* OR'ed combination of flags */ +{ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + /* + * Walk through the assembly script using the Tcl parser. Each 'command' + * will be an instruction or assembly directive. + */ + + const char* instPtr = codePtr; + /* Where to start looking for a line of code */ + const char* nextPtr; /* Pointer to the end of the line of code */ + int bytesLeft = codeLen; /* Number of bytes of source code remaining to + * be parsed */ + int status; /* Tcl status return */ + AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags); + Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; + + do { + /* + * Parse out one command line from the assembly script. + */ + + status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); + + /* + * Report errors in the parse. + */ + + if (status != TCL_OK) { + if (flags & TCL_EVAL_DIRECT) { + Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); + } + FreeAssemblyEnv(assemEnvPtr); + return TCL_ERROR; + } + + /* + * Advance the pointers around any leading commentary. + */ + + TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr, + parsePtr->commandStart); + TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, + parsePtr->commandStart - envPtr->source); + + /* + * Process the line of code. + */ + + if (parsePtr->numWords > 0) { + int instLen = parsePtr->commandSize; + /* Length in bytes of the current command */ + + if (parsePtr->term == parsePtr->commandStart + instLen - 1) { + --instLen; + } + + /* + * If tracing, show each line assembled as it happens. + */ + +#ifdef TCL_COMPILE_DEBUG + if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { + printf(" %4ld Assembling: ", + (long)(envPtr->codeNext - envPtr->codeStart)); + TclPrintSource(stdout, parsePtr->commandStart, + TclMin(instLen, 55)); + printf("\n"); + } +#endif + if (AssembleOneLine(assemEnvPtr) != TCL_OK) { + if (flags & TCL_EVAL_DIRECT) { + Tcl_LogCommandInfo(interp, codePtr, + parsePtr->commandStart, instLen); + } + Tcl_FreeParse(parsePtr); + FreeAssemblyEnv(assemEnvPtr); + return TCL_ERROR; + } + } + + /* + * Advance to the next line of code. + */ + + nextPtr = parsePtr->commandStart + parsePtr->commandSize; + bytesLeft -= (nextPtr - instPtr); + instPtr = nextPtr; + TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart, + instPtr); + TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, + instPtr - envPtr->source); + Tcl_FreeParse(parsePtr); + } while (bytesLeft > 0); + + /* + * Done with parsing the code. + */ + + status = FinishAssembly(assemEnvPtr); + FreeAssemblyEnv(assemEnvPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * NewAssemblyEnv -- + * + * Creates an environment for the assembler to run in. + * + * Results: + * Allocates, initialises and returns an assembler environment + * + *----------------------------------------------------------------------------- + */ + +static AssemblyEnv* +NewAssemblyEnv( + CompileEnv* envPtr, /* Compilation environment being used for code + * generation*/ + int flags) /* Compilation flags (TCL_EVAL_DIRECT) */ +{ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv)); + /* Assembler environment under construction */ + Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Parse of one line of assembly code */ + + assemEnvPtr->envPtr = envPtr; + assemEnvPtr->parsePtr = parsePtr; + assemEnvPtr->cmdLine = 1; + assemEnvPtr->clNext = envPtr->clNext; + + /* + * Make the hashtables that store symbol resolution. + */ + + Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS); + + /* + * Start the first basic block. + */ + + assemEnvPtr->curr_bb = NULL; + assemEnvPtr->head_bb = AllocBB(assemEnvPtr); + assemEnvPtr->curr_bb = assemEnvPtr->head_bb; + assemEnvPtr->head_bb->startLine = 1; + + /* + * Stash compilation flags. + */ + + assemEnvPtr->flags = flags; + return assemEnvPtr; +} + +/* + *----------------------------------------------------------------------------- + * + * FreeAssemblyEnv -- + * + * Cleans up the assembler environment when assembly is complete. + * + *----------------------------------------------------------------------------- + */ + +static void +FreeAssemblyEnv( + AssemblyEnv* assemEnvPtr) /* Environment to free */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment being used for code + * generation */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* thisBB; /* Pointer to a basic block being deleted */ + BasicBlock* nextBB; /* Pointer to a deleted basic block's + * successor */ + + /* + * Free all the basic block structures. + */ + + for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) { + if (thisBB->jumpTarget != NULL) { + Tcl_DecrRefCount(thisBB->jumpTarget); + } + if (thisBB->foreignExceptions != NULL) { + ckfree(thisBB->foreignExceptions); + } + nextBB = thisBB->successor1; + if (thisBB->jtPtr != NULL) { + DeleteMirrorJumpTable(thisBB->jtPtr); + thisBB->jtPtr = NULL; + } + ckfree(thisBB); + } + + /* + * Dispose what's left. + */ + + Tcl_DeleteHashTable(&assemEnvPtr->labelHash); + TclStackFree(interp, assemEnvPtr->parsePtr); + TclStackFree(interp, assemEnvPtr); +} + +/* + *----------------------------------------------------------------------------- + * + * AssembleOneLine -- + * + * Assembles a single command from an assembly language source. + * + * Results: + * Returns TCL_ERROR with an appropriate error message if the assembly + * fails. Returns TCL_OK if the assembly succeeds. Updates the assembly + * environment with the state of the assembly. + * + *----------------------------------------------------------------------------- + */ + +static int +AssembleOneLine( + AssemblyEnv* assemEnvPtr) /* State of the assembly */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment being used for code + * gen */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; + /* Parse of the line of code */ + Tcl_Token* tokenPtr; /* Current token within the line of code */ + Tcl_Obj* instNameObj; /* Name of the instruction */ + int tblIdx; /* Index in TalInstructionTable of the + * instruction */ + enum TalInstType instType; /* Type of the instruction */ + Tcl_Obj* operand1Obj = NULL; + /* First operand to the instruction */ + const char* operand1; /* String rep of the operand */ + int operand1Len; /* String length of the operand */ + int opnd; /* Integer representation of an operand */ + int litIndex; /* Literal pool index of a constant */ + int localVar; /* LVT index of a local variable */ + int flags; /* Flags for a basic block */ + JumptableInfo* jtPtr; /* Pointer to a jumptable */ + int infoIndex; /* Index of the jumptable in auxdata */ + int status = TCL_ERROR; /* Return value from this function */ + + /* + * Make sure that the instruction name is known at compile time. + */ + + tokenPtr = parsePtr->tokenPtr; + if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Look up the instruction name. + */ + + if (Tcl_GetIndexFromObjStruct(interp, instNameObj, + &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction", + TCL_EXACT, &tblIdx) != TCL_OK) { + goto cleanup; + } + + /* + * Vector on the type of instruction being processed. + */ + + instType = TalInstructionTable[tblIdx].instType; + switch (instType) { + + case ASSEM_PUSH: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "value"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); + break; + + case ASSEM_1BYTE: + if (parsePtr->numWords != 1) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); + goto cleanup; + } + BBEmitOpcode(assemEnvPtr, tblIdx, 0); + break; + + case ASSEM_BEGIN_CATCH: + /* + * Emit the BEGIN_CATCH instruction with the code offset of the + * exception branch target instead of the exception range index. The + * correct index will be generated and inserted later, when catches + * are being resolved. + */ + + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; + assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); + assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH; + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj); + break; + + case ASSEM_BOOL: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); + goto cleanup; + } + if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); + break; + + case ASSEM_BOOL_LVT4: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); + goto cleanup; + } + if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); + TclEmitInt4(localVar, envPtr); + break; + + case ASSEM_CONCAT1: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckOneByte(interp, opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_DICT_GET: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); + break; + + case ASSEM_DICT_SET: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); + TclEmitInt4(localVar, envPtr); + break; + + case ASSEM_DICT_UNSET: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + TclEmitInt4(localVar, envPtr); + break; + + case ASSEM_END_CATCH: + if (parsePtr->numWords != 1) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); + goto cleanup; + } + assemEnvPtr->curr_bb->flags |= BB_ENDCATCH; + BBEmitOpcode(assemEnvPtr, tblIdx, 0); + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); + break; + + case ASSEM_EVAL: + /* TODO - Refactor this stuff into a subroutine that takes the inst + * code, the message ("script" or "expression") and an evaluator + * callback that calls TclCompileScript or TclCompileExpr. */ + + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, + ((TalInstructionTable[tblIdx].tclInstCode + == INST_EVAL_STK) ? "script" : "expression")); + goto cleanup; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + CompileEmbeddedScript(assemEnvPtr, tokenPtr+1, + TalInstructionTable+tblIdx); + } else if (GetNextOperand(assemEnvPtr, &tokenPtr, + &operand1Obj) != TCL_OK) { + goto cleanup; + } else { + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + + /* + * Assumes that PUSH is the first slot! + */ + + BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); + BBEmitOpcode(assemEnvPtr, tblIdx, 0); + } + break; + + case ASSEM_INVOKE: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + + BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_JUMP: + case ASSEM_JUMP4: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + if (instType == ASSEM_JUMP) { + flags = BB_JUMP1; + BBEmitInstInt1(assemEnvPtr, tblIdx, 0, 0); + } else { + flags = 0; + BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); + } + + /* + * Start a new basic block at the instruction following the jump. + */ + + assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; + if (TalInstructionTable[tblIdx].operandsConsumed != 0) { + flags |= BB_FALLTHRU; + } + StartBasicBlock(assemEnvPtr, flags, operand1Obj); + break; + + case ASSEM_JUMPTABLE: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + + jtPtr = ckalloc(sizeof(JumptableInfo)); + + Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); + assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; + assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", + assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, + envPtr->codeNext - envPtr->codeStart); + + infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); + DEBUG_PRINT("auxdata index=%d\n", infoIndex); + + BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); + if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) { + goto cleanup; + } + StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL); + break; + + case ASSEM_LABEL: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "name"); + goto cleanup; + } + if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { + goto cleanup; + } + + /* + * Add the (label_name, address) pair to the hash table. + */ + + if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { + goto cleanup; + } + break; + + case ASSEM_LINDEX_MULTI: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckStrictlyPositive(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_LIST: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckNonNegative(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_INDEX: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_LSET_FLAT: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + if (opnd < 2) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("operand must be >=2", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL); + } + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_LVT: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0); + break; + + case ASSEM_LVT1: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0 || CheckOneByte(interp, localVar)) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); + break; + + case ASSEM_LVT1_SINT1: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0 || CheckOneByte(interp, localVar) + || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckSignedOneByte(interp, opnd)) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); + TclEmitInt1(opnd, envPtr); + break; + + case ASSEM_LVT4: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0); + break; + + case ASSEM_OVER: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckNonNegative(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); + break; + + case ASSEM_REGEXP: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); + goto cleanup; + } + if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + { + int flags = TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0); + + BBEmitInstInt1(assemEnvPtr, tblIdx, flags, 0); + } + break; + + case ASSEM_REVERSE: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckNonNegative(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); + break; + + case ASSEM_SINT1: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK + || CheckSignedOneByte(interp, opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); + break; + + case ASSEM_SINT4_LVT4: + if (parsePtr->numWords != 3) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + localVar = FindLocalVar(assemEnvPtr, &tokenPtr); + if (localVar < 0) { + goto cleanup; + } + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0); + TclEmitInt4(localVar, envPtr); + break; + + default: + Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", + Tcl_GetString(instNameObj)); + } + + status = TCL_OK; + cleanup: + Tcl_DecrRefCount(instNameObj); + if (operand1Obj) { + Tcl_DecrRefCount(operand1Obj); + } + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * CompileEmbeddedScript -- + * + * Compile an embedded 'eval' or 'expr' that appears in assembly code. + * + * This procedure is called when the 'eval' or 'expr' assembly directive is + * encountered, and the argument to the directive is a simple word that + * requires no substitution. The appropriate compiler (TclCompileScript or + * TclCompileExpr) is invoked recursively, and emits bytecode. + * + * Before the compiler is invoked, the compilation environment's stack + * consumption is reset to zero. Upon return from the compilation, the net + * stack effect of the compilation is in the compiler env, and this stack + * effect is posted to the assembler environment. The compile environment's + * stack consumption is then restored to what it was before (which is actually + * the state of the stack on entry to the block of assembly code). + * + * Any exception ranges pushed by the compilation are copied to the basic + * block and removed from the compiler environment. They will be rebuilt at + * the end of assembly, when the exception stack depth is actually known. + * + *----------------------------------------------------------------------------- + */ + +static void +CompileEmbeddedScript( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token* tokenPtr, /* Tcl_Token containing the script */ + const TalInstDesc* instPtr) /* Instruction that determines whether + * the script is 'expr' or 'eval' */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + + /* + * The expression or script is not only known at compile time, but + * actually a "simple word". It can be compiled inline by invoking the + * compiler recursively. + * + * Save away the stack depth and reset it before compiling the script. + * We'll record the stack usage of the script in the BasicBlock, and + * accumulate it together with the stack usage of the enclosing assembly + * code. + */ + + int savedStackDepth = envPtr->currStackDepth; + int savedMaxStackDepth = envPtr->maxStackDepth; + int savedCodeIndex = envPtr->codeNext - envPtr->codeStart; + int savedExceptArrayNext = envPtr->exceptArrayNext; + + envPtr->currStackDepth = 0; + envPtr->maxStackDepth = 0; + + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); + switch(instPtr->tclInstCode) { + case INST_EVAL_STK: + TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); + break; + case INST_EXPR_STK: + TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1); + break; + default: + Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen", + instPtr->name, instPtr->tclInstCode); + } + + /* + * Roll up the stack usage of the embedded block into the assembler + * environment. + */ + + SyncStackDepth(assemEnvPtr); + envPtr->currStackDepth = savedStackDepth; + envPtr->maxStackDepth = savedMaxStackDepth; + + /* + * Save any exception ranges that were pushed by the compiler; they will + * need to be fixed up once the stack depth is known. + */ + + MoveExceptionRangesToBasicBlock(assemEnvPtr, savedCodeIndex, + savedExceptArrayNext); + + /* + * Flush the current basic block. + */ + + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); +} + +/* + *----------------------------------------------------------------------------- + * + * SyncStackDepth -- + * + * Copies the stack depth from the compile environment to a basic block. + * + * Side effects: + * Current and max stack depth in the current basic block are adjusted. + * + * This procedure is called on return from invoking the compiler for the + * 'eval' and 'expr' operations. It adjusts the stack depth of the current + * basic block to reflect the stack required by the just-compiled code. + * + *----------------------------------------------------------------------------- + */ + +static void +SyncStackDepth( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* curr_bb = assemEnvPtr->curr_bb; + /* Current basic block */ + int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth; + /* Max stack depth in the basic block */ + + if (maxStackDepth > curr_bb->maxStackDepth) { + curr_bb->maxStackDepth = maxStackDepth; + } + curr_bb->finalStackDepth += envPtr->currStackDepth; +} + +/* + *----------------------------------------------------------------------------- + * + * MoveExceptionRangesToBasicBlock -- + * + * Removes exception ranges that were created by compiling an embedded + * script from the CompileEnv, and stores them in the BasicBlock. They + * will be reinstalled, at the correct stack depth, after control flow + * analysis is complete on the assembly code. + * + *----------------------------------------------------------------------------- + */ + +static void +MoveExceptionRangesToBasicBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int savedCodeIndex, /* Start of the embedded code */ + int savedExceptArrayNext) /* Saved index of the end of the exception + * range array */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* curr_bb = assemEnvPtr->curr_bb; + /* Current basic block */ + int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext; + /* Number of ranges that must be moved */ + int i; + + if (exceptionCount == 0) { + /* Nothing to do */ + return; + } + + /* + * Save the exception ranges in the basic block. They will be re-added at + * the conclusion of assembly; at this time, the INST_BEGIN_CATCH + * instructions in the block will be adjusted from whatever range indices + * they have [savedExceptArrayNext .. envPtr->exceptArrayNext) to the + * indices that the exceptions acquire. The saved exception ranges are + * converted to a relative nesting depth. The depth will be recomputed + * once flow analysis has determined the actual stack depth of the block. + */ + + DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n", + curr_bb, exceptionCount, savedExceptArrayNext); + curr_bb->foreignExceptionBase = savedExceptArrayNext; + curr_bb->foreignExceptionCount = exceptionCount; + curr_bb->foreignExceptions = + ckalloc(exceptionCount * sizeof(ExceptionRange)); + memcpy(curr_bb->foreignExceptions, + envPtr->exceptArrayPtr + savedExceptArrayNext, + exceptionCount * sizeof(ExceptionRange)); + for (i = 0; i < exceptionCount; ++i) { + curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; + } + envPtr->exceptArrayNext = savedExceptArrayNext; +} + +/* + *----------------------------------------------------------------------------- + * + * CreateMirrorJumpTable -- + * + * Makes a jump table with comparison values and assembly code labels. + * + * Results: + * Returns a standard Tcl status, with an error message in the + * interpreter on error. + * + * Side effects: + * Initializes the jump table pointer in the current basic block to a + * JumptableInfo. The keys in the JumptableInfo are the comparison + * strings. The values, instead of being jump displacements, are + * Tcl_Obj's with the code labels. + */ + +static int +CreateMirrorJumpTable( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Obj* jumps) /* List of alternating keywords and labels */ +{ + int objc; /* Number of elements in the 'jumps' list */ + Tcl_Obj** objv; /* Pointers to the elements in the list */ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* bbPtr = assemEnvPtr->curr_bb; + /* Current basic block */ + JumptableInfo* jtPtr; + Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */ + Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ + int isNew; /* Flag==1 if the key is not yet in the + * table. */ + int i; + + if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { + return TCL_ERROR; + } + if (objc % 2 != 0) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "jump table must have an even number of list elements", + -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL); + } + return TCL_ERROR; + } + + /* + * Allocate the jumptable. + */ + + jtPtr = ckalloc(sizeof(JumptableInfo)); + jtHashPtr = &jtPtr->hashTable; + Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); + + /* + * Fill the keys and labels into the table. + */ + + DEBUG_PRINT("jump table {\n"); + for (i = 0; i < objc; i+=2) { + DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]), + Tcl_GetString(objv[i+1])); + hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), + &isNew); + if (!isNew) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "duplicate entry in jump table for \"%s\"", + Tcl_GetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); + DeleteMirrorJumpTable(jtPtr); + return TCL_ERROR; + } + } + Tcl_SetHashValue(hashEntry, objv[i+1]); + Tcl_IncrRefCount(objv[i+1]); + } + DEBUG_PRINT("}\n"); + + /* + * Put the mirror jumptable in the basic block struct. + */ + + bbPtr->jtPtr = jtPtr; + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * DeleteMirrorJumpTable -- + * + * Cleans up a jump table when the basic block is deleted. + * + *----------------------------------------------------------------------------- + */ + +static void +DeleteMirrorJumpTable( + JumptableInfo* jtPtr) +{ + Tcl_HashTable* jtHashPtr = &jtPtr->hashTable; + /* Hash table pointer */ + Tcl_HashSearch search; /* Hash search control */ + Tcl_HashEntry* entry; /* Hash table entry containing a jump label */ + Tcl_Obj* label; /* Jump label from the hash table */ + + for (entry = Tcl_FirstHashEntry(jtHashPtr, &search); + entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + label = Tcl_GetHashValue(entry); + Tcl_DecrRefCount(label); + Tcl_SetHashValue(entry, NULL); + } + Tcl_DeleteHashTable(jtHashPtr); + ckfree(jtPtr); +} + +/* + *----------------------------------------------------------------------------- + * + * GetNextOperand -- + * + * Retrieves the next operand in sequence from an assembly instruction, + * and makes sure that its value is known at compile time. + * + * Results: + * If successful, returns TCL_OK and leaves a Tcl_Obj with the operand + * text in *operandObjPtr. In case of failure, returns TCL_ERROR and + * leaves *operandObjPtr untouched. + * + * Side effects: + * Advances *tokenPtrPtr around the token just processed. + * + *----------------------------------------------------------------------------- + */ + +static int +GetNextOperand( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr, /* INPUT/OUTPUT: Pointer to the token holding + * the operand */ + Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text + * with \-substitutions done. */ +{ + Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr; + Tcl_Obj* operandObj = Tcl_NewObj(); + + if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) { + Tcl_DecrRefCount(operandObj); + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "assembly code may not contain substitutions", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL); + } + return TCL_ERROR; + } + *tokenPtrPtr = TokenAfter(*tokenPtrPtr); + Tcl_IncrRefCount(operandObj); + *operandObjPtr = operandObj; + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * GetBooleanOperand -- + * + * Retrieves a Boolean operand from the input stream and advances + * the token pointer. + * + * Results: + * Returns a standard Tcl result (with an error message in the + * interpreter on failure). + * + * Side effects: + * Stores the Boolean value in (*result) and advances (*tokenPtrPtr) + * to the next token. + * + *----------------------------------------------------------------------------- + */ + +static int +GetBooleanOperand( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr, /* Current token from the parser */ + int* result) /* OUTPUT: Integer extracted from the token */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Token* tokenPtr = *tokenPtrPtr; + /* INOUT: Pointer to the next token in the + * source code */ + Tcl_Obj* intObj; /* Integer from the source code */ + int status; /* Tcl status return */ + + /* + * Extract the next token as a string. + */ + + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Convert to an integer, advance to the next token and return. + */ + + status = Tcl_GetBooleanFromObj(interp, intObj, result); + Tcl_DecrRefCount(intObj); + *tokenPtrPtr = TokenAfter(tokenPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * GetIntegerOperand -- + * + * Retrieves an integer operand from the input stream and advances the + * token pointer. + * + * Results: + * Returns a standard Tcl result (with an error message in the + * interpreter on failure). + * + * Side effects: + * Stores the integer value in (*result) and advances (*tokenPtrPtr) to + * the next token. + * + *----------------------------------------------------------------------------- + */ + +static int +GetIntegerOperand( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr, /* Current token from the parser */ + int* result) /* OUTPUT: Integer extracted from the token */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Token* tokenPtr = *tokenPtrPtr; + /* INOUT: Pointer to the next token in the + * source code */ + Tcl_Obj* intObj; /* Integer from the source code */ + int status; /* Tcl status return */ + + /* + * Extract the next token as a string. + */ + + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Convert to an integer, advance to the next token and return. + */ + + status = Tcl_GetIntFromObj(interp, intObj, result); + Tcl_DecrRefCount(intObj); + *tokenPtrPtr = TokenAfter(tokenPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * GetListIndexOperand -- + * + * Gets the value of an operand intended to serve as a list index. + * + * Results: + * Returns a standard Tcl result: TCL_OK if the parse is successful and + * TCL_ERROR (with an appropriate error message) if the parse fails. + * + * Side effects: + * Stores the list index at '*index'. Values between -1 and 0x7fffffff + * have their natural meaning; values between -2 and -0x80000000 + * represent 'end-2-N'. + * + *----------------------------------------------------------------------------- + */ + +static int +GetListIndexOperand( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr, /* Current token from the parser */ + int* result) /* OUTPUT: Integer extracted from the token */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Token* tokenPtr = *tokenPtrPtr; + /* INOUT: Pointer to the next token in the + * source code */ + Tcl_Obj* intObj; /* Integer from the source code */ + int status; /* Tcl status return */ + + /* + * Extract the next token as a string. + */ + + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Convert to an integer, advance to the next token and return. + */ + + status = TclGetIntForIndex(interp, intObj, -2, result); + Tcl_DecrRefCount(intObj); + *tokenPtrPtr = TokenAfter(tokenPtr); + return status; +} + +/* + *----------------------------------------------------------------------------- + * + * FindLocalVar -- + * + * Gets the name of a local variable from the input stream and advances + * the token pointer. + * + * Results: + * Returns the LVT index of the local variable. Returns -1 if the + * variable is non-local, not known at compile time, or cannot be + * installed in the LVT (leaving an error message in the interpreter + * result if necessary). + * + * Side effects: + * Advances the token pointer. May define a new LVT slot if the variable + * has not yet been seen and the execution context allows for it. + * + *----------------------------------------------------------------------------- + */ + +static int +FindLocalVar( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Token** tokenPtrPtr) +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Token* tokenPtr = *tokenPtrPtr; + /* INOUT: Pointer to the next token in the + * source code. */ + Tcl_Obj* varNameObj; /* Name of the variable */ + const char* varNameStr; + int varNameLen; + int localVar; /* Index of the variable in the LVT */ + + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { + return -1; + } + varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); + if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { + Tcl_DecrRefCount(varNameObj); + return -1; + } + localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); + Tcl_DecrRefCount(varNameObj); + if (localVar == -1) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot use this instruction to create a variable" + " in a non-proc context", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + } + return -1; + } + *tokenPtrPtr = TokenAfter(tokenPtr); + return localVar; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckNamespaceQualifiers -- + * + * Verify that a variable name has no namespace qualifiers before + * attempting to install it in the LVT. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores + * an error message in the interpreter result. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckNamespaceQualifiers( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + const char* name, /* Variable name to check */ + int nameLen) /* Length of the variable */ +{ + const char* p; + + for (p = name; p+2 < name+nameLen; p++) { + if ((*p == ':') && (p[1] == ':')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "variable \"%s\" is not local", name)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckOneByte -- + * + * Verify that a constant fits in a single byte in the instruction + * stream. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores + * an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_SCALAR1 + * are possible on a given local variable. The fact that there is no + * INCR_SCALAR4 is puzzling. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckOneByte( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + + if (value < 0 || value > 0xff) { + result = Tcl_NewStringObj("operand does not fit in one byte", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckSignedOneByte -- + * + * Verify that a constant fits in a single signed byte in the instruction + * stream. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores + * an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_SCALAR1 + * are possible on a given local variable. The fact that there is no + * INCR_SCALAR4 is puzzling. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckSignedOneByte( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + + if (value > 0x7f || value < -0x80) { + result = Tcl_NewStringObj("operand does not fit in one byte", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckNonNegative -- + * + * Verify that a constant is nonnegative + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores + * an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_INVOKE + * are consuming a positive number of operands + * + *----------------------------------------------------------------------------- + */ + +static int +CheckNonNegative( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + + if (value < 0) { + result = Tcl_NewStringObj("operand must be nonnegative", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckStrictlyPositive -- + * + * Verify that a constant is positive + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and + * stores an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_INVOKE + * are consuming a positive number of operands + * + *----------------------------------------------------------------------------- + */ + +static int +CheckStrictlyPositive( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + + if (value <= 0) { + result = Tcl_NewStringObj("operand must be positive", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * DefineLabel -- + * + * Defines a label appearing in the assembly sequence. + * + * Results: + * Returns a standard Tcl result. Returns TCL_OK and an empty result if + * the definition succeeds; returns TCL_ERROR and an appropriate message + * if a duplicate definition is found. + * + *----------------------------------------------------------------------------- + */ + +static int +DefineLabel( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + const char* labelName) /* Label being defined */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_HashEntry* entry; /* Label's entry in the symbol table */ + int isNew; /* Flag == 1 iff the label was previously + * undefined */ + + /* TODO - This can now be simplified! */ + + StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); + + /* + * Look up the newly-defined label in the symbol table. + */ + + entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew); + if (!isNew) { + /* + * This is a duplicate label. + */ + + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "duplicate definition of label \"%s\"", labelName)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, + NULL); + } + return TCL_ERROR; + } + + /* + * This is the first appearance of the label in the code. + */ + + Tcl_SetHashValue(entry, assemEnvPtr->curr_bb); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * StartBasicBlock -- + * + * Starts a new basic block when a label or jump is encountered. + * + * Results: + * Returns a pointer to the BasicBlock structure of the new + * basic block. + * + *----------------------------------------------------------------------------- + */ + +static BasicBlock* +StartBasicBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int flags, /* Flags to apply to the basic block being + * closed, if there is one. */ + Tcl_Obj* jumpLabel) /* Label of the location that the block jumps + * to, or NULL if the block does not jump */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* newBB; /* BasicBlock structure for the new block */ + BasicBlock* currBB = assemEnvPtr->curr_bb; + + /* + * Coalesce zero-length blocks. + */ + + if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) { + currBB->startLine = assemEnvPtr->cmdLine; + return currBB; + } + + /* + * Make the new basic block. + */ + + newBB = AllocBB(assemEnvPtr); + + /* + * Record the jump target if there is one. + */ + + currBB->jumpTarget = jumpLabel; + if (jumpLabel != NULL) { + Tcl_IncrRefCount(currBB->jumpTarget); + } + + /* + * Record the fallthrough if there is one. + */ + + currBB->flags |= flags; + + /* + * Record the successor block. + */ + + currBB->successor1 = newBB; + assemEnvPtr->curr_bb = newBB; + return newBB; +} + +/* + *----------------------------------------------------------------------------- + * + * AllocBB -- + * + * Allocates a new basic block + * + * Results: + * Returns a pointer to the newly allocated block, which is initialized + * to contain no code and begin at the current instruction pointer. + * + *----------------------------------------------------------------------------- + */ + +static BasicBlock * +AllocBB( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + BasicBlock *bb = ckalloc(sizeof(BasicBlock)); + + bb->originalStartOffset = + bb->startOffset = envPtr->codeNext - envPtr->codeStart; + bb->startLine = assemEnvPtr->cmdLine + 1; + bb->jumpOffset = -1; + bb->jumpLine = -1; + bb->prevPtr = assemEnvPtr->curr_bb; + bb->predecessor = NULL; + bb->successor1 = NULL; + bb->jumpTarget = NULL; + bb->initialStackDepth = 0; + bb->minStackDepth = 0; + bb->maxStackDepth = 0; + bb->finalStackDepth = 0; + bb->catchDepth = 0; + bb->enclosingCatch = NULL; + bb->foreignExceptionBase = -1; + bb->foreignExceptionCount = 0; + bb->foreignExceptions = NULL; + bb->jtPtr = NULL; + bb->flags = 0; + + return bb; +} + +/* + *----------------------------------------------------------------------------- + * + * FinishAssembly -- + * + * Postprocessing after all bytecode has been generated for a block of + * assembly code. + * + * Results: + * Returns a standard Tcl result, with an error message left in the + * interpreter if appropriate. + * + * Side effects: + * The program is checked to see if any undefined labels remain. The + * initial stack depth of all the basic blocks in the flow graph is + * calculated and saved. The stack balance on exit is computed, checked + * and saved. + * + *----------------------------------------------------------------------------- + */ + +static int +FinishAssembly( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + int mustMove; /* Amount by which the code needs to be grown + * because of expanding jumps */ + + /* + * Resolve the targets of all jumps and determine whether code needs to be + * moved around. + */ + + if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) { + return TCL_ERROR; + } + + /* + * Move the code if necessary. + */ + + if (mustMove) { + MoveCodeForJumps(assemEnvPtr, mustMove); + } + + /* + * Resolve jump target labels to bytecode offsets. + */ + + FillInJumpOffsets(assemEnvPtr); + + /* + * Label each basic block with its catch context. Quit on inconsistency. + */ + + if (ProcessCatches(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make sure that no block accessible from a catch's error exit that hasn't + * popped the exception stack can throw an exception. + */ + + if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Compute stack balance throughout the program. + */ + + if (CheckStack(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * TODO - Check for unreachable code. Or maybe not; unreachable code is + * Mostly Harmless. + */ + + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CalculateJumpRelocations -- + * + * Calculate any movement that has to be done in the assembly code to + * expand JUMP1 instructions to JUMP4 (because they jump more than a + * 1-byte range). + * + * Results: + * Returns a standard Tcl result, with an appropriate error message if + * anything fails. + * + * Side effects: + * Sets the 'startOffset' pointer in every basic block to the new origin + * of the block, and turns off JUMP1 flags on instructions that must be + * expanded (and adjusts them to the corresponding JUMP4's). Does *not* + * store the jump offsets at this point. + * + * Sets *mustMove to 1 if and only if at least one instruction changed + * size so the code must be moved. + * + * As a side effect, also checks for undefined labels and reports them. + * + *----------------------------------------------------------------------------- + */ + +static int +CalculateJumpRelocations( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + int* mustMove) /* OUTPUT: Number of bytes that have been + * added to the code */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Pointer to a basic block being checked */ + Tcl_HashEntry* entry; /* Exit label's entry in the symbol table */ + BasicBlock* jumpTarget; /* Basic block where the jump goes */ + int motion; /* Amount by which the code has expanded */ + int offset; /* Offset in the bytecode from a jump + * instruction to its target */ + unsigned opcode; /* Opcode in the bytecode being adjusted */ + + /* + * Iterate through basic blocks as long as a change results in code + * expansion. + */ + + *mustMove = 0; + do { + motion = 0; + for (bbPtr = assemEnvPtr->head_bb; + bbPtr != NULL; + bbPtr = bbPtr->successor1) { + /* + * Advance the basic block start offset by however many bytes we + * have inserted in the code up to this point + */ + + bbPtr->startOffset += motion; + + /* + * If the basic block references a label (and hence performs a + * jump), find the location of the label. Report an error if the + * label is missing. + */ + + if (bbPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(bbPtr->jumpTarget)); + if (entry == NULL) { + ReportUndefinedLabel(assemEnvPtr, bbPtr, + bbPtr->jumpTarget); + return TCL_ERROR; + } + + /* + * If the instruction is a JUMP1, turn it into a JUMP4 if its + * target is out of range. + */ + + jumpTarget = Tcl_GetHashValue(entry); + if (bbPtr->flags & BB_JUMP1) { + offset = jumpTarget->startOffset + - (bbPtr->jumpOffset + motion); + if (offset < -0x80 || offset > 0x7f) { + opcode = TclGetUInt1AtPtr(envPtr->codeStart + + bbPtr->jumpOffset); + ++opcode; + TclStoreInt1AtPtr(opcode, + envPtr->codeStart + bbPtr->jumpOffset); + motion += 3; + bbPtr->flags &= ~BB_JUMP1; + } + } + } + + /* + * If the basic block references a jump table, that doesn't affect + * the code locations, but resolve the labels now, and store basic + * block pointers in the jumptable hash. + */ + + if (bbPtr->flags & BB_JUMPTABLE) { + if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) { + return TCL_ERROR; + } + } + } + *mustMove += motion; + } while (motion != 0); + + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckJumpTableLabels -- + * + * Make sure that all the labels in a jump table are defined. + * + * Results: + * Returns TCL_OK if they are, TCL_ERROR if they aren't. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckJumpTableLabels( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr) /* Basic block that ends in a jump table */ +{ + Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; + /* Hash table with the symbols */ + Tcl_HashSearch search; /* Hash table iterator */ + Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ + Tcl_Obj* symbolObj; /* Jump target */ + Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ + + /* + * Look up every jump target in the jump hash. + */ + + DEBUG_PRINT("check jump table labels %p {\n", bbPtr); + for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); + symEntryPtr != NULL; + symEntryPtr = Tcl_NextHashEntry(&search)) { + symbolObj = Tcl_GetHashValue(symEntryPtr); + valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(symbolObj)); + DEBUG_PRINT(" %s -> %s (%d)\n", + (char*) Tcl_GetHashKey(symHash, symEntryPtr), + Tcl_GetString(symbolObj), (valEntryPtr != NULL)); + if (valEntryPtr == NULL) { + ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); + return TCL_ERROR; + } + } + DEBUG_PRINT("}\n"); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * ReportUndefinedLabel -- + * + * Report that a basic block refers to an undefined jump label + * + * Side effects: + * Stores an error message, error code, and line number information in + * the assembler's Tcl interpreter. + * + *----------------------------------------------------------------------------- + */ + +static void +ReportUndefinedLabel( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr, /* Basic block that contains the undefined + * label */ + Tcl_Obj* jumpTarget) /* Label of a jump target */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "undefined label \"%s\"", Tcl_GetString(jumpTarget))); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", + Tcl_GetString(jumpTarget), NULL); + Tcl_SetErrorLine(interp, bbPtr->jumpLine); + } +} + +/* + *----------------------------------------------------------------------------- + * + * MoveCodeForJumps -- + * + * Move bytecodes in memory to accommodate JUMP1 instructions that have + * expanded to become JUMP4's. + * + *----------------------------------------------------------------------------- + */ + +static void +MoveCodeForJumps( + AssemblyEnv* assemEnvPtr, /* Assembler environment */ + int mustMove) /* Number of bytes of added code */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Pointer to a basic block being checked */ + int topOffset; /* Bytecode offset of the following basic + * block before code motion */ + + /* + * Make sure that there is enough space in the bytecode array to + * accommodate the expanded code. + */ + + while (envPtr->codeEnd < envPtr->codeNext + mustMove) { + TclExpandCodeArray(envPtr); + } + + /* + * Iterate through the bytecodes in reverse order, and move them upward to + * their new homes. + */ + + topOffset = envPtr->codeNext - envPtr->codeStart; + for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) { + DEBUG_PRINT("move code from %d to %d\n", + bbPtr->originalStartOffset, bbPtr->startOffset); + memmove(envPtr->codeStart + bbPtr->startOffset, + envPtr->codeStart + bbPtr->originalStartOffset, + topOffset - bbPtr->originalStartOffset); + topOffset = bbPtr->originalStartOffset; + bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset); + } + envPtr->codeNext += mustMove; +} + +/* + *----------------------------------------------------------------------------- + * + * FillInJumpOffsets -- + * + * Fill in the final offsets of all jump instructions once bytecode + * locations have been completely determined. + * + *----------------------------------------------------------------------------- + */ + +static void +FillInJumpOffsets( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Pointer to a basic block being checked */ + Tcl_HashEntry* entry; /* Hashtable entry for a jump target label */ + BasicBlock* jumpTarget; /* Basic block where a jump goes */ + int fromOffset; /* Bytecode location of a jump instruction */ + int targetOffset; /* Bytecode location of a jump instruction's + * target */ + + for (bbPtr = assemEnvPtr->head_bb; + bbPtr != NULL; + bbPtr = bbPtr->successor1) { + if (bbPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(bbPtr->jumpTarget)); + jumpTarget = Tcl_GetHashValue(entry); + fromOffset = bbPtr->jumpOffset; + targetOffset = jumpTarget->startOffset; + if (bbPtr->flags & BB_JUMP1) { + TclStoreInt1AtPtr(targetOffset - fromOffset, + envPtr->codeStart + fromOffset + 1); + } else { + TclStoreInt4AtPtr(targetOffset - fromOffset, + envPtr->codeStart + fromOffset + 1); + } + } + if (bbPtr->flags & BB_JUMPTABLE) { + ResolveJumpTableTargets(assemEnvPtr, bbPtr); + } + } +} + +/* + *----------------------------------------------------------------------------- + * + * ResolveJumpTableTargets -- + * + * Puts bytecode addresses for the targets of a jumptable into the + * table + * + * Results: + * Returns TCL_OK if they are, TCL_ERROR if they aren't. + * + *----------------------------------------------------------------------------- + */ + +static void +ResolveJumpTableTargets( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr) /* Basic block that ends in a jump table */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; + /* Hash table with the symbols */ + Tcl_HashSearch search; /* Hash table iterator */ + Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ + Tcl_Obj* symbolObj; /* Jump target */ + Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ + int auxDataIndex; /* Index of the auxdata */ + JumptableInfo* realJumpTablePtr; + /* Jump table in the actual code */ + Tcl_HashTable* realJumpHashPtr; + /* Jump table hash in the actual code */ + Tcl_HashEntry* realJumpEntryPtr; + /* Entry in the jump table hash in + * the actual code */ + BasicBlock* jumpTargetBBPtr; + /* Basic block that the jump proceeds to */ + int junk; + + auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); + DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", + bbPtr, bbPtr->jumpOffset, auxDataIndex); + realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex); + realJumpHashPtr = &realJumpTablePtr->hashTable; + + /* + * Look up every jump target in the jump hash. + */ + + DEBUG_PRINT("resolve jump table {\n"); + for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); + symEntryPtr != NULL; + symEntryPtr = Tcl_NextHashEntry(&search)) { + symbolObj = Tcl_GetHashValue(symEntryPtr); + DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); + + valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(symbolObj)); + jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr); + + realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, + Tcl_GetHashKey(symHash, symEntryPtr), &junk); + DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", + (char*) Tcl_GetHashKey(symHash, symEntryPtr), + Tcl_GetString(symbolObj), jumpTargetBBPtr, + jumpTargetBBPtr->startOffset, realJumpEntryPtr); + + Tcl_SetHashValue(realJumpEntryPtr, + INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); + } + DEBUG_PRINT("}\n"); +} + +/* + *----------------------------------------------------------------------------- + * + * CheckForThrowInWrongContext -- + * + * Verify that no beginCatch/endCatch sequence can throw an exception + * after an original exception is caught and before its exception context + * is removed from the stack. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Stores an appropriate error message in the interpreter as needed. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckForThrowInWrongContext( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + BasicBlock* blockPtr; /* Current basic block */ + + /* + * Walk through the basic blocks in turn, checking all the ones that have + * caught an exception and not disposed of it properly. + */ + + for (blockPtr = assemEnvPtr->head_bb; + blockPtr != NULL; + blockPtr = blockPtr->successor1) { + if (blockPtr->catchState == BBCS_CAUGHT) { + /* + * Walk through the instructions in the basic block. + */ + + if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) { + return TCL_ERROR; + } + } + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckNonThrowingBlock -- + * + * Check that a basic block cannot throw an exception. + * + * Results: + * Returns TCL_ERROR if the block cannot be proven to be nonthrowing. + * + * Side effects: + * Stashes an error message in the interpreter result. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckNonThrowingBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* blockPtr) /* Basic block where exceptions are not + * allowed */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* nextPtr; /* Pointer to the succeeding basic block */ + int offset; /* Bytecode offset of the current + * instruction */ + int bound; /* Bytecode offset following the last + * instruction of the block. */ + unsigned char opcode; /* Current bytecode instruction */ + + /* + * Determine where in the code array the basic block ends. + */ + + nextPtr = blockPtr->successor1; + if (nextPtr == NULL) { + bound = envPtr->codeNext - envPtr->codeStart; + } else { + bound = nextPtr->startOffset; + } + + /* + * Walk through the instructions of the block. + */ + + offset = blockPtr->startOffset; + while (offset < bound) { + /* + * Determine whether an instruction is nonthrowing. + */ + + opcode = (envPtr->codeStart)[offset]; + if (BytecodeMightThrow(opcode)) { + /* + * Report an error for a throw in the wrong context. + */ + + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" instruction may not appear in " + "a context where an exception has been " + "caught and not disposed of.", + tclInstructionTable[opcode].name)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); + AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); + } + return TCL_ERROR; + } + offset += tclInstructionTable[opcode].numBytes; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * BytecodeMightThrow -- + * + * Tests if a given bytecode instruction might throw an exception. + * + * Results: + * Returns 1 if the bytecode might throw an exception, 0 if the + * instruction is known never to throw. + * + *----------------------------------------------------------------------------- + */ + +static int +BytecodeMightThrow( + unsigned char opcode) +{ + /* + * Binary search on the non-throwing bytecode list. + */ + + int min = 0; + int max = sizeof(NonThrowingByteCodes) - 1; + int mid; + unsigned char c; + + while (max >= min) { + mid = (min + max) / 2; + c = NonThrowingByteCodes[mid]; + if (opcode < c) { + max = mid-1; + } else if (opcode > c) { + min = mid+1; + } else { + /* + * Opcode is nonthrowing. + */ + + return 0; + } + } + + return 1; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckStack -- + * + * Audit stack usage in a block of assembly code. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Updates stack depth on entry for all basic blocks in the flowgraph. + * Calculates the max stack depth used in the program, and updates the + * compilation environment to reflect it. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckStack( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + int maxDepth; /* Maximum stack depth overall */ + + /* + * Checking the head block will check all the other blocks recursively. + */ + + assemEnvPtr->maxDepth = 0; + if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL, + 0) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Post the max stack depth back to the compilation environment. + */ + + maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth; + if (maxDepth > envPtr->maxStackDepth) { + envPtr->maxStackDepth = maxDepth; + } + + /* + * If the exit is reachable, make sure that the program exits with 1 + * operand on the stack. + */ + + if (StackCheckExit(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Reset the visited state on all basic blocks. + */ + + ResetVisitedBasicBlocks(assemEnvPtr); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * StackCheckBasicBlock -- + * + * Checks stack consumption for a basic block (and recursively for its + * successors). + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Updates initial stack depth for the basic block and its successors. + * (Final and maximum stack depth are relative to initial, and are not + * touched). + * + * This procedure eventually checks, for the entire flow graph, whether stack + * balance is consistent. It is an error for a given basic block to be + * reachable along multiple flow paths with different stack depths. + * + *----------------------------------------------------------------------------- + */ + +static int +StackCheckBasicBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* blockPtr, /* Pointer to the basic block being checked */ + BasicBlock* predecessor, /* Pointer to the block that passed control to + * this one. */ + int initialStackDepth) /* Stack depth on entry to the block */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* jumpTarget; /* Basic block where a jump goes */ + int stackDepth; /* Current stack depth */ + int maxDepth; /* Maximum stack depth so far */ + int result; /* Tcl status return */ + Tcl_HashSearch jtSearch; /* Search structure for the jump table */ + Tcl_HashEntry* jtEntry; /* Hash entry in the jump table */ + Tcl_Obj* targetLabel; /* Target label from the jump table */ + Tcl_HashEntry* entry; /* Hash entry in the label table */ + + if (blockPtr->flags & BB_VISITED) { + /* + * If the block is already visited, check stack depth for consistency + * among the paths that reach it. + */ + + if (blockPtr->initialStackDepth == initialStackDepth) { + return TCL_OK; + } + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "inconsistent stack depths on two execution paths", -1)); + + /* + * TODO - add execution trace of both paths + */ + + Tcl_SetErrorLine(interp, blockPtr->startLine); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + } + return TCL_ERROR; + } + + /* + * If the block is not already visited, set the 'predecessor' link to + * indicate how control got to it. Set the initial stack depth to the + * current stack depth in the flow of control. + */ + + blockPtr->flags |= BB_VISITED; + blockPtr->predecessor = predecessor; + blockPtr->initialStackDepth = initialStackDepth; + + /* + * Calculate minimum stack depth, and flag an error if the block + * underflows the stack. + */ + + if (initialStackDepth + blockPtr->minStackDepth < 0) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); + Tcl_SetErrorLine(interp, blockPtr->startLine); + } + return TCL_ERROR; + } + + /* + * Make sure that the block doesn't try to pop below the stack level of an + * enclosing catch. + */ + + if (blockPtr->enclosingCatch != 0 && + initialStackDepth + blockPtr->minStackDepth + < (blockPtr->enclosingCatch->initialStackDepth + + blockPtr->enclosingCatch->finalStackDepth)) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "code pops stack below level of enclosing catch", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1); + AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); + Tcl_SetErrorLine(interp, blockPtr->startLine); + } + return TCL_ERROR; + } + + /* + * Update maximum stgack depth. + */ + + maxDepth = initialStackDepth + blockPtr->maxStackDepth; + if (maxDepth > assemEnvPtr->maxDepth) { + assemEnvPtr->maxDepth = maxDepth; + } + + /* + * Calculate stack depth on exit from the block, and invoke this procedure + * recursively to check successor blocks. + */ + + stackDepth = initialStackDepth + blockPtr->finalStackDepth; + result = TCL_OK; + if (blockPtr->flags & BB_FALLTHRU) { + result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1, + blockPtr, stackDepth); + } + + if (result == TCL_OK && blockPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(blockPtr->jumpTarget)); + jumpTarget = Tcl_GetHashValue(entry); + result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, + stackDepth); + } + + /* + * All blocks referenced in a jump table are successors. + */ + + if (blockPtr->flags & BB_JUMPTABLE) { + for (jtEntry = Tcl_FirstHashEntry(&blockPtr->jtPtr->hashTable, + &jtSearch); + result == TCL_OK && jtEntry != NULL; + jtEntry = Tcl_NextHashEntry(&jtSearch)) { + targetLabel = Tcl_GetHashValue(jtEntry); + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(targetLabel)); + jumpTarget = Tcl_GetHashValue(entry); + result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, + blockPtr, stackDepth); + } + } + + return result; +} + +/* + *----------------------------------------------------------------------------- + * + * StackCheckExit -- + * + * Makes sure that the net stack effect of an entire assembly language + * script is to push 1 result. + * + * Results: + * Returns a standard Tcl result, with an error message in the + * interpreter result if the stack is wrong. + * + * Side effects: + * If the assembly code had a net stack effect of zero, emits code to the + * concluding block to push a null result. In any case, updates the stack + * depth in the compile environment to reflect the net effect of the + * assembly code. + * + *----------------------------------------------------------------------------- + */ + +static int +StackCheckExit( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + int depth; /* Net stack effect */ + int litIndex; /* Index in the literal pool of the empty + * string */ + BasicBlock* curr_bb = assemEnvPtr->curr_bb; + /* Final basic block in the assembly */ + + /* + * Don't perform these checks if execution doesn't reach the exit (either + * because of an infinite loop or because the only return is from the + * middle. + */ + + if (curr_bb->flags & BB_VISITED) { + /* + * Exit with no operands; push an empty one. + */ + + depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; + if (depth == 0) { + /* + * Emit a 'push' of the empty literal. + */ + + litIndex = TclRegisterNewLiteral(envPtr, "", 0); + + /* + * Assumes that 'push' is at slot 0 in TalInstructionTable. + */ + + BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); + ++depth; + } + + /* + * Exit with unbalanced stack. + */ + + if (depth != 1) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "stack is unbalanced on exit from the code (depth=%d)", + depth)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); + } + return TCL_ERROR; + } + + /* + * Record stack usage. + */ + + envPtr->currStackDepth += depth; + } + + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * ProcessCatches -- + * + * First pass of 'catch' processing. + * + * Results: + * Returns a standard Tcl result, with an appropriate error message if + * the result is TCL_ERROR. + * + * Side effects: + * Labels all basic blocks with their enclosing catches. + * + *----------------------------------------------------------------------------- + */ + +static int +ProcessCatches( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + BasicBlock* blockPtr; /* Pointer to a basic block */ + + /* + * Clear the catch state of all basic blocks. + */ + + for (blockPtr = assemEnvPtr->head_bb; + blockPtr != NULL; + blockPtr = blockPtr->successor1) { + blockPtr->catchState = BBCS_UNKNOWN; + blockPtr->enclosingCatch = NULL; + } + + /* + * Start the check recursively from the first basic block, which is + * outside any exception context + */ + + if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, + NULL, BBCS_NONE, 0) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Check for unclosed catch on exit. + */ + + if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Now there's enough information to build the exception ranges. + */ + + if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Finally, restore any exception ranges from embedded scripts. + */ + + RestoreEmbeddedExceptionRanges(assemEnvPtr); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * ProcessCatchesInBasicBlock -- + * + * First-pass catch processing for one basic block. + * + * Results: + * Returns a standard Tcl result, with error message in the interpreter + * result if an error occurs. + * + * This procedure checks consistency of the exception context through the + * assembler program, and records the enclosing 'catch' for every basic block. + * + *----------------------------------------------------------------------------- + */ + +static int +ProcessCatchesInBasicBlock( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr, /* Basic block being processed */ + BasicBlock* enclosing, /* Start basic block of the enclosing catch */ + enum BasicBlockCatchState state, + /* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */ + int catchDepth) /* Depth of nesting of catches */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + int result; /* Return value from this procedure */ + BasicBlock* fallThruEnclosing; + /* Enclosing catch if execution falls thru */ + enum BasicBlockCatchState fallThruState; + /* Catch state of the successor block */ + BasicBlock* jumpEnclosing; /* Enclosing catch if execution goes to jump + * target */ + enum BasicBlockCatchState jumpState; + /* Catch state of the jump target */ + int changed = 0; /* Flag == 1 iff successor blocks need to be + * checked because the state of this block has + * changed. */ + BasicBlock* jumpTarget; /* Basic block where a jump goes */ + Tcl_HashSearch jtSearch; /* Hash search control for a jumptable */ + Tcl_HashEntry* jtEntry; /* Entry in a jumptable */ + Tcl_Obj* targetLabel; /* Target label from a jumptable */ + Tcl_HashEntry* entry; /* Entry from the label table */ + + /* + * Update the state of the current block, checking for consistency. Set + * 'changed' to 1 if the state changes and successor blocks need to be + * rechecked. + */ + + if (bbPtr->catchState == BBCS_UNKNOWN) { + bbPtr->enclosingCatch = enclosing; + } else if (bbPtr->enclosingCatch != enclosing) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "execution reaches an instruction in inconsistent " + "exception contexts", -1)); + Tcl_SetErrorLine(interp, bbPtr->startLine); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL); + } + return TCL_ERROR; + } + if (state > bbPtr->catchState) { + bbPtr->catchState = state; + changed = 1; + } + + /* + * If this block has been visited before, and its state hasn't changed, + * we're done with it for now. + */ + + if (!changed) { + return TCL_OK; + } + bbPtr->catchDepth = catchDepth; + + /* + * Determine enclosing catch and 'caught' state for the fallthrough and + * the jump target. Default for both is the state of the current block. + */ + + fallThruEnclosing = enclosing; + fallThruState = state; + jumpEnclosing = enclosing; + jumpState = state; + + /* + * TODO: Make sure that the test cases include validating that a natural + * loop can't include 'beginCatch' or 'endCatch' + */ + + if (bbPtr->flags & BB_BEGINCATCH) { + /* + * If the block begins a catch, the state for the successor is 'in + * catch'. The jump target is the exception exit, and the state of the + * jump target is 'caught.' + */ + + fallThruEnclosing = bbPtr; + fallThruState = BBCS_INCATCH; + jumpEnclosing = bbPtr; + jumpState = BBCS_CAUGHT; + ++catchDepth; + } + + if (bbPtr->flags & BB_ENDCATCH) { + /* + * If the block ends a catch, the state for the successor is whatever + * the state was on entry to the catch. + */ + + if (enclosing == NULL) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "endCatch without a corresponding beginCatch", -1)); + Tcl_SetErrorLine(interp, bbPtr->startLine); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL); + } + return TCL_ERROR; + } + fallThruEnclosing = enclosing->enclosingCatch; + fallThruState = enclosing->catchState; + --catchDepth; + } + + /* + * Visit any successor blocks with the appropriate exception context + */ + + result = TCL_OK; + if (bbPtr->flags & BB_FALLTHRU) { + result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1, + fallThruEnclosing, fallThruState, catchDepth); + } + if (result == TCL_OK && bbPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(bbPtr->jumpTarget)); + jumpTarget = Tcl_GetHashValue(entry); + result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, + jumpEnclosing, jumpState, catchDepth); + } + + /* + * All blocks referenced in a jump table are successors. + */ + + if (bbPtr->flags & BB_JUMPTABLE) { + for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch); + result == TCL_OK && jtEntry != NULL; + jtEntry = Tcl_NextHashEntry(&jtSearch)) { + targetLabel = Tcl_GetHashValue(jtEntry); + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(targetLabel)); + jumpTarget = Tcl_GetHashValue(entry); + result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, + jumpEnclosing, jumpState, catchDepth); + } + } + + return result; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckForUnclosedCatches -- + * + * Checks that a sequence of assembly code has no unclosed catches on + * exit. + * + * Results: + * Returns a standard Tcl result, with an error message for unclosed + * catches. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckForUnclosedCatches( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + + if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "catch still active on exit from assembly code", -1)); + Tcl_SetErrorLine(interp, + assemEnvPtr->curr_bb->enclosingCatch->startLine); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * BuildExceptionRanges -- + * + * Walks through the assembly code and builds exception ranges for the + * catches embedded therein. + * + * Results: + * Returns a standard Tcl result with an error message in the interpreter + * if anything is unsuccessful. + * + * Side effects: + * Each contiguous block of code with a given catch exit is assigned an + * exception range at the appropriate level. + * Exception ranges in embedded blocks have their levels corrected and + * collated into the table. + * Blocks that end with 'beginCatch' are associated with the innermost + * exception range of the following block. + * + *----------------------------------------------------------------------------- + */ + +static int +BuildExceptionRanges( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Current basic block */ + BasicBlock* prevPtr = NULL; /* Previous basic block */ + int catchDepth = 0; /* Current catch depth */ + int maxCatchDepth = 0; /* Maximum catch depth in the program */ + BasicBlock** catches; /* Stack of catches in progress */ + int* catchIndices; /* Indices of the exception ranges of catches + * in progress */ + int i; + + /* + * Determine the max catch depth for the entire assembly script + * (excluding embedded eval's and expr's, which will be handled later). + */ + + for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { + if (bbPtr->catchDepth > maxCatchDepth) { + maxCatchDepth = bbPtr->catchDepth; + } + } + + /* + * Allocate memory for a stack of active catches. + */ + + catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*)); + catchIndices = ckalloc(maxCatchDepth * sizeof(int)); + for (i = 0; i < maxCatchDepth; ++i) { + catches[i] = NULL; + catchIndices[i] = -1; + } + + /* + * Walk through the basic blocks and manage exception ranges. + */ + + for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { + UnstackExpiredCatches(envPtr, bbPtr, catchDepth, catches, + catchIndices); + LookForFreshCatches(bbPtr, catches); + StackFreshCatches(assemEnvPtr, bbPtr, catchDepth, catches, + catchIndices); + + /* + * If the last block was a 'begin catch', fill in the exception range. + */ + + catchDepth = bbPtr->catchDepth; + if (prevPtr != NULL && (prevPtr->flags & BB_BEGINCATCH)) { + TclStoreInt4AtPtr(catchIndices[catchDepth-1], + envPtr->codeStart + bbPtr->startOffset - 4); + } + + prevPtr = bbPtr; + } + + /* Make sure that all catches are closed */ + + if (catchDepth != 0) { + Tcl_Panic("unclosed catch at end of code in " + "tclAssembly.c:BuildExceptionRanges, can't happen"); + } + + /* Free temp storage */ + + ckfree(catchIndices); + ckfree(catches); + + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * UnstackExpiredCatches -- + * + * Unstacks and closes the exception ranges for any catch contexts that + * were active in the previous basic block but are inactive in the + * current one. + * + *----------------------------------------------------------------------------- + */ + +static void +UnstackExpiredCatches( + CompileEnv* envPtr, /* Compilation environment */ + BasicBlock* bbPtr, /* Basic block being processed */ + int catchDepth, /* Depth of nesting of catches prior to entry + * to this block */ + BasicBlock** catches, /* Array of catch contexts */ + int* catchIndices) /* Indices of the exception ranges + * corresponding to the catch contexts */ +{ + ExceptionRange* range; /* Exception range for a specific catch */ + BasicBlock* catch; /* Catch block being examined */ + BasicBlockCatchState catchState; + /* State of the code relative to the catch + * block being examined ("in catch" or + * "caught"). */ + + /* + * Unstack any catches that are deeper than the nesting level of the basic + * block being entered. + */ + + while (catchDepth > bbPtr->catchDepth) { + --catchDepth; + range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; + range->numCodeBytes = bbPtr->startOffset - range->codeOffset; + catches[catchDepth] = NULL; + catchIndices[catchDepth] = -1; + } + + /* + * Unstack any catches that don't match the basic block being entered, + * either because they are no longer part of the context, or because the + * context has changed from INCATCH to CAUGHT. + */ + + catchState = bbPtr->catchState; + catch = bbPtr->enclosingCatch; + while (catchDepth > 0) { + --catchDepth; + if (catches[catchDepth] != NULL) { + if (catches[catchDepth] != catch || catchState >= BBCS_CAUGHT) { + range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; + range->numCodeBytes = bbPtr->startOffset - range->codeOffset; + catches[catchDepth] = NULL; + catchIndices[catchDepth] = -1; + } + catchState = catch->catchState; + catch = catch->enclosingCatch; + } + } +} + +/* + *----------------------------------------------------------------------------- + * + * LookForFreshCatches -- + * + * Determines whether a basic block being entered needs any exception + * ranges that are not already stacked. + * + * Does not create the ranges: this procedure iterates from the innermost + * catch outward, but exception ranges must be created from the outermost + * catch inward. + * + *----------------------------------------------------------------------------- + */ + +static void +LookForFreshCatches( + BasicBlock* bbPtr, /* Basic block being entered */ + BasicBlock** catches) /* Array of catch contexts that are already + * entered */ +{ + BasicBlockCatchState catchState; + /* State ("in catch" or "caught") of the + * current catch. */ + BasicBlock* catch; /* Current enclosing catch */ + int catchDepth; /* Nesting depth of the current catch */ + + catchState = bbPtr->catchState; + catch = bbPtr->enclosingCatch; + catchDepth = bbPtr->catchDepth; + while (catchDepth > 0) { + --catchDepth; + if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) { + catches[catchDepth] = catch; + } + catchState = catch->catchState; + catch = catch->enclosingCatch; + } +} + +/* + *----------------------------------------------------------------------------- + * + * StackFreshCatches -- + * + * Make ExceptionRange records for any catches that are in the basic + * block being entered and were not in the previous basic block. + * + *----------------------------------------------------------------------------- + */ + +static void +StackFreshCatches( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr, /* Basic block being processed */ + int catchDepth, /* Depth of nesting of catches prior to entry + * to this block */ + BasicBlock** catches, /* Array of catch contexts */ + int* catchIndices) /* Indices of the exception ranges + * corresponding to the catch contexts */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + ExceptionRange* range; /* Exception range for a specific catch */ + BasicBlock* catch; /* Catch block being examined */ + BasicBlock* errorExit; /* Error exit from the catch block */ + Tcl_HashEntry* entryPtr; + + catchDepth = 0; + + /* + * Iterate through the enclosing catch blocks from the outside in, + * looking for ones that don't have exception ranges (and are uncaught) + */ + + for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) { + if (catchIndices[catchDepth] == -1 && catches[catchDepth] != NULL) { + /* + * Create an exception range for a block that needs one. + */ + + catch = catches[catchDepth]; + catchIndices[catchDepth] = + TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; + range->nestingLevel = envPtr->exceptDepth + catchDepth; + envPtr->maxExceptDepth = + TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); + range->codeOffset = bbPtr->startOffset; + + entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + Tcl_GetString(catch->jumpTarget)); + if (entryPtr == NULL) { + Tcl_Panic("undefined label in tclAssembly.c:" + "BuildExceptionRanges, can't happen"); + } + + errorExit = Tcl_GetHashValue(entryPtr); + range->catchOffset = errorExit->startOffset; + } + } +} + +/* + *----------------------------------------------------------------------------- + * + * RestoreEmbeddedExceptionRanges -- + * + * Processes an assembly script, replacing any exception ranges that + * were present in embedded code. + * + *----------------------------------------------------------------------------- + */ + +static void +RestoreEmbeddedExceptionRanges( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + BasicBlock* bbPtr; /* Current basic block */ + int rangeBase; /* Base of the foreign exception ranges when + * they are reinstalled */ + int rangeIndex; /* Index of the current foreign exception + * range as reinstalled */ + ExceptionRange* range; /* Current foreign exception range */ + unsigned char opcode; /* Current instruction's opcode */ + int catchIndex; /* Index of the exception range to which the + * current instruction refers */ + int i; + + /* + * Walk the basic blocks looking for exceptions in embedded scripts. + */ + + for (bbPtr = assemEnvPtr->head_bb; + bbPtr != NULL; + bbPtr = bbPtr->successor1) { + if (bbPtr->foreignExceptionCount != 0) { + /* + * Reinstall the embedded exceptions and track their nesting level + */ + + rangeBase = envPtr->exceptArrayNext; + for (i = 0; i < bbPtr->foreignExceptionCount; ++i) { + range = bbPtr->foreignExceptions + i; + rangeIndex = TclCreateExceptRange(range->type, envPtr); + range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; + memcpy(envPtr->exceptArrayPtr + rangeIndex, range, + sizeof(ExceptionRange)); + if (range->nestingLevel >= envPtr->maxExceptDepth) { + envPtr->maxExceptDepth = range->nestingLevel + 1; + } + } + + /* + * Walk through the bytecode of the basic block, and relocate + * INST_BEGIN_CATCH4 instructions to the new locations + */ + + i = bbPtr->startOffset; + while (i < bbPtr->successor1->startOffset) { + opcode = envPtr->codeStart[i]; + if (opcode == INST_BEGIN_CATCH4) { + catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1); + if (catchIndex >= bbPtr->foreignExceptionBase + && catchIndex < (bbPtr->foreignExceptionBase + + bbPtr->foreignExceptionCount)) { + catchIndex -= bbPtr->foreignExceptionBase; + catchIndex += rangeBase; + TclStoreInt4AtPtr(catchIndex, envPtr->codeStart+i+1); + } + } + i += tclInstructionTable[opcode].numBytes; + } + } + } +} + +/* + *----------------------------------------------------------------------------- + * + * ResetVisitedBasicBlocks -- + * + * Turns off the 'visited' flag in all basic blocks at the conclusion + * of a pass. + * + *----------------------------------------------------------------------------- + */ + +static void +ResetVisitedBasicBlocks( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ +{ + BasicBlock* block; + + for (block = assemEnvPtr->head_bb; block != NULL; + block = block->successor1) { + block->flags &= ~BB_VISITED; + } +} + +/* + *----------------------------------------------------------------------------- + * + * AddBasicBlockRangeToErrorInfo -- + * + * Updates the error info of the Tcl interpreter to show a given basic + * block in the code. + * + * This procedure is used to label the callstack with source location + * information when reporting an error in stack checking. + * + *----------------------------------------------------------------------------- + */ + +static void +AddBasicBlockRangeToErrorInfo( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + BasicBlock* bbPtr) /* Basic block in which the error is found */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + Tcl_Obj* lineNo; /* Line number in the source */ + + Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); + lineNo = Tcl_NewIntObj(bbPtr->startLine); + Tcl_IncrRefCount(lineNo); + Tcl_AppendObjToErrorInfo(interp, lineNo); + Tcl_AddErrorInfo(interp, " and "); + if (bbPtr->successor1 != NULL) { + Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); + Tcl_AppendObjToErrorInfo(interp, lineNo); + } else { + Tcl_AddErrorInfo(interp, "end of assembly code"); + } + Tcl_DecrRefCount(lineNo); +} + +/* + *----------------------------------------------------------------------------- + * + * DupAssembleCodeInternalRep -- + * + * Part of the Tcl object type implementation for Tcl assembly language + * bytecode. We do not copy the bytecode intrep. Instead, we return + * without setting copyPtr->typePtr, so the copy is a plain string copy + * of the assembly source, and if it is to be used as a compiled + * expression, it will need to be reprocessed. + * + * This makes sense, because with Tcl's copy-on-write practices, the + * usual (only?) time Tcl_DuplicateObj() will be called is when the copy + * is about to be modified, which would invalidate any copied bytecode + * anyway. The only reason it might make sense to copy the bytecode is if + * we had some modifying routines that operated directly on the intrep, + * as we do for lists and dicts. + * + * Results: + * None. + * + * Side effects: + * None. + * + *----------------------------------------------------------------------------- + */ + +static void +DupAssembleCodeInternalRep( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) +{ + return; +} + +/* + *----------------------------------------------------------------------------- + * + * FreeAssembleCodeInternalRep -- + * + * Part of the Tcl object type implementation for Tcl expression + * bytecode. Frees the storage allocated to hold the internal rep, unless + * ref counts indicate bytecode execution is still in progress. + * + * Results: + * None. + * + * Side effects: + * May free allocated memory. Leaves objPtr untyped. + * + *----------------------------------------------------------------------------- + */ + +static void +FreeAssembleCodeInternalRep( + Tcl_Obj *objPtr) +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |