diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclAssembly.c | 4176 | ||||
| -rw-r--r-- | generic/tclBasic.c | 77 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 4 | ||||
| -rw-r--r-- | generic/tclCompCmdsSZ.c | 2 | ||||
| -rw-r--r-- | generic/tclExecute.c | 30 | ||||
| -rw-r--r-- | generic/tclInt.decls | 5 | ||||
| -rw-r--r-- | generic/tclInt.h | 29 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 6 | ||||
| -rw-r--r-- | generic/tclInterp.c | 76 | ||||
| -rw-r--r-- | generic/tclMain.c | 2 | ||||
| -rw-r--r-- | generic/tclOODecls.h | 2 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 1 | ||||
| -rw-r--r-- | generic/tclTomMath.decls | 2 | ||||
| -rw-r--r-- | generic/tclUtil.c | 2 | ||||
| -rw-r--r-- | generic/tclZlib.c | 2 |
15 files changed, 4355 insertions, 61 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c new file mode 100644 index 0000000..26372c6 --- /dev/null +++ b/generic/tclAssembly.c @@ -0,0 +1,4176 @@ +/* + * 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; +} + diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d2c506d..f88ea27 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -826,6 +826,13 @@ Tcl_CreateInterp(void) Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); + /* Adding the bytecode assembler command */ + cmdPtr = (Command*) + Tcl_NRCreateCommand(interp, "::tcl::unsupported::assemble", + Tcl_AssembleObjCmd, TclNRAssembleObjCmd, + NULL, NULL); + cmdPtr->compileProc = &TclCompileAssembleCmd; + Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL, TclNRYieldToObjCmd, NULL, NULL); Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL, @@ -3235,28 +3242,29 @@ CancelEvalProc( if (iPtr != NULL) { /* - * Setting this flag will cause the script in progress to be - * canceled as soon as possible. The core honors this flag at all - * the necessary places to ensure script cancellation is + * Setting the CANCELED flag will cause the script in progress to + * be canceled as soon as possible. The core honors this flag at + * all the necessary places to ensure script cancellation is * responsive. Extensions can check for this flag by calling * Tcl_Canceled and checking if TCL_ERROR is returned or they can * choose to ignore the script cancellation flag and the - * associated functionality altogether. + * associated functionality altogether. Currently, the only other + * flag we care about here is the TCL_CANCEL_UNWIND flag (from + * Tcl_CancelEval). We do not want to simply combine all the flags + * from original Tcl_CancelEval call with the interp flags here + * just in case the caller passed flags that might cause behaviour + * unrelated to script cancellation. */ - iPtr->flags |= CANCELED; + TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* - * Currently, we only care about the TCL_CANCEL_UNWIND flag from - * Tcl_CancelEval. We do not want to simply combine all the flags - * from original Tcl_CancelEval call with the interp flags here - * just in case the caller passed flags that might cause behaviour - * unrelated to script cancellation. + * Now, we must set the script cancellation flags on all the slave + * interpreters belonging to this one. */ - if (cancelInfo->flags & TCL_CANCEL_UNWIND) { - iPtr->flags |= TCL_CANCEL_UNWIND; - } + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, + cancelInfo->flags | CANCELED, 0); /* * Create the result object now so that Tcl_Canceled can avoid @@ -3785,7 +3793,15 @@ TclInterpReady( return TCL_ERROR; } - if (iPtr->execEnvPtr->rewind || + if (iPtr->execEnvPtr->rewind) { + return TCL_ERROR; + } + + /* + * Make sure the script being evaluated (if any) has not been canceled. + */ + + if (TclCanceled(iPtr) && (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } @@ -3835,7 +3851,7 @@ TclResetCancellation( } if (force || (iPtr->numLevels == 0)) { - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } return TCL_OK; } @@ -3873,21 +3889,12 @@ Tcl_Canceled( register Interp *iPtr = (Interp *) interp; /* - * Traverse up the to the top-level interp, checking for the CANCELED flag - * along the way. If any of the intervening interps have the CANCELED flag - * set, the current script in progress is considered to be canceled and we - * stop checking. Otherwise, if any interp has the DELETED flag set we - * stop checking. - */ - - for (; iPtr!=NULL; iPtr = (Interp *) Tcl_GetMaster((Tcl_Interp *) iPtr)) { - /* * Has the current script in progress for this interpreter been * canceled or is the stack being unwound due to the previous script * cancellation? */ - if ((iPtr->flags & CANCELED) || (iPtr->flags & TCL_CANCEL_UNWIND)) { + if (TclCanceled(iPtr)) { /* * The CANCELED flag is a one-shot flag that is reset immediately * upon being detected; however, if the TCL_CANCEL_UNWIND flag is @@ -3955,20 +3962,6 @@ Tcl_Canceled( return TCL_ERROR; } - } else { - /* - * FIXME: If this interpreter is being deleted we cannot continue - * to traverse up the interp chain due to an issue with - * Tcl_GetMaster (really the slave interp bookkeeping) that causes - * us to run off into a freed interp struct. Ideally, this check - * would not be necessary because Tcl_GetMaster would return NULL - * instead of a pointer to invalid (freed) memory. - */ - - if (iPtr->flags & DELETED) { - break; - } - } } return TCL_OK; @@ -4365,7 +4358,7 @@ NRCommand( if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); } - if (result == TCL_OK) { + if ((result == TCL_OK) && TclCanceled(iPtr)) { result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); } if (result == TCL_OK && TclLimitReady(iPtr->limit)) { @@ -4494,7 +4487,7 @@ TEOV_Exception( * here directly. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); return result; } @@ -6197,7 +6190,7 @@ TEOEx_ByteCodeCallback( * Let us just unset the flags inline. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } iPtr->evalFlags = 0; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3528bab..807c3e4 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -393,7 +393,7 @@ TclCompileCatchCmd( TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* Stack at this point: ?script? <mark> result TCL_OK */ - /* + /* * Emit the "error case" epilogue. Push the interpreter result * and the return code. */ @@ -479,7 +479,7 @@ TclCompileCatchCmd( TclEmitOpcode(INST_POP, envPtr); } - /* + /* * Result of all this, on either branch, should have been to leave * one operand -- the return code -- on the stack. */ diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 2f86be1..348098b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1863,6 +1863,7 @@ TclCompileThrowCmd( CompileWord(envPtr, msgToken, interp, 2); TclCompileSyntaxError(interp, envPtr); + Tcl_DecrRefCount(objPtr); return TCL_OK; } if (len == 0) { @@ -2586,6 +2587,7 @@ TclCompileUnsetCmd( * evaluation with reasonable effort, so spill to interpreted version. */ + TclDecrRefCount(leadingWord); return TCL_ERROR; } TclDecrRefCount(leadingWord); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8561bd4..d34b364 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1407,7 +1407,6 @@ ExprObjCallback( if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_IncrRefCount(resultPtr); Tcl_SetObjResult(interp, saveObjPtr); } TclDecrRefCount(saveObjPtr); @@ -2053,8 +2052,12 @@ TEBCresume( int traceInstructions; /* Whether we are doing instruction-level * tracing or not. */ #endif -#define LOCAL(i) (&iPtr->varFramePtr->compiledLocals[(i)]) -#define TCONST(i) (iPtr->execEnvPtr->constants[(i)]) + + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; + +#define LOCAL(i) (&compiledLocals[(i)]) +#define TCONST(i) (constants[(i)]) /* * These macros are just meant to save some global variables that are not @@ -2077,10 +2080,6 @@ TEBCresume( * stack. */ const unsigned char *pc; /* The current program counter. */ -#ifdef TCL_COMPILE_DEBUG - traceInstructions = (tclTraceExec == 3); -#endif - /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. @@ -2097,12 +2096,17 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv; - int opnd, objc, length, pcAdjustment; + int objc = 0; + int opnd, length, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; #endif +#ifdef TCL_COMPILE_DEBUG + traceInstructions = (tclTraceExec == 3); +#endif + NR_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG @@ -2277,9 +2281,11 @@ TEBCresume( } } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + if (TclCanceled(iPtr)) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + CACHE_STACK_INFO(); + goto gotError; + } } if (TclLimitReady(iPtr->limit)) { @@ -6300,7 +6306,7 @@ TEBCresume( * already be set prior to vectoring down to this point in the code. */ - if (Tcl_Canceled(interp, 0) == TCL_ERROR) { + if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... cancel with unwind, returning %s\n", diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 61f25d8..d39634e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1002,6 +1002,11 @@ declare 249 { int* decpt, int* signum, char** endPtr) } +# TIP #285: Script cancellation support. +declare 250 { + void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) +} + ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclInt.h b/generic/tclInt.h index f759593..5069ffc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2184,6 +2184,22 @@ typedef struct Interp { *((iPtr)->asyncReadyPtr) /* + * Macros for script cancellation support (TIP #285). + */ + +#define TclCanceled(iPtr) \ + (((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND)) + +#define TclSetCancelFlags(iPtr, cancelFlags) \ + (iPtr)->flags |= CANCELED; \ + if ((cancelFlags) & TCL_CANCEL_UNWIND) { \ + (iPtr)->flags |= TCL_CANCEL_UNWIND; \ + } + +#define TclUnsetCancelFlags(iPtr) \ + (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)) + +/* * General list of interpreters. Doubly linked for easier removal of items * deep in the list. */ @@ -3196,6 +3212,15 @@ MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + +/* Assemble command function */ +MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3688,6 +3713,10 @@ MODULE_SCOPE int TclStreqOpCmd(ClientData clientData, MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); + +MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); /* * Functions defined in generic/tclVar.c and currenttly exported only for use diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index cae5e4e..23f500f 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -600,6 +600,9 @@ EXTERN int TclCopyChannel(Tcl_Interp *interp, /* 249 */ EXTERN char* TclDoubleDigits(double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); +/* 250 */ +EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, + int force); typedef struct TclIntStubs { int magic; @@ -855,6 +858,7 @@ typedef struct TclIntStubs { void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char* (*tclDoubleDigits) (double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); /* 249 */ + void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ } TclIntStubs; #ifdef __cplusplus @@ -1277,6 +1281,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCopyChannel) /* 248 */ #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ +#define TclSetSlaveCancelFlags \ + (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 6ccde87..bfcc383 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2096,6 +2096,72 @@ Tcl_GetMaster( /* *---------------------------------------------------------------------- * + * TclSetSlaveCancelFlags -- + * + * This function marks all slave interpreters belonging to a given + * interpreter as being canceled or not canceled, depending on the + * provided flags. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclSetSlaveCancelFlags( + Tcl_Interp *interp, /* Set cancel flags of this interpreter. */ + int flags, /* Collection of OR-ed bits that control + * the cancellation of the script. Only + * TCL_CANCEL_UNWIND is currently + * supported. */ + int force) /* Non-zero to ignore numLevels for the purpose + * of resetting the cancellation flags. */ +{ + Master *masterPtr; /* Master record of given interpreter. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hashSearch; /* Search variable. */ + Slave *slavePtr; /* Slave record of interpreter. */ + Interp *iPtr; + + if (interp == NULL) { + return; + } + + flags &= (CANCELED | TCL_CANCEL_UNWIND); + + masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master; + + hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + slavePtr = Tcl_GetHashValue(hPtr); + iPtr = (Interp *) slavePtr->slaveInterp; + + if (iPtr == NULL) { + continue; + } + + if (flags == 0) { + TclResetCancellation((Tcl_Interp *) iPtr, force); + } else { + TclSetCancelFlags(iPtr, flags); + } + + /* + * Now, recursively handle this for the slaves of this slave + * interpreter. + */ + + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force); + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list @@ -2717,6 +2783,16 @@ SlaveEval( { int result; + /* + * TIP #285: If necessary, reset the cancellation flags for the slave + * interpreter now; otherwise, canceling a script in a master interpreter + * can result in a situation where a slave interpreter can no longer + * evaluate any scripts unless somebody calls the TclResetCancellation + * function for that particular Tcl_Interp. + */ + + TclSetSlaveCancelFlags(slaveInterp, 0, 0); + Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); diff --git a/generic/tclMain.c b/generic/tclMain.c index 4f992e5..f1a6ce7 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -652,7 +652,7 @@ Tcl_MainEx( Tcl_Release(interp); Tcl_Exit(exitCode); } - + #ifndef UNICODE void Tcl_Main( diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 697570d..161be09 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -24,7 +24,7 @@ * in the generic/tclOO.decls script. */ -#if defined(USE_TCLOO_STUBS) +#if defined(USE_TCL_STUBS) extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp),TCLOO_VERSION) #else diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 98ef9b7..542e604 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -306,6 +306,7 @@ static const TclIntStubs tclIntStubs = { TclResetRewriteEnsemble, /* 247 */ TclCopyChannel, /* 248 */ TclDoubleDigits, /* 249 */ + TclSetSlaveCancelFlags, /* 250 */ }; static const TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 0bd5ca5..4f6bc70 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -219,4 +219,4 @@ declare 61 { } declare 62 { int TclBN_mp_set_int(mp_int* a, unsigned long i) -}
\ No newline at end of file +} diff --git a/generic/tclUtil.c b/generic/tclUtil.c index f746aed..3a42a32 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2268,7 +2268,7 @@ Tcl_PrintDouble( /* * Ordinary (normal and denormal) values. */ - + if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, &exponent, &signum, &end); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index e429b86..dfa58ea 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1229,7 +1229,7 @@ Tcl_ZlibDeflate( if (!interp) { return TCL_ERROR; } - + /* * Compressed format is specified by the wbits parameter. See zlib.h for * details. |