/* * 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. * * RCS: @(#) $Id: tclAssembly.c,v 1.1.2.18 2010/12/16 01:40:42 kennykb Exp $ */ /*- *- 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 *- dictFirst, dictNext, dictDone *- dictUpdateStart, dictUpdateEnd *- jumpTable testing *- syntax (?) *- returnCodeBranch */ #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 tblind, int count); static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblind, unsigned char opnd, int count); static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblind, int opnd, int count); static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblind, int param, int count); static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblind, 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*, 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 */ }; /* * TIP #280: Remember the per-word line information of the current command. An * index is used instead of a pointer as recursive compilation may reallocate, * i.e. move, the array. This is also the reason to save the nuloc now, it may * change during the course of the function. * * Macro to encapsulate the variable definition and setup. */ #define DefineLineInformation \ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 #define SetLineInformation(word) \ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] /* * Flags bits used by PushVarName. */ #define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ /* * Source instructions recognized in the Tcl Assembly Language (TAL) */ 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}, {"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_CONCAT1, INT_MIN,1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 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}, {"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_SCALAR_STK, 2, 1}, {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, 1, 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}, {"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_SCALAR_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}, {"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}, {"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_SCALAR_STK, 2, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"sub", ASSEM_1BYTE , INST_SUB , 2 , 1}, {"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}, {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 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_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ INST_NOP /* 132 */ }; /* *----------------------------------------------------------------------------- * * 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 tblind, /* Index in TalInstructionTable of the * operation being assembled */ int count) /* Count of operands for variadic insts */ { int consumed = TalInstructionTable[tblind].operandsConsumed; int produced = TalInstructionTable[tblind].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 tblind, /* 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[tblind].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); envPtr->atCmdStart = ((op) == INST_START_CMD); BBUpdateStackReqs(bbPtr, tblind, count); } static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, /* Assembly environment */ int tblind, /* Index in TalInstructionTable of op */ unsigned char opnd, /* 1-byte operand */ int count) /* Operand count for variadic ops */ { BBEmitOpcode(assemEnvPtr, tblind, count); TclEmitInt1(opnd, assemEnvPtr->envPtr); } static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, /* Assembly environment */ int tblind, /* Index in TalInstructionTable of op */ int opnd, /* 4-byte operand */ int count) /* Operand count for variadic ops */ { BBEmitOpcode(assemEnvPtr, tblind, 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 tblind, /* 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[tblind].tclInstCode; if (param <= 0xff) { op >>= 8; } else { op &= 0xff; } TclEmitInt1(op, envPtr); if (param <= 0xff) { TclEmitInt1(param, envPtr); } else { TclEmitInt4(param, envPtr); } envPtr->atCmdStart = ((op) == INST_START_CMD); BBUpdateStackReqs(bbPtr, tblind, 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. */ /* Check args */ 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_AddErrorInfo(interp, Tcl_GetString(objv[0])); Tcl_AddErrorInfo(interp, "\" body, line "); backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp)); Tcl_IncrRefCount(backtrace); Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace)); Tcl_DecrRefCount(backtrace); Tcl_AddErrorInfo(interp, ")"); return TCL_ERROR; } /* Use NRE to evaluate the bytecode from the trampoline */ /* Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, NULL, NULL); return TCL_OK; */ 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 = (ByteCode *) objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { FreeAssembleCodeInternalRep(objPtr); } } if (objPtr->typePtr != &assembleCodeType) { /* 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 = (ByteCode *) objPtr->internalRep.otherValuePtr; 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 status; /* Status return from assembling the code */ /* Make sure that the command has a single arg */ if (parsePtr->numWords != 2) { return TCL_ERROR; } /* Make sure that the arg is a simple word */ tokenPtr = TokenAfter(parsePtr->tokenPtr); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } /* Compile the code and return any error from the compilation */ status = TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); return status; } /* *----------------------------------------------------------------------------- * * 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 */ int instLen; /* Length in bytes of the current 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); instLen = parsePtr->commandSize; if (parsePtr->term == parsePtr->commandStart + instLen - 1) { --instLen; } /* Report errors in the parse */ if (status != TCL_OK) { if (flags & TCL_EVAL_DIRECT) { Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, instLen); } 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) { /* If tracing, show each line assembled as it happens */ #ifdef TCL_COMPILE_DEBUG if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { printf(" %4d Assembling: ", 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 = envPtr->line; 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 */ Tcl_HashEntry* hashEntry; Tcl_HashSearch hashSearch; /* 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((char*)(thisBB->foreignExceptions)); } nextBB = thisBB->successor1; if (thisBB->jtPtr != NULL) { DeleteMirrorJumpTable(thisBB->jtPtr); thisBB->jtPtr = NULL; } ckfree((char*)thisBB); } /* Free the label hash */ while ((hashEntry = Tcl_FirstHashEntry(&assemEnvPtr->labelHash, &hashSearch)) != NULL) { Tcl_DeleteHashEntry(hashEntry); } 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 = NULL; /* Name of the instruction */ int tblind; /* 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; instNameObj = Tcl_NewObj(); Tcl_IncrRefCount(instNameObj); 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, &tblind) != TCL_OK) { return TCL_ERROR; } /* Vector on the type of instruction being processed */ instType = TalInstructionTable[tblind].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, tblind, litIndex, 0); break; case ASSEM_1BYTE: if (parsePtr->numWords != 1) { Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); goto cleanup; } BBEmitOpcode(assemEnvPtr, tblind, 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, tblind, 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, tblind, 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 || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) { goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblind, 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, tblind, 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, tblind, 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 || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblind, 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 || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblind, 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, tblind, 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[tblind].tclInstCode == INST_EVAL_STK) ? "script" : "expression")); goto cleanup; } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { CompileEmbeddedScript(assemEnvPtr, tokenPtr+1, TalInstructionTable+tblind); } 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, tblind, 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, tblind, 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, tblind, 0, 0); } else { flags = 0; BBEmitInstInt4(assemEnvPtr, tblind, 0, 0); } /* Start a new basic block at the instruction following the jump */ assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; if (TalInstructionTable[tblind].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 = (JumptableInfo*) ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext - envPtr->codeStart; /*fprintf(stderr, "bb %p jumpLine %d jumpOffset %d\n", assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, envPtr->codeNext - envPtr->codeStart); fflush(stderr); */ infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); /* fprintf(stderr, "auxdata index=%d\n", infoIndex); */ BBEmitInstInt4(assemEnvPtr, tblind, 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, tblind, 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, tblind, 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, tblind, 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, tblind, opnd, opnd); break; case ASSEM_LVT: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) { goto cleanup; } BBEmitInst1or4(assemEnvPtr, tblind, localVar, 0); break; case ASSEM_LVT1: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0 || CheckOneByte(interp, localVar)) { goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblind, localVar, 0); break; case ASSEM_LVT1_SINT1: if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); goto cleanup; } if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0 || CheckOneByte(interp, localVar) || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK || CheckSignedOneByte(interp, opnd)) { goto cleanup; } BBEmitInstInt1(assemEnvPtr, tblind, localVar, 0); TclEmitInt1(opnd, envPtr); break; case ASSEM_LVT4: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; } if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblind, 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, tblind, 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, tblind, 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, tblind, 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, tblind, 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 || (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) { goto cleanup; } BBEmitInstInt4(assemEnvPtr, tblind, 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: if (instNameObj) { 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, /* Assembler environment */ Tcl_Token* tokenPtr, /* Tcl_Token containing the script */ TalInstDesc* instPtr) /* Instruction that determines whether * the script is 'expr' or 'eval' */ { /* * 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. */ CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ /* * 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, /* Assembler 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. */ /*fprintf(stderr, "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 = (ExceptionRange*) 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 */ Tcl_Obj* result; /* Error message */ 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 = (JumptableInfo*) ckalloc(sizeof(JumptableInfo)); jtHashPtr = &(jtPtr->hashTable); Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); /* Fill the keys and labels into the table */ /* fprintf(stderr, "jump table {\n"); */ for (i = 0; i < objc; i+=2) { /* fprintf(stderr, " %s -> %s\n", Tcl_GetString(objv[i]), Tcl_GetString(objv[i+1])); fflush(stderr); */ hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), &isNew); if (!isNew) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { result = Tcl_NewStringObj("duplicate entry in jump table for " "\"", -1); Tcl_AppendObjToObj(result, objv[i]); Tcl_AppendToObj(result, "\"", -1); Tcl_SetObjResult(interp, result); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; } } Tcl_SetHashValue(hashEntry, (ClientData) objv[i+1]); Tcl_IncrRefCount(objv[i+1]); } /* fprintf(stderr, "}\n"); fflush(stderr); */ /* 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_Obj*) Tcl_GetHashValue(entry); Tcl_DecrRefCount(label); Tcl_SetHashValue(entry, NULL); } Tcl_DeleteHashTable(jtHashPtr); ckfree((char*)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, /* Assembler 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 = Tcl_NewObj(); /* Integer from the source code */ int status; /* Tcl status return */ /* Extract the next token as a string */ Tcl_IncrRefCount(intObj); if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { Tcl_DecrRefCount(intObj); 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 = Tcl_NewObj(); /* Integer from the source code */ int status; /* Tcl status return */ /* Extract the next token as a string */ Tcl_IncrRefCount(intObj); if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { Tcl_DecrRefCount(intObj); 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 = Tcl_NewObj(); /* Integer from the source code */ int status; /* Tcl status return */ /* Extract the next token as a string */ Tcl_IncrRefCount(intObj); if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { Tcl_DecrRefCount(intObj); 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, 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 = Tcl_NewObj(); /* Name of the variable */ const char* varNameStr; int varNameLen; int localVar; /* Index of the variable in the LVT */ Tcl_IncrRefCount(varNameObj); if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { Tcl_DecrRefCount(varNameObj); return -1; } varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { 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 */ { Tcl_Obj* result; /* Error message */ const char* p; for (p = name; p+2 < name+nameLen; p++) { if ((*p == ':') && (p[1] == ':')) { result = Tcl_NewStringObj("variable \"", -1); Tcl_AppendToObj(result, name, -1); Tcl_AppendToObj(result, "\" is not local", -1); Tcl_SetObjResult(interp, result); 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 */ Tcl_Obj* result; /* Error message */ /* 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 the first appearance of the label in the code */ Tcl_SetHashValue(entry, assemEnvPtr->curr_bb); } else { /* This is a duplicate label */ if (assemEnvPtr-> flags & (TCL_EVAL_DIRECT)) { result = Tcl_NewStringObj("duplicate definition " "of label \"", -1); Tcl_AppendToObj(result, labelName, -1); Tcl_AppendToObj(result, "\"", -1); Tcl_SetObjResult(interp, result); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, NULL); } return TCL_ERROR; } 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. */ if ((currBB->jumpTarget = 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 = (BasicBlock *) 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->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 */ /* 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, /* Assembler 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 = (BasicBlock*) 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 */ /* fprintf(stderr, "check jump table labels %p {\n", bbPtr); */ for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = (Tcl_Obj*) Tcl_GetHashValue(symEntryPtr); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, Tcl_GetString(symbolObj)); /* fprintf(stderr, " %s -> %s (%d)\n", (char*)Tcl_GetHashKey(symHash, symEntryPtr), Tcl_GetString(symbolObj), (valEntryPtr != NULL)); fflush(stderr); */ if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); return TCL_ERROR; } } /* fprintf(stderr, "}\n"); fflush(stderr); */ 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, /* Assembler 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 */ Tcl_Obj* result; /* Error message */ if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { result = Tcl_NewStringObj("undefined label \"", -1); Tcl_AppendObjToObj(result, jumpTarget); Tcl_AppendToObj(result, "\"", -1); Tcl_SetObjResult(interp, result); 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) { /* fprintf(stderr, "move code from %d to %d\n", bbPtr->originalStartOffset, bbPtr->startOffset); fflush(stderr); */ 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) { 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 = (BasicBlock*) 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); /* fprintf(stderr, "bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", bbPtr, bbPtr->jumpOffset, auxDataIndex); */ realJumpTablePtr = (JumptableInfo*) envPtr->auxDataArrayPtr[auxDataIndex].clientData; realJumpHashPtr = &(realJumpTablePtr->hashTable); /* Look up every jump target in the jump hash */ /* fprintf(stderr, "resolve jump table {\n"); fflush(stderr); */ for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = (Tcl_Obj*) Tcl_GetHashValue(symEntryPtr); /* fprintf(stderr, " symbol %s\n", Tcl_GetString(symbolObj)); */ valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, Tcl_GetString(symbolObj)); jumpTargetBBPtr = (BasicBlock*) Tcl_GetHashValue(valEntryPtr); realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, Tcl_GetHashKey(symHash, symEntryPtr), &junk); /* fprintf(stderr, " %s -> %s -> bb %p (pc %d) hash entry %p\n", (char*)Tcl_GetHashKey(symHash, symEntryPtr), Tcl_GetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); fflush(stderr); */ Tcl_SetHashValue(realJumpEntryPtr, (ClientData) (jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); } /* fprintf(stderr, "}\n"); fflush(stderr); */ } /* *----------------------------------------------------------------------------- * * 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) /* Assembler 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, /* Assembler 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 */ Tcl_Obj* retval; /* Error message */ /* 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) { retval = Tcl_NewStringObj("\"", -1); Tcl_AppendToObj(retval, tclInstructionTable[opcode].name, -1); Tcl_AppendToObj(retval, "\" instruction may not appear in " "a context where an exception has been " "caught and not disposed of.", -1); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); Tcl_SetObjResult(interp, retval); 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) { 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; } else { return TCL_OK; } } /* * 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 = (BasicBlock*) 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_Obj*) Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, Tcl_GetString(targetLabel)); jumpTarget = (BasicBlock*) 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) /* Assembler 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 */ Tcl_Obj* depthObj; /* Net stack effect for an error message */ Tcl_Obj* resultObj; /* Error message from this procedure */ 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) { depthObj = Tcl_NewIntObj(depth); Tcl_IncrRefCount(depthObj); resultObj = Tcl_NewStringObj("stack is unbalanced on exit " "from the code (depth=", -1); Tcl_AppendObjToObj(resultObj, depthObj); Tcl_DecrRefCount(depthObj); Tcl_AppendToObj(resultObj, ")", -1); Tcl_SetObjResult(interp, resultObj); 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) /* Assembler 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, /* Assembler 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 = (BasicBlock*) 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_Obj*) Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, Tcl_GetString(targetLabel)); jumpTarget = (BasicBlock*) 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) { 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) /* Assembler 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 = (BasicBlock**) ckalloc(maxCatchDepth * sizeof(BasicBlock*)); catchIndices = (int*) 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; } if (catchDepth != 0) { Tcl_Panic("unclosed catch at end of code in " "tclAssembly.c:BuildExceptionRanges, can't happen"); } 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; if ((entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, Tcl_GetString(catch->jumpTarget))) == NULL) { Tcl_Panic("undefined label in tclAssembly.c:" "BuildExceptionRanges, can't happen"); } else { errorExit = (BasicBlock*) 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) /* Assembler 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 */ unsigned 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) { 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_AddErrorInfo(interp, Tcl_GetString(lineNo)); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); Tcl_AddErrorInfo(interp, Tcl_GetString(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 = (ByteCode *) objPtr->internalRep.otherValuePtr; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } objPtr->typePtr = NULL; objPtr->internalRep.otherValuePtr = NULL; }