diff options
| -rw-r--r-- | README.opt2 | 13 | ||||
| -rw-r--r-- | generic/tcl.decls | 12 | ||||
| -rw-r--r-- | generic/tclAssembly.c | 4329 | ||||
| -rw-r--r-- | generic/tclBasic.c | 9 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 42 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 502 | ||||
| -rw-r--r-- | generic/tclCompCmdsGR.c | 120 | ||||
| -rw-r--r-- | generic/tclCompCmdsSZ.c | 450 | ||||
| -rw-r--r-- | generic/tclCompExpr.c | 55 | ||||
| -rw-r--r-- | generic/tclCompile.c | 847 | ||||
| -rw-r--r-- | generic/tclCompile.h | 589 | ||||
| -rw-r--r-- | generic/tclDecls.h | 17 | ||||
| -rw-r--r-- | generic/tclDisassemble.c | 60 | ||||
| -rw-r--r-- | generic/tclExecute.c | 948 | ||||
| -rw-r--r-- | generic/tclInt.h | 30 | ||||
| -rw-r--r-- | generic/tclInterp.c | 335 | ||||
| -rw-r--r-- | generic/tclOptimize.c | 1282 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 4 | ||||
| -rw-r--r-- | tests/assemble.test | 3292 | ||||
| -rw-r--r-- | tests/assemble1.bench | 85 | ||||
| -rw-r--r-- | tests/compile.test | 2 | ||||
| -rw-r--r-- | tests/info.test | 46 | ||||
| -rw-r--r-- | tests/interp.test | 253 | ||||
| -rw-r--r-- | unix/Makefile.in | 7 |
24 files changed, 2187 insertions, 11142 deletions
diff --git a/README.opt2 b/README.opt2 new file mode 100644 index 0000000..48b47e8 --- /dev/null +++ b/README.opt2 @@ -0,0 +1,13 @@ +IMPORTANT MODS AND INCOMPATS + +* changes to compiler and engine: old .tbc will not run, except with a + "sufficiently clever" tbcload. The compilefr and tbcload will probably + need some work to adapt to the changes. This branch completely ignores + these issues. + +* tclAssembly.c and related are gone; it was an added burden adapting them + while modifying the bytecodes and tebc, the decision was taken to remove + it and do the work again "at the end" + +* INCOMPATIBILITY - no more cmdCount + There is no more [info cmdcount], or cmdCount based interpreter limits diff --git a/generic/tcl.decls b/generic/tcl.decls index 574b49b..ba49a6d 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1894,9 +1894,9 @@ declare 523 { declare 524 { int Tcl_LimitExceeded(Tcl_Interp *interp) } -declare 525 { - void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit) -} +#declare 525 { +# void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit) +#} declare 526 { void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr) } @@ -1915,9 +1915,9 @@ declare 530 { declare 531 { void Tcl_LimitTypeReset(Tcl_Interp *interp, int type) } -declare 532 { - int Tcl_LimitGetCommands(Tcl_Interp *interp) -} +#declare 532 { +# int Tcl_LimitGetCommands(Tcl_Interp *interp) +#} declare 533 { void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr) } diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c deleted file mode 100644 index 6d5676b..0000000 --- a/generic/tclAssembly.c +++ /dev/null @@ -1,4329 +0,0 @@ -/* - * tclAssembly.c -- - * - * Assembler for Tcl bytecodes. - * - * This file contains the procedures that convert Tcl Assembly Language (TAL) - * to a sequence of bytecode instructions for the Tcl execution engine. - * - * Copyright (c) 2010 by Ozgur Dogan Ugurlu. - * Copyright (c) 2010 by Kevin B. Kenny. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/*- - *- THINGS TO DO: - *- More instructions: - *- done - alternate exit point (affects stack and exception range checking) - *- break and continue - if exception ranges can be sorted out. - *- foreach_start4, foreach_step4 - *- returnImm, returnStk - *- expandStart, expandStkTop, invokeExpanded, expandDrop - *- dictFirst, dictNext, dictDone - *- dictUpdateStart, dictUpdateEnd - *- jumpTable testing - *- syntax (?) - *- returnCodeBranch - *- tclooNext, tclooNextClass - */ - -#include "tclInt.h" -#include "tclCompile.h" -#include "tclOOInt.h" - -/* - * Structure that represents a range of instructions in the bytecode. - */ - -typedef struct CodeRange { - int startOffset; /* Start offset in the bytecode array */ - int endOffset; /* End offset in the bytecode array */ -} CodeRange; - -/* - * State identified for a basic block's catch context. - */ - -typedef enum BasicBlockCatchState { - BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ - BBCS_NONE, /* Block is outside of any catch */ - BBCS_INCATCH, /* Block is within a catch context */ - BBCS_CAUGHT /* Block is within a catch context and - * may be executed after an exception fires */ -} BasicBlockCatchState; - -/* - * Structure that defines a basic block - a linear sequence of bytecode - * instructions with no jumps in or out (including not changing the - * state of any exception range). - */ - -typedef struct BasicBlock { - int originalStartOffset; /* Instruction offset before JUMP1s were - * substituted with JUMP4's */ - int startOffset; /* Instruction offset of the start of the - * block */ - int startLine; /* Line number in the input script of the - * instruction at the start of the block */ - int jumpOffset; /* Bytecode offset of the 'jump' instruction - * that ends the block, or -1 if there is no - * jump. */ - int jumpLine; /* Line number in the input script of the - * 'jump' instruction that ends the block, or - * -1 if there is no jump */ - struct BasicBlock* prevPtr; /* Immediate predecessor of this block */ - struct BasicBlock* predecessor; - /* Predecessor of this block in the spanning - * tree */ - struct BasicBlock* successor1; - /* BasicBlock structure of the following - * block: NULL at the end of the bytecode - * sequence. */ - Tcl_Obj* jumpTarget; /* Jump target label if the jump target is - * unresolved */ - int initialStackDepth; /* Absolute stack depth on entry */ - int minStackDepth; /* Low-water relative stack depth */ - int maxStackDepth; /* High-water relative stack depth */ - int finalStackDepth; /* Relative stack depth on exit */ - enum BasicBlockCatchState catchState; - /* State of the block for 'catch' analysis */ - int catchDepth; /* Number of nested catches in which the basic - * block appears */ - struct BasicBlock* enclosingCatch; - /* BasicBlock structure of the last startCatch - * executed on a path to this block, or NULL - * if there is no enclosing catch */ - int foreignExceptionBase; /* Base index of foreign exceptions */ - int foreignExceptionCount; /* Count of foreign exceptions */ - ExceptionRange* foreignExceptions; - /* ExceptionRange structures for exception - * ranges belonging to embedded scripts and - * expressions in this block */ - JumptableInfo* jtPtr; /* Jump table at the end of this basic block */ - int flags; /* Boolean flags */ -} BasicBlock; - -/* - * Flags that pertain to a basic block. - */ - -enum BasicBlockFlags { - BB_VISITED = (1 << 0), /* Block has been visited in the current - * traversal */ - BB_FALLTHRU = (1 << 1), /* Control may pass from this block to a - * successor */ - BB_JUMP1 = (1 << 2), /* Basic block ends with a 1-byte-offset jump - * and may need expansion */ - BB_JUMPTABLE = (1 << 3), /* Basic block ends with a jump table */ - BB_BEGINCATCH = (1 << 4), /* Block ends with a 'beginCatch' instruction, - * marking it as the start of a 'catch' - * sequence. The 'jumpTarget' is the exception - * exit from the catch block. */ - BB_ENDCATCH = (1 << 5) /* Block ends with an 'endCatch' instruction, - * unwinding the catch from the exception - * stack. */ -}; - -/* - * Source instruction type recognized by the assembler. - */ - -typedef enum TalInstType { - ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */ - ASSEM_BEGIN_CATCH, /* Begin catch: one 4-byte jump offset to be - * converted to appropriate exception - * ranges */ - ASSEM_BOOL, /* One Boolean operand */ - ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */ - ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must - * be strictly positive, consumes N, produces - * 1 */ - ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 - * operands, produces 1, N > 0 */ - ASSEM_DICT_SET, /* specifies key count and LVT index, consumes - * N+1 operands, produces 1, N > 0 */ - ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes - * N operands, produces 1, N > 0 */ - ASSEM_END_CATCH, /* End catch. No args. Exception range popped - * from stack and stack pointer restored. */ - ASSEM_EVAL, /* 'eval' - evaluate a constant script (by - * compiling it in line with the assembly - * code! I love Tcl!) */ - ASSEM_INDEX, /* 4 byte operand, integer or end-integer */ - ASSEM_INVOKE, /* 1- or 4-byte operand count, must be - * strictly positive, consumes N, produces - * 1. */ - ASSEM_JUMP, /* Jump instructions */ - ASSEM_JUMP4, /* Jump instructions forcing a 4-byte offset */ - ASSEM_JUMPTABLE, /* Jumptable (switch -exact) */ - ASSEM_LABEL, /* The assembly directive that defines a - * label */ - ASSEM_LINDEX_MULTI, /* 4-byte operand count, must be strictly - * positive, consumes N, produces 1 */ - ASSEM_LIST, /* 4-byte operand count, must be nonnegative, - * consumses N, produces 1 */ - ASSEM_LSET_FLAT, /* 4-byte operand count, must be >= 3, - * consumes N, produces 1 */ - ASSEM_LVT, /* One operand that references a local - * variable */ - ASSEM_LVT1, /* One 1-byte operand that references a local - * variable */ - ASSEM_LVT1_SINT1, /* One 1-byte operand that references a local - * variable, one signed-integer 1-byte - * operand */ - ASSEM_LVT4, /* One 4-byte operand that references a local - * variable */ - ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1, - * produces N+2 */ - ASSEM_PUSH, /* one literal operand */ - ASSEM_REGEXP, /* One Boolean operand, but weird mapping to - * call flags */ - ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N, - * produces N */ - ASSEM_SINT1, /* One 1-byte signed-integer operand - * (INCR_STK_IMM) */ - ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by - * LVT entry. Fixed arity */ -} TalInstType; - -/* - * Description of an instruction recognized by the assembler. - */ - -typedef struct TalInstDesc { - const char *name; /* Name of instruction. */ - TalInstType instType; /* The type of instruction */ - int tclInstCode; /* Instruction code. For instructions having - * 1- and 4-byte variables, tclInstCode is - * ((1byte)<<8) || (4byte) */ - int operandsConsumed; /* Number of operands consumed by the - * operation, or INT_MIN if the operation is - * variadic */ - int operandsProduced; /* Number of operands produced by the - * operation. If negative, the operation has a - * net stack effect of -1-operandsProduced */ -} TalInstDesc; - -/* - * Structure that holds the state of the assembler while generating code. - */ - -typedef struct AssemblyEnv { - CompileEnv* envPtr; /* Compilation environment being used for code - * generation */ - Tcl_Parse* parsePtr; /* Parse of the current line of source */ - Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose - * values are 'label' objects storing the code - * offsets of the labels. */ - int cmdLine; /* Current line number within the assembly - * code */ - int* clNext; /* Invisible continuation line for - * [info frame] */ - BasicBlock* head_bb; /* First basic block in the code */ - BasicBlock* curr_bb; /* Current basic block */ - int maxDepth; /* Maximum stack depth encountered */ - int curCatchDepth; /* Current depth of catches */ - int maxCatchDepth; /* Maximum depth of catches encountered */ - int flags; /* Compilation flags (TCL_EVAL_DIRECT) */ -} AssemblyEnv; - -/* - * Static functions defined in this file. - */ - -static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*, - BasicBlock*); -static BasicBlock * AllocBB(AssemblyEnv*); -static int AssembleOneLine(AssemblyEnv* envPtr); -static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, - int produced); -static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblIdx, - int count); -static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx, - int opnd, int count); -static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, - int opnd, int count); -static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, - int param, int count); -static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, - int count); -static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); -static int CalculateJumpRelocations(AssemblyEnv*, int*); -static int CheckForUnclosedCatches(AssemblyEnv*); -static int CheckForThrowInWrongContext(AssemblyEnv*); -static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*); -static int BytecodeMightThrow(unsigned char); -static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*); -static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, - int); -static int CheckNonNegative(Tcl_Interp*, int); -static int CheckOneByte(Tcl_Interp*, int); -static int CheckSignedOneByte(Tcl_Interp*, int); -static int CheckStack(AssemblyEnv*); -static int CheckStrictlyPositive(Tcl_Interp*, int); -static ByteCode * CompileAssembleObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, - const TalInstDesc*); -static int DefineLabel(AssemblyEnv* envPtr, const char* label); -static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); -static void DupAssembleCodeInternalRep(Tcl_Obj* src, - Tcl_Obj* dest); -static void FillInJumpOffsets(AssemblyEnv*); -static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, - Tcl_Obj* jumpTable); -static int FindLocalVar(AssemblyEnv* envPtr, - Tcl_Token** tokenPtrPtr); -static int FinishAssembly(AssemblyEnv*); -static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); -static void FreeAssemblyEnv(AssemblyEnv*); -static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); -static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); -static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); -static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); -static void LookForFreshCatches(BasicBlock*, BasicBlock**); -static void MoveCodeForJumps(AssemblyEnv*, int); -static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int, - int); -static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); -static int ProcessCatches(AssemblyEnv*); -static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, - BasicBlock*, enum BasicBlockCatchState, int); -static void ResetVisitedBasicBlocks(AssemblyEnv*); -static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*); -static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*, - Tcl_Obj*); -static void RestoreEmbeddedExceptionRanges(AssemblyEnv*); -static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, - BasicBlock *, int); -static BasicBlock* StartBasicBlock(AssemblyEnv*, int fallthrough, - Tcl_Obj* jumpLabel); -/* static int AdvanceIp(const unsigned char *pc); */ -static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, - BasicBlock *, int); -static int StackCheckExit(AssemblyEnv*); -static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int, - BasicBlock**, int*); -static void SyncStackDepth(AssemblyEnv*); -static int TclAssembleCode(CompileEnv* envPtr, const char* code, - int codeLen, int flags); -static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, - BasicBlock**, int*); - -/* - * Tcl_ObjType that describes bytecode emitted by the assembler. - */ - -static const Tcl_ObjType assembleCodeType = { - "assemblecode", - FreeAssembleCodeInternalRep, /* freeIntRepProc */ - DupAssembleCodeInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; - -/* - * Source instructions recognized in the Tcl Assembly Language (TAL) - */ - -static const TalInstDesc TalInstructionTable[] = { - /* PUSH must be first, see the code near the end of TclAssembleCode */ - {"push", ASSEM_PUSH, (INST_PUSH1<<8 - | INST_PUSH4), 0, 1}, - - {"add", ASSEM_1BYTE, INST_ADD, 2, 1}, - {"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8 - | INST_APPEND_SCALAR4),1, 1}, - {"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8 - | INST_APPEND_ARRAY4), 2, 1}, - {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1}, - {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, - {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1}, - {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1}, - {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0}, - {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0}, - {"beginCatch", ASSEM_BEGIN_CATCH, - INST_BEGIN_CATCH4, 0, 0}, - {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, - {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, - {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, - {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, - {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, - {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, - {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, - {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, - {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, - {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, - {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, - {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, - {"dictIncrImm", ASSEM_SINT4_LVT4, - INST_DICT_INCR_IMM, 1, 1}, - {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, - {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, - {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0}, - {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, - {"dictUnset", ASSEM_DICT_UNSET, - INST_DICT_UNSET, INT_MIN,1}, - {"div", ASSEM_1BYTE, INST_DIV, 2, 1}, - {"dup", ASSEM_1BYTE, INST_DUP, 1, 2}, - {"endCatch", ASSEM_END_CATCH,INST_END_CATCH, 0, 0}, - {"eq", ASSEM_1BYTE, INST_EQ, 2, 1}, - {"eval", ASSEM_EVAL, INST_EVAL_STK, 1, 1}, - {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, - {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1}, - {"existArray", ASSEM_LVT4, INST_EXIST_ARRAY, 1, 1}, - {"existArrayStk", ASSEM_1BYTE, INST_EXIST_ARRAY_STK, 2, 1}, - {"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1}, - {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1}, - {"expr", ASSEM_EVAL, INST_EXPR_STK, 1, 1}, - {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, - {"ge", ASSEM_1BYTE, INST_GE, 2, 1}, - {"gt", ASSEM_1BYTE, INST_GT, 2, 1}, - {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, 1, 1}, - {"incrArray", ASSEM_LVT1, INST_INCR_ARRAY1, 2, 1}, - {"incrArrayImm", ASSEM_LVT1_SINT1, - INST_INCR_ARRAY1_IMM, 1, 1}, - {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1}, - {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, - {"incrImm", ASSEM_LVT1_SINT1, - INST_INCR_SCALAR1_IMM, 0, 1}, - {"incrStk", ASSEM_1BYTE, INST_INCR_STK, 2, 1}, - {"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1}, - {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, - {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, - {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 - | INST_INVOKE_STK4), INT_MIN,1}, - {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, - {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, - {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, - {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, - {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, - {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, - {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, - {"label", ASSEM_LABEL, 0, 0, 0}, - {"land", ASSEM_1BYTE, INST_LAND, 2, 1}, - {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 - | INST_LAPPEND_SCALAR4), - 1, 1}, - {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 - | INST_LAPPEND_ARRAY4),2, 1}, - {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, - {"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1}, - {"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1}, - {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1}, - {"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 1}, - {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, - {"le", ASSEM_1BYTE, INST_LE, 2, 1}, - {"lindexMulti", ASSEM_LINDEX_MULTI, - INST_LIST_INDEX_MULTI, INT_MIN,1}, - {"list", ASSEM_LIST, INST_LIST, INT_MIN,1}, - {"listConcat", ASSEM_1BYTE, INST_LIST_CONCAT, 2, 1}, - {"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1}, - {"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1}, - {"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1}, - {"listLength", ASSEM_1BYTE, INST_LIST_LENGTH, 1, 1}, - {"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1}, - {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8 - | INST_LOAD_SCALAR4), 0, 1}, - {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 - | INST_LOAD_ARRAY4), 1, 1}, - {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, - {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, - {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, - {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, - {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, - {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, - {"lt", ASSEM_1BYTE, INST_LT, 2, 1}, - {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, - {"mult", ASSEM_1BYTE, INST_MULT, 2, 1}, - {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, - {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, - {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, - {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, - {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1}, - {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, - {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, - {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, - {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, - {"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS, - 0, 1}, - {"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1}, - {"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1}, - {"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1}, - {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0}, - {"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1}, - {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8 - | INST_STORE_SCALAR4), 1, 1}, - {"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8 - | INST_STORE_ARRAY4), 2, 1}, - {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, - {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, - {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, - {"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, - {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, - {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, - {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, - {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, - {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, - {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, - {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, - {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, - {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, - {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, - {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, - {"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1}, - {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, - {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1}, - {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, - {"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1}, - {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, - {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, - {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, - {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, - {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, - {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2}, - {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, - {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, - {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, - {"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0}, - {"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0}, - {"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0}, - {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, - {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1}, - {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0}, - {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0}, - {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1}, - {NULL, 0, 0, 0, 0} -}; - -/* - * List of instructions that cannot throw an exception under any - * circumstances. These instructions are the ones that are permissible after - * an exception is caught but before the corresponding exception range is - * popped from the stack. - * The instructions must be in ascending order by numeric operation code. - */ - -static const unsigned char NonThrowingByteCodes[] = { - INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ - INST_JUMP1, INST_JUMP4, /* 34-35 */ - INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ - INST_LIST, /* 79 */ - INST_OVER, /* 95 */ - INST_PUSH_RETURN_OPTIONS, /* 108 */ - INST_REVERSE, /* 126 */ - INST_NOP, /* 132 */ - INST_STR_MAP, /* 143 */ - INST_STR_FIND, /* 144 */ - INST_COROUTINE_NAME, /* 149 */ - INST_NS_CURRENT, /* 151 */ - INST_INFO_LEVEL_NUM, /* 152 */ - INST_RESOLVE_COMMAND, /* 154 */ - INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ - INST_CONCAT_STK, /* 169 */ - INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ - INST_NUM_TYPE /* 180 */ -}; - -/* - * Helper macros. - */ - -#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2 -#define DEBUG_PRINT(...) fprintf(stderr, ##__VA_ARGS__);fflush(stderr) -#elif defined(__GNUC__) && __GNUC__ > 2 -#define DEBUG_PRINT(...) /* nothing */ -#else -#define DEBUG_PRINT /* nothing */ -#endif - -/* - *----------------------------------------------------------------------------- - * - * BBAdjustStackDepth -- - * - * When an opcode is emitted, adjusts the stack information in the basic - * block to reflect the number of operands produced and consumed. - * - * Results: - * None. - * - * Side effects: - * Updates minimum, maximum and final stack requirements in the basic - * block. - * - *----------------------------------------------------------------------------- - */ - -static void -BBAdjustStackDepth( - BasicBlock *bbPtr, /* Structure describing the basic block */ - int consumed, /* Count of operands consumed by the - * operation */ - int produced) /* Count of operands produced by the - * operation */ -{ - int depth = bbPtr->finalStackDepth; - - depth -= consumed; - if (depth < bbPtr->minStackDepth) { - bbPtr->minStackDepth = depth; - } - depth += produced; - if (depth > bbPtr->maxStackDepth) { - bbPtr->maxStackDepth = depth; - } - bbPtr->finalStackDepth = depth; -} - -/* - *----------------------------------------------------------------------------- - * - * BBUpdateStackReqs -- - * - * Updates the stack requirements of a basic block, given the opcode - * being emitted and an operand count. - * - * Results: - * None. - * - * Side effects: - * Updates min, max and final stack requirements in the basic block. - * - * Notes: - * This function must not be called for instructions such as REVERSE and - * OVER that are variadic but do not consume all their operands. Instead, - * BBAdjustStackDepth should be called directly. - * - * count should be provided only for variadic operations. For operations - * with known arity, count should be 0. - * - *----------------------------------------------------------------------------- - */ - -static void -BBUpdateStackReqs( - BasicBlock* bbPtr, /* Structure describing the basic block */ - int tblIdx, /* Index in TalInstructionTable of the - * operation being assembled */ - int count) /* Count of operands for variadic insts */ -{ - int consumed = TalInstructionTable[tblIdx].operandsConsumed; - int produced = TalInstructionTable[tblIdx].operandsProduced; - - if (consumed == INT_MIN) { - /* - * The instruction is variadic; it consumes 'count' operands. - */ - - consumed = count; - } - if (produced < 0) { - /* - * The instruction leaves some of its variadic operands on the stack, - * with net stack effect of '-1-produced' - */ - - produced = consumed - produced - 1; - } - BBAdjustStackDepth(bbPtr, consumed, produced); -} - -/* - *----------------------------------------------------------------------------- - * - * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 -- - * - * Emit the opcode part of an instruction, or the entirety of an - * instruction with a 1- or 4-byte operand, and adjust stack - * requirements. - * - * Results: - * None. - * - * Side effects: - * Stores instruction and operand in the operand stream, and adjusts the - * stack. - * - *----------------------------------------------------------------------------- - */ - -static void -BBEmitOpcode( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Table index in TalInstructionTable of op */ - int count) /* Operand count for variadic ops */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - int op = TalInstructionTable[tblIdx].tclInstCode & 0xff; - - /* - * If this is the first instruction in a basic block, record its line - * number. - */ - - if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) { - bbPtr->startLine = assemEnvPtr->cmdLine; - } - - TclEmitInt1(op, envPtr); - TclUpdateAtCmdStart(op, envPtr); - BBUpdateStackReqs(bbPtr, tblIdx, count); -} - -static void -BBEmitInstInt1( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int opnd, /* 1-byte operand */ - int count) /* Operand count for variadic ops */ -{ - BBEmitOpcode(assemEnvPtr, tblIdx, count); - TclEmitInt1(opnd, assemEnvPtr->envPtr); -} - -static void -BBEmitInstInt4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int opnd, /* 4-byte operand */ - int count) /* Operand count for variadic ops */ -{ - BBEmitOpcode(assemEnvPtr, tblIdx, count); - TclEmitInt4(opnd, assemEnvPtr->envPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * BBEmitInst1or4 -- - * - * Emits a 1- or 4-byte operation according to the magnitude of the - * operand. - * - *----------------------------------------------------------------------------- - */ - -static void -BBEmitInst1or4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int param, /* Variable-length parameter */ - int count) /* Arity if variadic */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - int op = TalInstructionTable[tblIdx].tclInstCode; - - if (param <= 0xff) { - op >>= 8; - } else { - op &= 0xff; - } - TclEmitInt1(op, envPtr); - if (param <= 0xff) { - TclEmitInt1(param, envPtr); - } else { - TclEmitInt4(param, envPtr); - } - TclUpdateAtCmdStart(op, envPtr); - BBUpdateStackReqs(bbPtr, tblIdx, count); -} - -/* - *----------------------------------------------------------------------------- - * - * Tcl_AssembleObjCmd, TclNRAssembleObjCmd -- - * - * Direct evaluation path for tcl::unsupported::assemble - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Assembles the code in objv[1], and executes it, so side effects - * include whatever the code does. - * - *----------------------------------------------------------------------------- - */ - -int -Tcl_AssembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - /* - * Boilerplate - make sure that there is an NRE trampoline on the C stack - * because there needs to be one in place to execute bytecode. - */ - - return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv); -} - -int -TclNRAssembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - ByteCode *codePtr; /* Pointer to the bytecode to execute */ - Tcl_Obj* backtrace; /* Object where extra error information is - * constructed. */ - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); - return TCL_ERROR; - } - - /* - * Assemble the source to bytecode. - */ - - codePtr = CompileAssembleObj(interp, objv[1]); - - /* - * On failure, report error line. - */ - - if (codePtr == NULL) { - Tcl_AddErrorInfo(interp, "\n (\""); - Tcl_AppendObjToErrorInfo(interp, objv[0]); - Tcl_AddErrorInfo(interp, "\" body, line "); - backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp)); - Tcl_AppendObjToErrorInfo(interp, backtrace); - Tcl_AddErrorInfo(interp, ")"); - return TCL_ERROR; - } - - /* - * Use NRE to evaluate the bytecode from the trampoline. - */ - - return TclNRExecuteByteCode(interp, codePtr); -} - -/* - *----------------------------------------------------------------------------- - * - * CompileAssembleObj -- - * - * Sets up and assembles Tcl bytecode for the direct-execution path in - * the Tcl bytecode assembler. - * - * Results: - * Returns a pointer to the assembled code. Returns NULL if the assembly - * fails for any reason, with an appropriate error message in the - * interpreter. - * - *----------------------------------------------------------------------------- - */ - -static ByteCode * -CompileAssembleObj( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *objPtr) /* Source code to assemble */ -{ - Interp *iPtr = (Interp *) interp; - /* Internals of the interpreter */ - CompileEnv compEnv; /* Compilation environment structure */ - register ByteCode *codePtr = NULL; - /* Bytecode resulting from the assembly */ - Namespace* namespacePtr; /* Namespace in which variable and command - * names in the bytecode resolve */ - int status; /* Status return from Tcl_AssembleCode */ - const char* source; /* String representation of the source code */ - int sourceLen; /* Length of the source code in bytes */ - - - /* - * Get the expression ByteCode from the object. If it exists, make sure it - * is valid in the current context. - */ - - if (objPtr->typePtr == &assembleCodeType) { - namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; - if (((Interp *) *codePtr->interpHandle == iPtr) - && (codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsPtr == namespacePtr) - && (codePtr->nsEpoch == namespacePtr->resolverEpoch) - && (codePtr->localCachePtr - == iPtr->varFramePtr->localCachePtr)) { - return codePtr; - } - - /* - * Not valid, so free it and regenerate. - */ - - FreeAssembleCodeInternalRep(objPtr); - } - - /* - * Set up the compilation environment, and assemble the code. - */ - - source = TclGetStringFromObj(objPtr, &sourceLen); - TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0); - status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT); - if (status != TCL_OK) { - /* - * Assembly failed. Clean up and report the error. - */ - TclFreeCompileEnv(&compEnv); - return NULL; - } - - /* - * Add a "done" instruction as the last instruction and change the object - * into a ByteCode object. Ownership of the literal objects and aux data - * items is given to the ByteCode object. - */ - - TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &assembleCodeType; - TclFreeCompileEnv(&compEnv); - - /* - * Record the local variable context to which the bytecode pertains - */ - - codePtr = objPtr->internalRep.twoPtrValue.ptr1; - if (iPtr->varFramePtr->localCachePtr) { - codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; - codePtr->localCachePtr->refCount++; - } - - /* - * Report on what the assembler did. - */ - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - - return codePtr; -} - -/* - *----------------------------------------------------------------------------- - * - * TclCompileAssembleCmd -- - * - * Compilation procedure for the '::tcl::unsupported::assemble' command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Puts the result of assembling the code into the bytecode stream in - * 'compileEnv'. - * - * This procedure makes sure that the command has a single arg, which is - * constant. If that condition is met, the procedure calls TclAssembleCode to - * produce bytecode for the given assembly code, and returns any error - * resulting from the assembly. - * - *----------------------------------------------------------------------------- - */ - -int -TclCompileAssembleCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; /* Token in the input script */ - - int numCommands = envPtr->numCommands; - int offset = envPtr->codeNext - envPtr->codeStart; - int depth = envPtr->currStackDepth; - - /* - * Make sure that the command has a single arg that is a simple word. - */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - /* - * Compile the code and convert any error from the compilation into - * bytecode reporting the error; - */ - - if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, - tokenPtr[1].size, TCL_EVAL_DIRECT)) { - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"%.*s\" body, line %d)", - parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, - Tcl_GetErrorLine(interp))); - envPtr->numCommands = numCommands; - envPtr->codeNext = envPtr->codeStart + offset; - envPtr->currStackDepth = depth; - TclCompileSyntaxError(interp, envPtr); - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * TclAssembleCode -- - * - * Take a list of instructions in a Tcl_Obj, and assemble them to Tcl - * bytecodes - * - * Results: - * Returns TCL_OK on success, TCL_ERROR on failure. If 'flags' includes - * TCL_EVAL_DIRECT, places an error message in the interpreter result. - * - * Side effects: - * Adds byte codes to the compile environment, and updates the - * environment's stack depth. - * - *----------------------------------------------------------------------------- - */ - -static int -TclAssembleCode( - CompileEnv *envPtr, /* Compilation environment that is to receive - * the generated bytecode */ - const char* codePtr, /* Assembly-language code to be processed */ - int codeLen, /* Length of the code */ - int flags) /* OR'ed combination of flags */ -{ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - /* - * Walk through the assembly script using the Tcl parser. Each 'command' - * will be an instruction or assembly directive. - */ - - const char* instPtr = codePtr; - /* Where to start looking for a line of code */ - const char* nextPtr; /* Pointer to the end of the line of code */ - int bytesLeft = codeLen; /* Number of bytes of source code remaining to - * be parsed */ - int status; /* Tcl status return */ - AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags); - Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; - - do { - /* - * Parse out one command line from the assembly script. - */ - - status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); - - /* - * Report errors in the parse. - */ - - if (status != TCL_OK) { - if (flags & TCL_EVAL_DIRECT) { - Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - } - FreeAssemblyEnv(assemEnvPtr); - return TCL_ERROR; - } - - /* - * Advance the pointers around any leading commentary. - */ - - TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr, - parsePtr->commandStart); - TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, - parsePtr->commandStart - envPtr->source); - - /* - * Process the line of code. - */ - - if (parsePtr->numWords > 0) { - int instLen = parsePtr->commandSize; - /* Length in bytes of the current command */ - - if (parsePtr->term == parsePtr->commandStart + instLen - 1) { - --instLen; - } - - /* - * If tracing, show each line assembled as it happens. - */ - -#ifdef TCL_COMPILE_DEBUG - if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { - printf(" %4ld Assembling: ", - (long)(envPtr->codeNext - envPtr->codeStart)); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(instLen, 55)); - printf("\n"); - } -#endif - if (AssembleOneLine(assemEnvPtr) != TCL_OK) { - if (flags & TCL_EVAL_DIRECT) { - Tcl_LogCommandInfo(interp, codePtr, - parsePtr->commandStart, instLen); - } - Tcl_FreeParse(parsePtr); - FreeAssemblyEnv(assemEnvPtr); - return TCL_ERROR; - } - } - - /* - * Advance to the next line of code. - */ - - nextPtr = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= (nextPtr - instPtr); - instPtr = nextPtr; - TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart, - instPtr); - TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext, - instPtr - envPtr->source); - Tcl_FreeParse(parsePtr); - } while (bytesLeft > 0); - - /* - * Done with parsing the code. - */ - - status = FinishAssembly(assemEnvPtr); - FreeAssemblyEnv(assemEnvPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * NewAssemblyEnv -- - * - * Creates an environment for the assembler to run in. - * - * Results: - * Allocates, initialises and returns an assembler environment - * - *----------------------------------------------------------------------------- - */ - -static AssemblyEnv* -NewAssemblyEnv( - CompileEnv* envPtr, /* Compilation environment being used for code - * generation*/ - int flags) /* Compilation flags (TCL_EVAL_DIRECT) */ -{ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv)); - /* Assembler environment under construction */ - Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); - /* Parse of one line of assembly code */ - - assemEnvPtr->envPtr = envPtr; - assemEnvPtr->parsePtr = parsePtr; - assemEnvPtr->cmdLine = 1; - assemEnvPtr->clNext = envPtr->clNext; - - /* - * Make the hashtables that store symbol resolution. - */ - - Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS); - - /* - * Start the first basic block. - */ - - assemEnvPtr->curr_bb = NULL; - assemEnvPtr->head_bb = AllocBB(assemEnvPtr); - assemEnvPtr->curr_bb = assemEnvPtr->head_bb; - assemEnvPtr->head_bb->startLine = 1; - - /* - * Stash compilation flags. - */ - - assemEnvPtr->flags = flags; - return assemEnvPtr; -} - -/* - *----------------------------------------------------------------------------- - * - * FreeAssemblyEnv -- - * - * Cleans up the assembler environment when assembly is complete. - * - *----------------------------------------------------------------------------- - */ - -static void -FreeAssemblyEnv( - AssemblyEnv* assemEnvPtr) /* Environment to free */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment being used for code - * generation */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* thisBB; /* Pointer to a basic block being deleted */ - BasicBlock* nextBB; /* Pointer to a deleted basic block's - * successor */ - - /* - * Free all the basic block structures. - */ - - for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) { - if (thisBB->jumpTarget != NULL) { - Tcl_DecrRefCount(thisBB->jumpTarget); - } - if (thisBB->foreignExceptions != NULL) { - ckfree(thisBB->foreignExceptions); - } - nextBB = thisBB->successor1; - if (thisBB->jtPtr != NULL) { - DeleteMirrorJumpTable(thisBB->jtPtr); - thisBB->jtPtr = NULL; - } - ckfree(thisBB); - } - - /* - * Dispose what's left. - */ - - Tcl_DeleteHashTable(&assemEnvPtr->labelHash); - TclStackFree(interp, assemEnvPtr->parsePtr); - TclStackFree(interp, assemEnvPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * AssembleOneLine -- - * - * Assembles a single command from an assembly language source. - * - * Results: - * Returns TCL_ERROR with an appropriate error message if the assembly - * fails. Returns TCL_OK if the assembly succeeds. Updates the assembly - * environment with the state of the assembly. - * - *----------------------------------------------------------------------------- - */ - -static int -AssembleOneLine( - AssemblyEnv* assemEnvPtr) /* State of the assembly */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment being used for code - * gen */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Parse* parsePtr = assemEnvPtr->parsePtr; - /* Parse of the line of code */ - Tcl_Token* tokenPtr; /* Current token within the line of code */ - Tcl_Obj* instNameObj; /* Name of the instruction */ - int tblIdx; /* Index in TalInstructionTable of the - * instruction */ - enum TalInstType instType; /* Type of the instruction */ - Tcl_Obj* operand1Obj = NULL; - /* First operand to the instruction */ - const char* operand1; /* String rep of the operand */ - int operand1Len; /* String length of the operand */ - int opnd; /* Integer representation of an operand */ - int litIndex; /* Literal pool index of a constant */ - int localVar; /* LVT index of a local variable */ - int flags; /* Flags for a basic block */ - JumptableInfo* jtPtr; /* Pointer to a jumptable */ - int infoIndex; /* Index of the jumptable in auxdata */ - int status = TCL_ERROR; /* Return value from this function */ - - /* - * Make sure that the instruction name is known at compile time. - */ - - tokenPtr = parsePtr->tokenPtr; - if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Look up the instruction name. - */ - - if (Tcl_GetIndexFromObjStruct(interp, instNameObj, - &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction", - TCL_EXACT, &tblIdx) != TCL_OK) { - goto cleanup; - } - - /* - * Vector on the type of instruction being processed. - */ - - instType = TalInstructionTable[tblIdx].instType; - switch (instType) { - - case ASSEM_PUSH: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "value"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); - BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); - break; - - case ASSEM_1BYTE: - if (parsePtr->numWords != 1) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); - goto cleanup; - } - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - break; - - case ASSEM_BEGIN_CATCH: - /* - * Emit the BEGIN_CATCH instruction with the code offset of the - * exception branch target instead of the exception range index. The - * correct index will be generated and inserted later, when catches - * are being resolved. - */ - - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); - assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH; - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj); - break; - - case ASSEM_BOOL: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); - goto cleanup; - } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - break; - - case ASSEM_BOOL_LVT4: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); - goto cleanup; - } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_CONCAT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckOneByte(interp, opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_DICT_GET: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - break; - - case ASSEM_DICT_SET: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_DICT_UNSET: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - TclEmitInt4(localVar, envPtr); - break; - - case ASSEM_END_CATCH: - if (parsePtr->numWords != 1) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, ""); - goto cleanup; - } - assemEnvPtr->curr_bb->flags |= BB_ENDCATCH; - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - break; - - case ASSEM_EVAL: - /* TODO - Refactor this stuff into a subroutine that takes the inst - * code, the message ("script" or "expression") and an evaluator - * callback that calls TclCompileScript or TclCompileExpr. */ - - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, - ((TalInstructionTable[tblIdx].tclInstCode - == INST_EVAL_STK) ? "script" : "expression")); - goto cleanup; - } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - CompileEmbeddedScript(assemEnvPtr, tokenPtr+1, - TalInstructionTable+tblIdx); - } else if (GetNextOperand(assemEnvPtr, &tokenPtr, - &operand1Obj) != TCL_OK) { - goto cleanup; - } else { - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); - - /* - * Assumes that PUSH is the first slot! - */ - - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); - BBEmitOpcode(assemEnvPtr, tblIdx, 0); - } - break; - - case ASSEM_INVOKE: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - - BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_JUMP: - case ASSEM_JUMP4: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - if (instType == ASSEM_JUMP) { - flags = BB_JUMP1; - BBEmitInstInt1(assemEnvPtr, tblIdx, 0, 0); - } else { - flags = 0; - BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); - } - - /* - * Start a new basic block at the instruction following the jump. - */ - - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - if (TalInstructionTable[tblIdx].operandsConsumed != 0) { - flags |= BB_FALLTHRU; - } - StartBasicBlock(assemEnvPtr, flags, operand1Obj); - break; - - case ASSEM_JUMPTABLE: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - - jtPtr = ckalloc(sizeof(JumptableInfo)); - - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", - assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, - envPtr->codeNext - envPtr->codeStart); - - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - DEBUG_PRINT("auxdata index=%d\n", infoIndex); - - BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); - if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) { - goto cleanup; - } - StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL); - break; - - case ASSEM_LABEL: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "name"); - goto cleanup; - } - if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { - goto cleanup; - } - - /* - * Add the (label_name, address) pair to the hash table. - */ - - if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { - goto cleanup; - } - break; - - case ASSEM_LINDEX_MULTI: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckStrictlyPositive(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LIST: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_INDEX: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LSET_FLAT: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - if (opnd < 2) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("operand must be >=2", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL); - } - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_LVT: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_LVT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar)) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_LVT1_SINT1: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar) - || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckSignedOneByte(interp, opnd)) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); - TclEmitInt1(opnd, envPtr); - break; - - case ASSEM_LVT4: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_OVER: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1); - break; - - case ASSEM_REGEXP: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean"); - goto cleanup; - } - if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - { - int flags = TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0); - - BBEmitInstInt1(assemEnvPtr, tblIdx, flags, 0); - } - break; - - case ASSEM_REVERSE: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckNonNegative(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); - break; - - case ASSEM_SINT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK - || CheckSignedOneByte(interp, opnd) != TCL_OK) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); - break; - - case ASSEM_SINT4_LVT4: - if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); - goto cleanup; - } - if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0); - TclEmitInt4(localVar, envPtr); - break; - - default: - Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - Tcl_GetString(instNameObj)); - } - - status = TCL_OK; - cleanup: - Tcl_DecrRefCount(instNameObj); - if (operand1Obj) { - Tcl_DecrRefCount(operand1Obj); - } - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * CompileEmbeddedScript -- - * - * Compile an embedded 'eval' or 'expr' that appears in assembly code. - * - * This procedure is called when the 'eval' or 'expr' assembly directive is - * encountered, and the argument to the directive is a simple word that - * requires no substitution. The appropriate compiler (TclCompileScript or - * TclCompileExpr) is invoked recursively, and emits bytecode. - * - * Before the compiler is invoked, the compilation environment's stack - * consumption is reset to zero. Upon return from the compilation, the net - * stack effect of the compilation is in the compiler env, and this stack - * effect is posted to the assembler environment. The compile environment's - * stack consumption is then restored to what it was before (which is actually - * the state of the stack on entry to the block of assembly code). - * - * Any exception ranges pushed by the compilation are copied to the basic - * block and removed from the compiler environment. They will be rebuilt at - * the end of assembly, when the exception stack depth is actually known. - * - *----------------------------------------------------------------------------- - */ - -static void -CompileEmbeddedScript( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token* tokenPtr, /* Tcl_Token containing the script */ - const TalInstDesc* instPtr) /* Instruction that determines whether - * the script is 'expr' or 'eval' */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - /* - * The expression or script is not only known at compile time, but - * actually a "simple word". It can be compiled inline by invoking the - * compiler recursively. - * - * Save away the stack depth and reset it before compiling the script. - * We'll record the stack usage of the script in the BasicBlock, and - * accumulate it together with the stack usage of the enclosing assembly - * code. - */ - - int savedStackDepth = envPtr->currStackDepth; - int savedMaxStackDepth = envPtr->maxStackDepth; - int savedCodeIndex = envPtr->codeNext - envPtr->codeStart; - int savedExceptArrayNext = envPtr->exceptArrayNext; - - envPtr->currStackDepth = 0; - envPtr->maxStackDepth = 0; - - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - switch(instPtr->tclInstCode) { - case INST_EVAL_STK: - TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); - break; - case INST_EXPR_STK: - TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1); - break; - default: - Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen", - instPtr->name, instPtr->tclInstCode); - } - - /* - * Roll up the stack usage of the embedded block into the assembler - * environment. - */ - - SyncStackDepth(assemEnvPtr); - envPtr->currStackDepth = savedStackDepth; - envPtr->maxStackDepth = savedMaxStackDepth; - - /* - * Save any exception ranges that were pushed by the compiler; they will - * need to be fixed up once the stack depth is known. - */ - - MoveExceptionRangesToBasicBlock(assemEnvPtr, savedCodeIndex, - savedExceptArrayNext); - - /* - * Flush the current basic block. - */ - - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); -} - -/* - *----------------------------------------------------------------------------- - * - * SyncStackDepth -- - * - * Copies the stack depth from the compile environment to a basic block. - * - * Side effects: - * Current and max stack depth in the current basic block are adjusted. - * - * This procedure is called on return from invoking the compiler for the - * 'eval' and 'expr' operations. It adjusts the stack depth of the current - * basic block to reflect the stack required by the just-compiled code. - * - *----------------------------------------------------------------------------- - */ - -static void -SyncStackDepth( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* curr_bb = assemEnvPtr->curr_bb; - /* Current basic block */ - int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth; - /* Max stack depth in the basic block */ - - if (maxStackDepth > curr_bb->maxStackDepth) { - curr_bb->maxStackDepth = maxStackDepth; - } - curr_bb->finalStackDepth += envPtr->currStackDepth; -} - -/* - *----------------------------------------------------------------------------- - * - * MoveExceptionRangesToBasicBlock -- - * - * Removes exception ranges that were created by compiling an embedded - * script from the CompileEnv, and stores them in the BasicBlock. They - * will be reinstalled, at the correct stack depth, after control flow - * analysis is complete on the assembly code. - * - *----------------------------------------------------------------------------- - */ - -static void -MoveExceptionRangesToBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int savedCodeIndex, /* Start of the embedded code */ - int savedExceptArrayNext) /* Saved index of the end of the exception - * range array */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* curr_bb = assemEnvPtr->curr_bb; - /* Current basic block */ - int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext; - /* Number of ranges that must be moved */ - int i; - - if (exceptionCount == 0) { - /* Nothing to do */ - return; - } - - /* - * Save the exception ranges in the basic block. They will be re-added at - * the conclusion of assembly; at this time, the INST_BEGIN_CATCH - * instructions in the block will be adjusted from whatever range indices - * they have [savedExceptArrayNext .. envPtr->exceptArrayNext) to the - * indices that the exceptions acquire. The saved exception ranges are - * converted to a relative nesting depth. The depth will be recomputed - * once flow analysis has determined the actual stack depth of the block. - */ - - DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n", - curr_bb, exceptionCount, savedExceptArrayNext); - curr_bb->foreignExceptionBase = savedExceptArrayNext; - curr_bb->foreignExceptionCount = exceptionCount; - curr_bb->foreignExceptions = - ckalloc(exceptionCount * sizeof(ExceptionRange)); - memcpy(curr_bb->foreignExceptions, - envPtr->exceptArrayPtr + savedExceptArrayNext, - exceptionCount * sizeof(ExceptionRange)); - for (i = 0; i < exceptionCount; ++i) { - curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth; - } - envPtr->exceptArrayNext = savedExceptArrayNext; -} - -/* - *----------------------------------------------------------------------------- - * - * CreateMirrorJumpTable -- - * - * Makes a jump table with comparison values and assembly code labels. - * - * Results: - * Returns a standard Tcl status, with an error message in the - * interpreter on error. - * - * Side effects: - * Initializes the jump table pointer in the current basic block to a - * JumptableInfo. The keys in the JumptableInfo are the comparison - * strings. The values, instead of being jump displacements, are - * Tcl_Obj's with the code labels. - */ - -static int -CreateMirrorJumpTable( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Obj* jumps) /* List of alternating keywords and labels */ -{ - int objc; /* Number of elements in the 'jumps' list */ - Tcl_Obj** objv; /* Pointers to the elements in the list */ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - JumptableInfo* jtPtr; - Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */ - Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ - int isNew; /* Flag==1 if the key is not yet in the - * table. */ - int i; - - if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { - return TCL_ERROR; - } - if (objc % 2 != 0) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "jump table must have an even number of list elements", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL); - } - return TCL_ERROR; - } - - /* - * Allocate the jumptable. - */ - - jtPtr = ckalloc(sizeof(JumptableInfo)); - jtHashPtr = &jtPtr->hashTable; - Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); - - /* - * Fill the keys and labels into the table. - */ - - DEBUG_PRINT("jump table {\n"); - for (i = 0; i < objc; i+=2) { - DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]), - Tcl_GetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), - &isNew); - if (!isNew) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "duplicate entry in jump table for \"%s\"", - Tcl_GetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); - DeleteMirrorJumpTable(jtPtr); - return TCL_ERROR; - } - } - Tcl_SetHashValue(hashEntry, objv[i+1]); - Tcl_IncrRefCount(objv[i+1]); - } - DEBUG_PRINT("}\n"); - - /* - * Put the mirror jumptable in the basic block struct. - */ - - bbPtr->jtPtr = jtPtr; - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DeleteMirrorJumpTable -- - * - * Cleans up a jump table when the basic block is deleted. - * - *----------------------------------------------------------------------------- - */ - -static void -DeleteMirrorJumpTable( - JumptableInfo* jtPtr) -{ - Tcl_HashTable* jtHashPtr = &jtPtr->hashTable; - /* Hash table pointer */ - Tcl_HashSearch search; /* Hash search control */ - Tcl_HashEntry* entry; /* Hash table entry containing a jump label */ - Tcl_Obj* label; /* Jump label from the hash table */ - - for (entry = Tcl_FirstHashEntry(jtHashPtr, &search); - entry != NULL; - entry = Tcl_NextHashEntry(&search)) { - label = Tcl_GetHashValue(entry); - Tcl_DecrRefCount(label); - Tcl_SetHashValue(entry, NULL); - } - Tcl_DeleteHashTable(jtHashPtr); - ckfree(jtPtr); -} - -/* - *----------------------------------------------------------------------------- - * - * GetNextOperand -- - * - * Retrieves the next operand in sequence from an assembly instruction, - * and makes sure that its value is known at compile time. - * - * Results: - * If successful, returns TCL_OK and leaves a Tcl_Obj with the operand - * text in *operandObjPtr. In case of failure, returns TCL_ERROR and - * leaves *operandObjPtr untouched. - * - * Side effects: - * Advances *tokenPtrPtr around the token just processed. - * - *----------------------------------------------------------------------------- - */ - -static int -GetNextOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* INPUT/OUTPUT: Pointer to the token holding - * the operand */ - Tcl_Obj** operandObjPtr) /* OUTPUT: Tcl object holding the operand text - * with \-substitutions done. */ -{ - Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr; - Tcl_Obj* operandObj = Tcl_NewObj(); - - if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) { - Tcl_DecrRefCount(operandObj); - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "assembly code may not contain substitutions", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL); - } - return TCL_ERROR; - } - *tokenPtrPtr = TokenAfter(*tokenPtrPtr); - Tcl_IncrRefCount(operandObj); - *operandObjPtr = operandObj; - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * GetBooleanOperand -- - * - * Retrieves a Boolean operand from the input stream and advances - * the token pointer. - * - * Results: - * Returns a standard Tcl result (with an error message in the - * interpreter on failure). - * - * Side effects: - * Stores the Boolean value in (*result) and advances (*tokenPtrPtr) - * to the next token. - * - *----------------------------------------------------------------------------- - */ - -static int -GetBooleanOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token in the - * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Convert to an integer, advance to the next token and return. - */ - - status = Tcl_GetBooleanFromObj(interp, intObj, result); - Tcl_DecrRefCount(intObj); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * GetIntegerOperand -- - * - * Retrieves an integer operand from the input stream and advances the - * token pointer. - * - * Results: - * Returns a standard Tcl result (with an error message in the - * interpreter on failure). - * - * Side effects: - * Stores the integer value in (*result) and advances (*tokenPtrPtr) to - * the next token. - * - *----------------------------------------------------------------------------- - */ - -static int -GetIntegerOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token in the - * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Convert to an integer, advance to the next token and return. - */ - - status = Tcl_GetIntFromObj(interp, intObj, result); - Tcl_DecrRefCount(intObj); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * GetListIndexOperand -- - * - * Gets the value of an operand intended to serve as a list index. - * - * Results: - * Returns a standard Tcl result: TCL_OK if the parse is successful and - * TCL_ERROR (with an appropriate error message) if the parse fails. - * - * Side effects: - * Stores the list index at '*index'. Values between -1 and 0x7fffffff - * have their natural meaning; values between -2 and -0x80000000 - * represent 'end-2-N'. - * - *----------------------------------------------------------------------------- - */ - -static int -GetListIndexOperand( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: Integer extracted from the token */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token in the - * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Convert to an integer, advance to the next token and return. - */ - - status = TclGetIntForIndex(interp, intObj, -2, result); - Tcl_DecrRefCount(intObj); - *tokenPtrPtr = TokenAfter(tokenPtr); - return status; -} - -/* - *----------------------------------------------------------------------------- - * - * FindLocalVar -- - * - * Gets the name of a local variable from the input stream and advances - * the token pointer. - * - * Results: - * Returns the LVT index of the local variable. Returns -1 if the - * variable is non-local, not known at compile time, or cannot be - * installed in the LVT (leaving an error message in the interpreter - * result if necessary). - * - * Side effects: - * Advances the token pointer. May define a new LVT slot if the variable - * has not yet been seen and the execution context allows for it. - * - *----------------------------------------------------------------------------- - */ - -static int -FindLocalVar( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Token** tokenPtrPtr) -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Token* tokenPtr = *tokenPtrPtr; - /* INOUT: Pointer to the next token in the - * source code. */ - Tcl_Obj* varNameObj; /* Name of the variable */ - const char* varNameStr; - int varNameLen; - int localVar; /* Index of the variable in the LVT */ - - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { - return -1; - } - varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); - if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { - Tcl_DecrRefCount(varNameObj); - return -1; - } - localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); - Tcl_DecrRefCount(varNameObj); - if (localVar == -1) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot use this instruction to create a variable" - " in a non-proc context", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); - } - return -1; - } - *tokenPtrPtr = TokenAfter(tokenPtr); - return localVar; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNamespaceQualifiers -- - * - * Verify that a variable name has no namespace qualifiers before - * attempting to install it in the LVT. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNamespaceQualifiers( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - const char* name, /* Variable name to check */ - int nameLen) /* Length of the variable */ -{ - const char* p; - - for (p = name; p+2 < name+nameLen; p++) { - if ((*p == ':') && (p[1] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "variable \"%s\" is not local", name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL); - return TCL_ERROR; - } - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckOneByte -- - * - * Verify that a constant fits in a single byte in the instruction - * stream. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_SCALAR1 - * are possible on a given local variable. The fact that there is no - * INCR_SCALAR4 is puzzling. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckOneByte( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value < 0 || value > 0xff) { - result = Tcl_NewStringObj("operand does not fit in one byte", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckSignedOneByte -- - * - * Verify that a constant fits in a single signed byte in the instruction - * stream. - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_SCALAR1 - * are possible on a given local variable. The fact that there is no - * INCR_SCALAR4 is puzzling. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckSignedOneByte( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value > 0x7f || value < -0x80) { - result = Tcl_NewStringObj("operand does not fit in one byte", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNonNegative -- - * - * Verify that a constant is nonnegative - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores - * an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_INVOKE - * are consuming a positive number of operands - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNonNegative( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value < 0) { - result = Tcl_NewStringObj("operand must be nonnegative", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckStrictlyPositive -- - * - * Verify that a constant is positive - * - * Results: - * On success, returns TCL_OK. On failure, returns TCL_ERROR and - * stores an error message in the interpreter result. - * - * This code is here primarily to verify that instructions like INCR_INVOKE - * are consuming a positive number of operands - * - *----------------------------------------------------------------------------- - */ - -static int -CheckStrictlyPositive( - Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ -{ - Tcl_Obj* result; /* Error message */ - - if (value <= 0) { - result = Tcl_NewStringObj("operand must be positive", -1); - Tcl_SetObjResult(interp, result); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * DefineLabel -- - * - * Defines a label appearing in the assembly sequence. - * - * Results: - * Returns a standard Tcl result. Returns TCL_OK and an empty result if - * the definition succeeds; returns TCL_ERROR and an appropriate message - * if a duplicate definition is found. - * - *----------------------------------------------------------------------------- - */ - -static int -DefineLabel( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - const char* labelName) /* Label being defined */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_HashEntry* entry; /* Label's entry in the symbol table */ - int isNew; /* Flag == 1 iff the label was previously - * undefined */ - - /* TODO - This can now be simplified! */ - - StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - - /* - * Look up the newly-defined label in the symbol table. - */ - - entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew); - if (!isNew) { - /* - * This is a duplicate label. - */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "duplicate definition of label \"%s\"", labelName)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName, - NULL); - } - return TCL_ERROR; - } - - /* - * This is the first appearance of the label in the code. - */ - - Tcl_SetHashValue(entry, assemEnvPtr->curr_bb); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * StartBasicBlock -- - * - * Starts a new basic block when a label or jump is encountered. - * - * Results: - * Returns a pointer to the BasicBlock structure of the new - * basic block. - * - *----------------------------------------------------------------------------- - */ - -static BasicBlock* -StartBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int flags, /* Flags to apply to the basic block being - * closed, if there is one. */ - Tcl_Obj* jumpLabel) /* Label of the location that the block jumps - * to, or NULL if the block does not jump */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* newBB; /* BasicBlock structure for the new block */ - BasicBlock* currBB = assemEnvPtr->curr_bb; - - /* - * Coalesce zero-length blocks. - */ - - if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) { - currBB->startLine = assemEnvPtr->cmdLine; - return currBB; - } - - /* - * Make the new basic block. - */ - - newBB = AllocBB(assemEnvPtr); - - /* - * Record the jump target if there is one. - */ - - currBB->jumpTarget = jumpLabel; - if (jumpLabel != NULL) { - Tcl_IncrRefCount(currBB->jumpTarget); - } - - /* - * Record the fallthrough if there is one. - */ - - currBB->flags |= flags; - - /* - * Record the successor block. - */ - - currBB->successor1 = newBB; - assemEnvPtr->curr_bb = newBB; - return newBB; -} - -/* - *----------------------------------------------------------------------------- - * - * AllocBB -- - * - * Allocates a new basic block - * - * Results: - * Returns a pointer to the newly allocated block, which is initialized - * to contain no code and begin at the current instruction pointer. - * - *----------------------------------------------------------------------------- - */ - -static BasicBlock * -AllocBB( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - BasicBlock *bb = ckalloc(sizeof(BasicBlock)); - - bb->originalStartOffset = - bb->startOffset = envPtr->codeNext - envPtr->codeStart; - bb->startLine = assemEnvPtr->cmdLine + 1; - bb->jumpOffset = -1; - bb->jumpLine = -1; - bb->prevPtr = assemEnvPtr->curr_bb; - bb->predecessor = NULL; - bb->successor1 = NULL; - bb->jumpTarget = NULL; - bb->initialStackDepth = 0; - bb->minStackDepth = 0; - bb->maxStackDepth = 0; - bb->finalStackDepth = 0; - bb->catchDepth = 0; - bb->enclosingCatch = NULL; - bb->foreignExceptionBase = -1; - bb->foreignExceptionCount = 0; - bb->foreignExceptions = NULL; - bb->jtPtr = NULL; - bb->flags = 0; - - return bb; -} - -/* - *----------------------------------------------------------------------------- - * - * FinishAssembly -- - * - * Postprocessing after all bytecode has been generated for a block of - * assembly code. - * - * Results: - * Returns a standard Tcl result, with an error message left in the - * interpreter if appropriate. - * - * Side effects: - * The program is checked to see if any undefined labels remain. The - * initial stack depth of all the basic blocks in the flow graph is - * calculated and saved. The stack balance on exit is computed, checked - * and saved. - * - *----------------------------------------------------------------------------- - */ - -static int -FinishAssembly( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - int mustMove; /* Amount by which the code needs to be grown - * because of expanding jumps */ - - /* - * Resolve the targets of all jumps and determine whether code needs to be - * moved around. - */ - - if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) { - return TCL_ERROR; - } - - /* - * Move the code if necessary. - */ - - if (mustMove) { - MoveCodeForJumps(assemEnvPtr, mustMove); - } - - /* - * Resolve jump target labels to bytecode offsets. - */ - - FillInJumpOffsets(assemEnvPtr); - - /* - * Label each basic block with its catch context. Quit on inconsistency. - */ - - if (ProcessCatches(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Make sure that no block accessible from a catch's error exit that hasn't - * popped the exception stack can throw an exception. - */ - - if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Compute stack balance throughout the program. - */ - - if (CheckStack(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * TODO - Check for unreachable code. Or maybe not; unreachable code is - * Mostly Harmless. - */ - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CalculateJumpRelocations -- - * - * Calculate any movement that has to be done in the assembly code to - * expand JUMP1 instructions to JUMP4 (because they jump more than a - * 1-byte range). - * - * Results: - * Returns a standard Tcl result, with an appropriate error message if - * anything fails. - * - * Side effects: - * Sets the 'startOffset' pointer in every basic block to the new origin - * of the block, and turns off JUMP1 flags on instructions that must be - * expanded (and adjusts them to the corresponding JUMP4's). Does *not* - * store the jump offsets at this point. - * - * Sets *mustMove to 1 if and only if at least one instruction changed - * size so the code must be moved. - * - * As a side effect, also checks for undefined labels and reports them. - * - *----------------------------------------------------------------------------- - */ - -static int -CalculateJumpRelocations( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int* mustMove) /* OUTPUT: Number of bytes that have been - * added to the code */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - Tcl_HashEntry* entry; /* Exit label's entry in the symbol table */ - BasicBlock* jumpTarget; /* Basic block where the jump goes */ - int motion; /* Amount by which the code has expanded */ - int offset; /* Offset in the bytecode from a jump - * instruction to its target */ - unsigned opcode; /* Opcode in the bytecode being adjusted */ - - /* - * Iterate through basic blocks as long as a change results in code - * expansion. - */ - - *mustMove = 0; - do { - motion = 0; - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - /* - * Advance the basic block start offset by however many bytes we - * have inserted in the code up to this point - */ - - bbPtr->startOffset += motion; - - /* - * If the basic block references a label (and hence performs a - * jump), find the location of the label. Report an error if the - * label is missing. - */ - - if (bbPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); - if (entry == NULL) { - ReportUndefinedLabel(assemEnvPtr, bbPtr, - bbPtr->jumpTarget); - return TCL_ERROR; - } - - /* - * If the instruction is a JUMP1, turn it into a JUMP4 if its - * target is out of range. - */ - - jumpTarget = Tcl_GetHashValue(entry); - if (bbPtr->flags & BB_JUMP1) { - offset = jumpTarget->startOffset - - (bbPtr->jumpOffset + motion); - if (offset < -0x80 || offset > 0x7f) { - opcode = TclGetUInt1AtPtr(envPtr->codeStart - + bbPtr->jumpOffset); - ++opcode; - TclStoreInt1AtPtr(opcode, - envPtr->codeStart + bbPtr->jumpOffset); - motion += 3; - bbPtr->flags &= ~BB_JUMP1; - } - } - } - - /* - * If the basic block references a jump table, that doesn't affect - * the code locations, but resolve the labels now, and store basic - * block pointers in the jumptable hash. - */ - - if (bbPtr->flags & BB_JUMPTABLE) { - if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) { - return TCL_ERROR; - } - } - } - *mustMove += motion; - } while (motion != 0); - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckJumpTableLabels -- - * - * Make sure that all the labels in a jump table are defined. - * - * Results: - * Returns TCL_OK if they are, TCL_ERROR if they aren't. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckJumpTableLabels( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block that ends in a jump table */ -{ - Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; - /* Hash table with the symbols */ - Tcl_HashSearch search; /* Hash table iterator */ - Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ - Tcl_Obj* symbolObj; /* Jump target */ - Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ - - /* - * Look up every jump target in the jump hash. - */ - - DEBUG_PRINT("check jump table labels %p {\n", bbPtr); - for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); - symEntryPtr != NULL; - symEntryPtr = Tcl_NextHashEntry(&search)) { - symbolObj = Tcl_GetHashValue(symEntryPtr); - valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); - DEBUG_PRINT(" %s -> %s (%d)\n", - (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), (valEntryPtr != NULL)); - if (valEntryPtr == NULL) { - ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); - return TCL_ERROR; - } - } - DEBUG_PRINT("}\n"); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ReportUndefinedLabel -- - * - * Report that a basic block refers to an undefined jump label - * - * Side effects: - * Stores an error message, error code, and line number information in - * the assembler's Tcl interpreter. - * - *----------------------------------------------------------------------------- - */ - -static void -ReportUndefinedLabel( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block that contains the undefined - * label */ - Tcl_Obj* jumpTarget) /* Label of a jump target */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "undefined label \"%s\"", Tcl_GetString(jumpTarget))); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - Tcl_GetString(jumpTarget), NULL); - Tcl_SetErrorLine(interp, bbPtr->jumpLine); - } -} - -/* - *----------------------------------------------------------------------------- - * - * MoveCodeForJumps -- - * - * Move bytecodes in memory to accommodate JUMP1 instructions that have - * expanded to become JUMP4's. - * - *----------------------------------------------------------------------------- - */ - -static void -MoveCodeForJumps( - AssemblyEnv* assemEnvPtr, /* Assembler environment */ - int mustMove) /* Number of bytes of added code */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - int topOffset; /* Bytecode offset of the following basic - * block before code motion */ - - /* - * Make sure that there is enough space in the bytecode array to - * accommodate the expanded code. - */ - - while (envPtr->codeEnd < envPtr->codeNext + mustMove) { - TclExpandCodeArray(envPtr); - } - - /* - * Iterate through the bytecodes in reverse order, and move them upward to - * their new homes. - */ - - topOffset = envPtr->codeNext - envPtr->codeStart; - for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) { - DEBUG_PRINT("move code from %d to %d\n", - bbPtr->originalStartOffset, bbPtr->startOffset); - memmove(envPtr->codeStart + bbPtr->startOffset, - envPtr->codeStart + bbPtr->originalStartOffset, - topOffset - bbPtr->originalStartOffset); - topOffset = bbPtr->originalStartOffset; - bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset); - } - envPtr->codeNext += mustMove; -} - -/* - *----------------------------------------------------------------------------- - * - * FillInJumpOffsets -- - * - * Fill in the final offsets of all jump instructions once bytecode - * locations have been completely determined. - * - *----------------------------------------------------------------------------- - */ - -static void -FillInJumpOffsets( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - Tcl_HashEntry* entry; /* Hashtable entry for a jump target label */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - int fromOffset; /* Bytecode location of a jump instruction */ - int targetOffset; /* Bytecode location of a jump instruction's - * target */ - - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - if (bbPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); - fromOffset = bbPtr->jumpOffset; - targetOffset = jumpTarget->startOffset; - if (bbPtr->flags & BB_JUMP1) { - TclStoreInt1AtPtr(targetOffset - fromOffset, - envPtr->codeStart + fromOffset + 1); - } else { - TclStoreInt4AtPtr(targetOffset - fromOffset, - envPtr->codeStart + fromOffset + 1); - } - } - if (bbPtr->flags & BB_JUMPTABLE) { - ResolveJumpTableTargets(assemEnvPtr, bbPtr); - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * ResolveJumpTableTargets -- - * - * Puts bytecode addresses for the targets of a jumptable into the - * table - * - * Results: - * Returns TCL_OK if they are, TCL_ERROR if they aren't. - * - *----------------------------------------------------------------------------- - */ - -static void -ResolveJumpTableTargets( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block that ends in a jump table */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; - /* Hash table with the symbols */ - Tcl_HashSearch search; /* Hash table iterator */ - Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ - Tcl_Obj* symbolObj; /* Jump target */ - Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ - int auxDataIndex; /* Index of the auxdata */ - JumptableInfo* realJumpTablePtr; - /* Jump table in the actual code */ - Tcl_HashTable* realJumpHashPtr; - /* Jump table hash in the actual code */ - Tcl_HashEntry* realJumpEntryPtr; - /* Entry in the jump table hash in - * the actual code */ - BasicBlock* jumpTargetBBPtr; - /* Basic block that the jump proceeds to */ - int junk; - - auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); - DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", - bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex); - realJumpHashPtr = &realJumpTablePtr->hashTable; - - /* - * Look up every jump target in the jump hash. - */ - - DEBUG_PRINT("resolve jump table {\n"); - for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); - symEntryPtr != NULL; - symEntryPtr = Tcl_NextHashEntry(&search)) { - symbolObj = Tcl_GetHashValue(symEntryPtr); - DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); - - valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); - jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr); - - realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, - Tcl_GetHashKey(symHash, symEntryPtr), &junk); - DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", - (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), jumpTargetBBPtr, - jumpTargetBBPtr->startOffset, realJumpEntryPtr); - - Tcl_SetHashValue(realJumpEntryPtr, - INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); - } - DEBUG_PRINT("}\n"); -} - -/* - *----------------------------------------------------------------------------- - * - * CheckForThrowInWrongContext -- - * - * Verify that no beginCatch/endCatch sequence can throw an exception - * after an original exception is caught and before its exception context - * is removed from the stack. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Stores an appropriate error message in the interpreter as needed. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckForThrowInWrongContext( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* blockPtr; /* Current basic block */ - - /* - * Walk through the basic blocks in turn, checking all the ones that have - * caught an exception and not disposed of it properly. - */ - - for (blockPtr = assemEnvPtr->head_bb; - blockPtr != NULL; - blockPtr = blockPtr->successor1) { - if (blockPtr->catchState == BBCS_CAUGHT) { - /* - * Walk through the instructions in the basic block. - */ - - if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) { - return TCL_ERROR; - } - } - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckNonThrowingBlock -- - * - * Check that a basic block cannot throw an exception. - * - * Results: - * Returns TCL_ERROR if the block cannot be proven to be nonthrowing. - * - * Side effects: - * Stashes an error message in the interpreter result. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckNonThrowingBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* blockPtr) /* Basic block where exceptions are not - * allowed */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* nextPtr; /* Pointer to the succeeding basic block */ - int offset; /* Bytecode offset of the current - * instruction */ - int bound; /* Bytecode offset following the last - * instruction of the block. */ - unsigned char opcode; /* Current bytecode instruction */ - - /* - * Determine where in the code array the basic block ends. - */ - - nextPtr = blockPtr->successor1; - if (nextPtr == NULL) { - bound = envPtr->codeNext - envPtr->codeStart; - } else { - bound = nextPtr->startOffset; - } - - /* - * Walk through the instructions of the block. - */ - - offset = blockPtr->startOffset; - while (offset < bound) { - /* - * Determine whether an instruction is nonthrowing. - */ - - opcode = (envPtr->codeStart)[offset]; - if (BytecodeMightThrow(opcode)) { - /* - * Report an error for a throw in the wrong context. - */ - - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" instruction may not appear in " - "a context where an exception has been " - "caught and not disposed of.", - tclInstructionTable[opcode].name)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - } - return TCL_ERROR; - } - offset += tclInstructionTable[opcode].numBytes; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * BytecodeMightThrow -- - * - * Tests if a given bytecode instruction might throw an exception. - * - * Results: - * Returns 1 if the bytecode might throw an exception, 0 if the - * instruction is known never to throw. - * - *----------------------------------------------------------------------------- - */ - -static int -BytecodeMightThrow( - unsigned char opcode) -{ - /* - * Binary search on the non-throwing bytecode list. - */ - - int min = 0; - int max = sizeof(NonThrowingByteCodes) - 1; - int mid; - unsigned char c; - - while (max >= min) { - mid = (min + max) / 2; - c = NonThrowingByteCodes[mid]; - if (opcode < c) { - max = mid-1; - } else if (opcode > c) { - min = mid+1; - } else { - /* - * Opcode is nonthrowing. - */ - - return 0; - } - } - - return 1; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckStack -- - * - * Audit stack usage in a block of assembly code. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Updates stack depth on entry for all basic blocks in the flowgraph. - * Calculates the max stack depth used in the program, and updates the - * compilation environment to reflect it. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckStack( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - int maxDepth; /* Maximum stack depth overall */ - - /* - * Checking the head block will check all the other blocks recursively. - */ - - assemEnvPtr->maxDepth = 0; - if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL, - 0) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Post the max stack depth back to the compilation environment. - */ - - maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth; - if (maxDepth > envPtr->maxStackDepth) { - envPtr->maxStackDepth = maxDepth; - } - - /* - * If the exit is reachable, make sure that the program exits with 1 - * operand on the stack. - */ - - if (StackCheckExit(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Reset the visited state on all basic blocks. - */ - - ResetVisitedBasicBlocks(assemEnvPtr); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * StackCheckBasicBlock -- - * - * Checks stack consumption for a basic block (and recursively for its - * successors). - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Updates initial stack depth for the basic block and its successors. - * (Final and maximum stack depth are relative to initial, and are not - * touched). - * - * This procedure eventually checks, for the entire flow graph, whether stack - * balance is consistent. It is an error for a given basic block to be - * reachable along multiple flow paths with different stack depths. - * - *----------------------------------------------------------------------------- - */ - -static int -StackCheckBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* blockPtr, /* Pointer to the basic block being checked */ - BasicBlock* predecessor, /* Pointer to the block that passed control to - * this one. */ - int initialStackDepth) /* Stack depth on entry to the block */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - int stackDepth; /* Current stack depth */ - int maxDepth; /* Maximum stack depth so far */ - int result; /* Tcl status return */ - Tcl_HashSearch jtSearch; /* Search structure for the jump table */ - Tcl_HashEntry* jtEntry; /* Hash entry in the jump table */ - Tcl_Obj* targetLabel; /* Target label from the jump table */ - Tcl_HashEntry* entry; /* Hash entry in the label table */ - - if (blockPtr->flags & BB_VISITED) { - /* - * If the block is already visited, check stack depth for consistency - * among the paths that reach it. - */ - - if (blockPtr->initialStackDepth == initialStackDepth) { - return TCL_OK; - } - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "inconsistent stack depths on two execution paths", -1)); - - /* - * TODO - add execution trace of both paths - */ - - Tcl_SetErrorLine(interp, blockPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - } - return TCL_ERROR; - } - - /* - * If the block is not already visited, set the 'predecessor' link to - * indicate how control got to it. Set the initial stack depth to the - * current stack depth in the flow of control. - */ - - blockPtr->flags |= BB_VISITED; - blockPtr->predecessor = predecessor; - blockPtr->initialStackDepth = initialStackDepth; - - /* - * Calculate minimum stack depth, and flag an error if the block - * underflows the stack. - */ - - if (initialStackDepth + blockPtr->minStackDepth < 0) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - Tcl_SetErrorLine(interp, blockPtr->startLine); - } - return TCL_ERROR; - } - - /* - * Make sure that the block doesn't try to pop below the stack level of an - * enclosing catch. - */ - - if (blockPtr->enclosingCatch != 0 && - initialStackDepth + blockPtr->minStackDepth - < (blockPtr->enclosingCatch->initialStackDepth - + blockPtr->enclosingCatch->finalStackDepth)) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "code pops stack below level of enclosing catch", -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1); - AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); - Tcl_SetErrorLine(interp, blockPtr->startLine); - } - return TCL_ERROR; - } - - /* - * Update maximum stgack depth. - */ - - maxDepth = initialStackDepth + blockPtr->maxStackDepth; - if (maxDepth > assemEnvPtr->maxDepth) { - assemEnvPtr->maxDepth = maxDepth; - } - - /* - * Calculate stack depth on exit from the block, and invoke this procedure - * recursively to check successor blocks. - */ - - stackDepth = initialStackDepth + blockPtr->finalStackDepth; - result = TCL_OK; - if (blockPtr->flags & BB_FALLTHRU) { - result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1, - blockPtr, stackDepth); - } - - if (result == TCL_OK && blockPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(blockPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); - result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, - stackDepth); - } - - /* - * All blocks referenced in a jump table are successors. - */ - - if (blockPtr->flags & BB_JUMPTABLE) { - for (jtEntry = Tcl_FirstHashEntry(&blockPtr->jtPtr->hashTable, - &jtSearch); - result == TCL_OK && jtEntry != NULL; - jtEntry = Tcl_NextHashEntry(&jtSearch)) { - targetLabel = Tcl_GetHashValue(jtEntry); - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); - jumpTarget = Tcl_GetHashValue(entry); - result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, - blockPtr, stackDepth); - } - } - - return result; -} - -/* - *----------------------------------------------------------------------------- - * - * StackCheckExit -- - * - * Makes sure that the net stack effect of an entire assembly language - * script is to push 1 result. - * - * Results: - * Returns a standard Tcl result, with an error message in the - * interpreter result if the stack is wrong. - * - * Side effects: - * If the assembly code had a net stack effect of zero, emits code to the - * concluding block to push a null result. In any case, updates the stack - * depth in the compile environment to reflect the net effect of the - * assembly code. - * - *----------------------------------------------------------------------------- - */ - -static int -StackCheckExit( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - int depth; /* Net stack effect */ - int litIndex; /* Index in the literal pool of the empty - * string */ - BasicBlock* curr_bb = assemEnvPtr->curr_bb; - /* Final basic block in the assembly */ - - /* - * Don't perform these checks if execution doesn't reach the exit (either - * because of an infinite loop or because the only return is from the - * middle. - */ - - if (curr_bb->flags & BB_VISITED) { - /* - * Exit with no operands; push an empty one. - */ - - depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; - if (depth == 0) { - /* - * Emit a 'push' of the empty literal. - */ - - litIndex = TclRegisterNewLiteral(envPtr, "", 0); - - /* - * Assumes that 'push' is at slot 0 in TalInstructionTable. - */ - - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); - ++depth; - } - - /* - * Exit with unbalanced stack. - */ - - if (depth != 1) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "stack is unbalanced on exit from the code (depth=%d)", - depth)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL); - } - return TCL_ERROR; - } - - /* - * Record stack usage. - */ - - envPtr->currStackDepth += depth; - } - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ProcessCatches -- - * - * First pass of 'catch' processing. - * - * Results: - * Returns a standard Tcl result, with an appropriate error message if - * the result is TCL_ERROR. - * - * Side effects: - * Labels all basic blocks with their enclosing catches. - * - *----------------------------------------------------------------------------- - */ - -static int -ProcessCatches( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* blockPtr; /* Pointer to a basic block */ - - /* - * Clear the catch state of all basic blocks. - */ - - for (blockPtr = assemEnvPtr->head_bb; - blockPtr != NULL; - blockPtr = blockPtr->successor1) { - blockPtr->catchState = BBCS_UNKNOWN; - blockPtr->enclosingCatch = NULL; - } - - /* - * Start the check recursively from the first basic block, which is - * outside any exception context - */ - - if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, - NULL, BBCS_NONE, 0) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Check for unclosed catch on exit. - */ - - if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Now there's enough information to build the exception ranges. - */ - - if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Finally, restore any exception ranges from embedded scripts. - */ - - RestoreEmbeddedExceptionRanges(assemEnvPtr); - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * ProcessCatchesInBasicBlock -- - * - * First-pass catch processing for one basic block. - * - * Results: - * Returns a standard Tcl result, with error message in the interpreter - * result if an error occurs. - * - * This procedure checks consistency of the exception context through the - * assembler program, and records the enclosing 'catch' for every basic block. - * - *----------------------------------------------------------------------------- - */ - -static int -ProcessCatchesInBasicBlock( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - BasicBlock* enclosing, /* Start basic block of the enclosing catch */ - enum BasicBlockCatchState state, - /* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */ - int catchDepth) /* Depth of nesting of catches */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - int result; /* Return value from this procedure */ - BasicBlock* fallThruEnclosing; - /* Enclosing catch if execution falls thru */ - enum BasicBlockCatchState fallThruState; - /* Catch state of the successor block */ - BasicBlock* jumpEnclosing; /* Enclosing catch if execution goes to jump - * target */ - enum BasicBlockCatchState jumpState; - /* Catch state of the jump target */ - int changed = 0; /* Flag == 1 iff successor blocks need to be - * checked because the state of this block has - * changed. */ - BasicBlock* jumpTarget; /* Basic block where a jump goes */ - Tcl_HashSearch jtSearch; /* Hash search control for a jumptable */ - Tcl_HashEntry* jtEntry; /* Entry in a jumptable */ - Tcl_Obj* targetLabel; /* Target label from a jumptable */ - Tcl_HashEntry* entry; /* Entry from the label table */ - - /* - * Update the state of the current block, checking for consistency. Set - * 'changed' to 1 if the state changes and successor blocks need to be - * rechecked. - */ - - if (bbPtr->catchState == BBCS_UNKNOWN) { - bbPtr->enclosingCatch = enclosing; - } else if (bbPtr->enclosingCatch != enclosing) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "execution reaches an instruction in inconsistent " - "exception contexts", -1)); - Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL); - } - return TCL_ERROR; - } - if (state > bbPtr->catchState) { - bbPtr->catchState = state; - changed = 1; - } - - /* - * If this block has been visited before, and its state hasn't changed, - * we're done with it for now. - */ - - if (!changed) { - return TCL_OK; - } - bbPtr->catchDepth = catchDepth; - - /* - * Determine enclosing catch and 'caught' state for the fallthrough and - * the jump target. Default for both is the state of the current block. - */ - - fallThruEnclosing = enclosing; - fallThruState = state; - jumpEnclosing = enclosing; - jumpState = state; - - /* - * TODO: Make sure that the test cases include validating that a natural - * loop can't include 'beginCatch' or 'endCatch' - */ - - if (bbPtr->flags & BB_BEGINCATCH) { - /* - * If the block begins a catch, the state for the successor is 'in - * catch'. The jump target is the exception exit, and the state of the - * jump target is 'caught.' - */ - - fallThruEnclosing = bbPtr; - fallThruState = BBCS_INCATCH; - jumpEnclosing = bbPtr; - jumpState = BBCS_CAUGHT; - ++catchDepth; - } - - if (bbPtr->flags & BB_ENDCATCH) { - /* - * If the block ends a catch, the state for the successor is whatever - * the state was on entry to the catch. - */ - - if (enclosing == NULL) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "endCatch without a corresponding beginCatch", -1)); - Tcl_SetErrorLine(interp, bbPtr->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL); - } - return TCL_ERROR; - } - fallThruEnclosing = enclosing->enclosingCatch; - fallThruState = enclosing->catchState; - --catchDepth; - } - - /* - * Visit any successor blocks with the appropriate exception context - */ - - result = TCL_OK; - if (bbPtr->flags & BB_FALLTHRU) { - result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1, - fallThruEnclosing, fallThruState, catchDepth); - } - if (result == TCL_OK && bbPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); - result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, - jumpEnclosing, jumpState, catchDepth); - } - - /* - * All blocks referenced in a jump table are successors. - */ - - if (bbPtr->flags & BB_JUMPTABLE) { - for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch); - result == TCL_OK && jtEntry != NULL; - jtEntry = Tcl_NextHashEntry(&jtSearch)) { - targetLabel = Tcl_GetHashValue(jtEntry); - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); - jumpTarget = Tcl_GetHashValue(entry); - result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, - jumpEnclosing, jumpState, catchDepth); - } - } - - return result; -} - -/* - *----------------------------------------------------------------------------- - * - * CheckForUnclosedCatches -- - * - * Checks that a sequence of assembly code has no unclosed catches on - * exit. - * - * Results: - * Returns a standard Tcl result, with an error message for unclosed - * catches. - * - *----------------------------------------------------------------------------- - */ - -static int -CheckForUnclosedCatches( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - - if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "catch still active on exit from assembly code", -1)); - Tcl_SetErrorLine(interp, - assemEnvPtr->curr_bb->enclosingCatch->startLine); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * BuildExceptionRanges -- - * - * Walks through the assembly code and builds exception ranges for the - * catches embedded therein. - * - * Results: - * Returns a standard Tcl result with an error message in the interpreter - * if anything is unsuccessful. - * - * Side effects: - * Each contiguous block of code with a given catch exit is assigned an - * exception range at the appropriate level. - * Exception ranges in embedded blocks have their levels corrected and - * collated into the table. - * Blocks that end with 'beginCatch' are associated with the innermost - * exception range of the following block. - * - *----------------------------------------------------------------------------- - */ - -static int -BuildExceptionRanges( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Current basic block */ - BasicBlock* prevPtr = NULL; /* Previous basic block */ - int catchDepth = 0; /* Current catch depth */ - int maxCatchDepth = 0; /* Maximum catch depth in the program */ - BasicBlock** catches; /* Stack of catches in progress */ - int* catchIndices; /* Indices of the exception ranges of catches - * in progress */ - int i; - - /* - * Determine the max catch depth for the entire assembly script - * (excluding embedded eval's and expr's, which will be handled later). - */ - - for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { - if (bbPtr->catchDepth > maxCatchDepth) { - maxCatchDepth = bbPtr->catchDepth; - } - } - - /* - * Allocate memory for a stack of active catches. - */ - - catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*)); - catchIndices = ckalloc(maxCatchDepth * sizeof(int)); - for (i = 0; i < maxCatchDepth; ++i) { - catches[i] = NULL; - catchIndices[i] = -1; - } - - /* - * Walk through the basic blocks and manage exception ranges. - */ - - for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) { - UnstackExpiredCatches(envPtr, bbPtr, catchDepth, catches, - catchIndices); - LookForFreshCatches(bbPtr, catches); - StackFreshCatches(assemEnvPtr, bbPtr, catchDepth, catches, - catchIndices); - - /* - * If the last block was a 'begin catch', fill in the exception range. - */ - - catchDepth = bbPtr->catchDepth; - if (prevPtr != NULL && (prevPtr->flags & BB_BEGINCATCH)) { - TclStoreInt4AtPtr(catchIndices[catchDepth-1], - envPtr->codeStart + bbPtr->startOffset - 4); - } - - prevPtr = bbPtr; - } - - /* Make sure that all catches are closed */ - - if (catchDepth != 0) { - Tcl_Panic("unclosed catch at end of code in " - "tclAssembly.c:BuildExceptionRanges, can't happen"); - } - - /* Free temp storage */ - - ckfree(catchIndices); - ckfree(catches); - - return TCL_OK; -} - -/* - *----------------------------------------------------------------------------- - * - * UnstackExpiredCatches -- - * - * Unstacks and closes the exception ranges for any catch contexts that - * were active in the previous basic block but are inactive in the - * current one. - * - *----------------------------------------------------------------------------- - */ - -static void -UnstackExpiredCatches( - CompileEnv* envPtr, /* Compilation environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - int catchDepth, /* Depth of nesting of catches prior to entry - * to this block */ - BasicBlock** catches, /* Array of catch contexts */ - int* catchIndices) /* Indices of the exception ranges - * corresponding to the catch contexts */ -{ - ExceptionRange* range; /* Exception range for a specific catch */ - BasicBlock* catch; /* Catch block being examined */ - BasicBlockCatchState catchState; - /* State of the code relative to the catch - * block being examined ("in catch" or - * "caught"). */ - - /* - * Unstack any catches that are deeper than the nesting level of the basic - * block being entered. - */ - - while (catchDepth > bbPtr->catchDepth) { - --catchDepth; - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; - catches[catchDepth] = NULL; - catchIndices[catchDepth] = -1; - } - - /* - * Unstack any catches that don't match the basic block being entered, - * either because they are no longer part of the context, or because the - * context has changed from INCATCH to CAUGHT. - */ - - catchState = bbPtr->catchState; - catch = bbPtr->enclosingCatch; - while (catchDepth > 0) { - --catchDepth; - if (catches[catchDepth] != NULL) { - if (catches[catchDepth] != catch || catchState >= BBCS_CAUGHT) { - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; - catches[catchDepth] = NULL; - catchIndices[catchDepth] = -1; - } - catchState = catch->catchState; - catch = catch->enclosingCatch; - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * LookForFreshCatches -- - * - * Determines whether a basic block being entered needs any exception - * ranges that are not already stacked. - * - * Does not create the ranges: this procedure iterates from the innermost - * catch outward, but exception ranges must be created from the outermost - * catch inward. - * - *----------------------------------------------------------------------------- - */ - -static void -LookForFreshCatches( - BasicBlock* bbPtr, /* Basic block being entered */ - BasicBlock** catches) /* Array of catch contexts that are already - * entered */ -{ - BasicBlockCatchState catchState; - /* State ("in catch" or "caught") of the - * current catch. */ - BasicBlock* catch; /* Current enclosing catch */ - int catchDepth; /* Nesting depth of the current catch */ - - catchState = bbPtr->catchState; - catch = bbPtr->enclosingCatch; - catchDepth = bbPtr->catchDepth; - while (catchDepth > 0) { - --catchDepth; - if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) { - catches[catchDepth] = catch; - } - catchState = catch->catchState; - catch = catch->enclosingCatch; - } -} - -/* - *----------------------------------------------------------------------------- - * - * StackFreshCatches -- - * - * Make ExceptionRange records for any catches that are in the basic - * block being entered and were not in the previous basic block. - * - *----------------------------------------------------------------------------- - */ - -static void -StackFreshCatches( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr, /* Basic block being processed */ - int catchDepth, /* Depth of nesting of catches prior to entry - * to this block */ - BasicBlock** catches, /* Array of catch contexts */ - int* catchIndices) /* Indices of the exception ranges - * corresponding to the catch contexts */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - ExceptionRange* range; /* Exception range for a specific catch */ - BasicBlock* catch; /* Catch block being examined */ - BasicBlock* errorExit; /* Error exit from the catch block */ - Tcl_HashEntry* entryPtr; - - catchDepth = 0; - - /* - * Iterate through the enclosing catch blocks from the outside in, - * looking for ones that don't have exception ranges (and are uncaught) - */ - - for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) { - if (catchIndices[catchDepth] == -1 && catches[catchDepth] != NULL) { - /* - * Create an exception range for a block that needs one. - */ - - catch = catches[catchDepth]; - catchIndices[catchDepth] = - TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->nestingLevel = envPtr->exceptDepth + catchDepth; - envPtr->maxExceptDepth = - TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); - range->codeOffset = bbPtr->startOffset; - - entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(catch->jumpTarget)); - if (entryPtr == NULL) { - Tcl_Panic("undefined label in tclAssembly.c:" - "BuildExceptionRanges, can't happen"); - } - - errorExit = Tcl_GetHashValue(entryPtr); - range->catchOffset = errorExit->startOffset; - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * RestoreEmbeddedExceptionRanges -- - * - * Processes an assembly script, replacing any exception ranges that - * were present in embedded code. - * - *----------------------------------------------------------------------------- - */ - -static void -RestoreEmbeddedExceptionRanges( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Current basic block */ - int rangeBase; /* Base of the foreign exception ranges when - * they are reinstalled */ - int rangeIndex; /* Index of the current foreign exception - * range as reinstalled */ - ExceptionRange* range; /* Current foreign exception range */ - unsigned char opcode; /* Current instruction's opcode */ - int catchIndex; /* Index of the exception range to which the - * current instruction refers */ - int i; - - /* - * Walk the basic blocks looking for exceptions in embedded scripts. - */ - - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - if (bbPtr->foreignExceptionCount != 0) { - /* - * Reinstall the embedded exceptions and track their nesting level - */ - - rangeBase = envPtr->exceptArrayNext; - for (i = 0; i < bbPtr->foreignExceptionCount; ++i) { - range = bbPtr->foreignExceptions + i; - rangeIndex = TclCreateExceptRange(range->type, envPtr); - range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; - memcpy(envPtr->exceptArrayPtr + rangeIndex, range, - sizeof(ExceptionRange)); - if (range->nestingLevel >= envPtr->maxExceptDepth) { - envPtr->maxExceptDepth = range->nestingLevel + 1; - } - } - - /* - * Walk through the bytecode of the basic block, and relocate - * INST_BEGIN_CATCH4 instructions to the new locations - */ - - i = bbPtr->startOffset; - while (i < bbPtr->successor1->startOffset) { - opcode = envPtr->codeStart[i]; - if (opcode == INST_BEGIN_CATCH4) { - catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1); - if (catchIndex >= bbPtr->foreignExceptionBase - && catchIndex < (bbPtr->foreignExceptionBase + - bbPtr->foreignExceptionCount)) { - catchIndex -= bbPtr->foreignExceptionBase; - catchIndex += rangeBase; - TclStoreInt4AtPtr(catchIndex, envPtr->codeStart+i+1); - } - } - i += tclInstructionTable[opcode].numBytes; - } - } - } -} - -/* - *----------------------------------------------------------------------------- - * - * ResetVisitedBasicBlocks -- - * - * Turns off the 'visited' flag in all basic blocks at the conclusion - * of a pass. - * - *----------------------------------------------------------------------------- - */ - -static void -ResetVisitedBasicBlocks( - AssemblyEnv* assemEnvPtr) /* Assembly environment */ -{ - BasicBlock* block; - - for (block = assemEnvPtr->head_bb; block != NULL; - block = block->successor1) { - block->flags &= ~BB_VISITED; - } -} - -/* - *----------------------------------------------------------------------------- - * - * AddBasicBlockRangeToErrorInfo -- - * - * Updates the error info of the Tcl interpreter to show a given basic - * block in the code. - * - * This procedure is used to label the callstack with source location - * information when reporting an error in stack checking. - * - *----------------------------------------------------------------------------- - */ - -static void -AddBasicBlockRangeToErrorInfo( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - BasicBlock* bbPtr) /* Basic block in which the error is found */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; - /* Tcl interpreter */ - Tcl_Obj* lineNo; /* Line number in the source */ - - Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); - lineNo = Tcl_NewIntObj(bbPtr->startLine); - Tcl_IncrRefCount(lineNo); - Tcl_AppendObjToErrorInfo(interp, lineNo); - Tcl_AddErrorInfo(interp, " and "); - if (bbPtr->successor1 != NULL) { - Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); - Tcl_AppendObjToErrorInfo(interp, lineNo); - } else { - Tcl_AddErrorInfo(interp, "end of assembly code"); - } - Tcl_DecrRefCount(lineNo); -} - -/* - *----------------------------------------------------------------------------- - * - * DupAssembleCodeInternalRep -- - * - * Part of the Tcl object type implementation for Tcl assembly language - * bytecode. We do not copy the bytecode intrep. Instead, we return - * without setting copyPtr->typePtr, so the copy is a plain string copy - * of the assembly source, and if it is to be used as a compiled - * expression, it will need to be reprocessed. - * - * This makes sense, because with Tcl's copy-on-write practices, the - * usual (only?) time Tcl_DuplicateObj() will be called is when the copy - * is about to be modified, which would invalidate any copied bytecode - * anyway. The only reason it might make sense to copy the bytecode is if - * we had some modifying routines that operated directly on the intrep, - * as we do for lists and dicts. - * - * Results: - * None. - * - * Side effects: - * None. - * - *----------------------------------------------------------------------------- - */ - -static void -DupAssembleCodeInternalRep( - Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr) -{ - return; -} - -/* - *----------------------------------------------------------------------------- - * - * FreeAssembleCodeInternalRep -- - * - * Part of the Tcl object type implementation for Tcl expression - * bytecode. Frees the storage allocated to hold the internal rep, unless - * ref counts indicate bytecode execution is still in progress. - * - * Results: - * None. - * - * Side effects: - * May free allocated memory. Leaves objPtr untyped. - * - *----------------------------------------------------------------------------- - */ - -static void -FreeAssembleCodeInternalRep( - Tcl_Obj *objPtr) -{ - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - objPtr->typePtr = NULL; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5c5bc64..594f8b7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -586,7 +586,6 @@ Tcl_CreateInterp(void) iPtr->packagePrefer = PKG_PREFER_LATEST; } - iPtr->cmdCount = 0; TclInitLiteralTable(&iPtr->literalTable); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; @@ -839,12 +838,6 @@ 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::inject", NULL, NRCoroInjectObjCmd, NULL, NULL); @@ -4318,7 +4311,6 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; - Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { @@ -4349,7 +4341,6 @@ Dispatch( } #endif /* USE_DTRACE */ - iPtr->cmdCount++; return objProc(clientData, interp, objc, objv); } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 739dca9..59e0991 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -111,8 +111,6 @@ static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoCompleteCmd(ClientData dummy, Tcl_Interp *interp, @@ -163,7 +161,6 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, @@ -589,45 +586,6 @@ InfoBodyCmd( /* *---------------------------------------------------------------------- * - * InfoCmdCountCmd -- - * - * Called to implement the "info cmdcount" command that returns the - * number of commands that have been executed. Handles the following - * syntax: - * - * info cmdcount - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a result in the interpreter's result object. If there is an - * error, the result is an error message. - * - *---------------------------------------------------------------------- - */ - -static int -InfoCmdCountCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, NULL); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * InfoCommandsCmd -- * * Called to implement the "info commands" command that returns the list diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 18da741..860beec 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -37,12 +37,6 @@ static void PrintForeachInfo(ClientData clientData, static void DisassembleForeachInfo(ClientData clientData, Tcl_Obj *dictObj, ByteCode *codePtr, unsigned int pcOffset); -static void PrintNewForeachInfo(ClientData clientData, - Tcl_Obj *appendObj, ByteCode *codePtr, - unsigned int pcOffset); -static void DisassembleNewForeachInfo(ClientData clientData, - Tcl_Obj *dictObj, ByteCode *codePtr, - unsigned int pcOffset); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -62,14 +56,6 @@ const AuxDataType tclForeachInfoType = { DisassembleForeachInfo /* disassembleProc */ }; -const AuxDataType tclNewForeachInfoType = { - "NewForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo, /* freeProc */ - PrintNewForeachInfo, /* printProc */ - DisassembleNewForeachInfo /* disassembleProc */ -}; - const AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ @@ -268,7 +254,7 @@ TclCompileArraySetCmd( int isScalar, localIndex, code = TCL_OK; int isDataLiteral, isDataValid, isDataEven, len; int keyVar, valVar, infoIndex; - int fwd, offsetBack, offsetFwd; + int offsetBack, offsetFwd; Tcl_Obj *literalObj; ForeachInfo *infoPtr; @@ -320,20 +306,23 @@ TclCompileArraySetCmd( */ if (isDataEven && len == 0) { + int jumpEnd, jumpPop; if (localIndex >= 0) { TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitForwardJump(envPtr, JUMP_TRUE, &jumpEnd); TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); } else { TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); + TclEmitForwardJump(envPtr, JUMP_TRUE, &jumpPop); TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); + TclEmitForwardJump(envPtr, JUMP, &jumpEnd); /* Each branch decrements stack depth, but we only take one. */ TclAdjustStackDepth(1, envPtr); + TclFixupForwardJumpToHere(envPtr, jumpPop); TclEmitOpcode( INST_POP, envPtr); } + TclFixupForwardJumpToHere(envPtr, jumpEnd); PushStringLiteral(envPtr, ""); goto done; } @@ -384,19 +373,17 @@ TclCompileArraySetCmd( TclEmitOpcode( INST_LIST_LENGTH, envPtr); PushStringLiteral(envPtr, "1"); TclEmitOpcode( INST_BITAND, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + TclEmitForwardJump(envPtr, JUMP_FALSE, &offsetFwd); PushStringLiteral(envPtr, "list must have an even number of elements"); PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); TclAdjustStackDepth(-1, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + TclFixupForwardJumpToHere(envPtr, offsetFwd); } TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_JUMP_TRUE4, 10, envPtr); TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); offsetBack = CurrentOffset(envPtr); @@ -404,7 +391,7 @@ TclCompileArraySetCmd( Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); - infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ + infoPtr->jumpSize = offsetBack - CurrentOffset(envPtr); TclEmitOpcode( INST_FOREACH_STEP, envPtr); TclEmitOpcode( INST_FOREACH_END, envPtr); TclAdjustStackDepth(-3, envPtr); @@ -427,6 +414,7 @@ TclCompileArrayUnsetCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int isScalar, localIndex; + int jumpEnd, jumpPop; if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -440,19 +428,21 @@ TclCompileArrayUnsetCmd( if (localIndex >= 0) { TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); + TclEmitForwardJump(envPtr, JUMP_FALSE, &jumpEnd); TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); TclEmitInt4( localIndex, envPtr); } else { TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); + TclEmitForwardJump(envPtr, JUMP_FALSE, &jumpPop); TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); + TclEmitForwardJump(envPtr, JUMP, &jumpEnd); /* Each branch decrements stack depth, but we only take one. */ TclAdjustStackDepth(1, envPtr); + TclFixupForwardJumpToHere(envPtr, jumpPop); TclEmitOpcode( INST_POP, envPtr); } + TclFixupForwardJumpToHere(envPtr, jumpEnd); PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -480,38 +470,43 @@ TclCompileBreakCmd( 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 + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + int next = envPtr->exceptArrayNext - 1; + int i = -1; + int savedStackDepth = envPtr->currStackDepth; ExceptionRange *rangePtr; - ExceptionAux *auxPtr; - + if (parsePtr->numWords != 1) { return TCL_ERROR; } - /* - * Find the innermost exception range that contains this command. - */ - - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr); - if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - /* - * Found the target! No need for a nasty INST_BREAK here. - */ - - TclCleanupStackForBreakContinue(envPtr, auxPtr); - TclAddLoopBreakFixup(envPtr, auxPtr); - } else { - /* - * Emit a real break. - */ - - TclEmitOpcode(INST_BREAK, envPtr); + if (next >= 0) { + rangePtr = TclGetExceptionRange(CurrentOffset(envPtr), + TCL_BREAK, &envPtr->exceptArrayPtr[next], + &envPtr->exceptArrayPtr[0]); + if (rangePtr) { + i = rangePtr - envPtr->exceptArrayPtr; + if (!IS_CATCH_RANGE(rangePtr) && + ((savedStackDepth > rangePtr->stackDepth) + ||(envPtr->expandDepth > ~rangePtr->numCodeBytes))) { + /* + * (required so that we can optimize to a jump) + * + * Clear expansions and objs on the stack since this range + * started. + */ + + TclEmitInstInt4(INST_CLEAR_RANGE, + (rangePtr - envPtr->exceptArrayPtr), envPtr); + } + } } - TclAdjustStackDepth(1, envPtr); - + + TclEmitInstInt4(INST_BREAK, i, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -542,9 +537,9 @@ TclCompileCatchCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - JumpFixup jumpFixup; + int jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range, dropScript = 0; + int resultIndex, optsIndex, range, rangeFlags; DefineLineInformation; /* TIP #280 */ int depth = TclGetStackDepth(envPtr); @@ -595,108 +590,74 @@ TclCompileCatchCmd( * We will compile the catch command. Declare the exception range that it * uses. * - * If the body is a simple word, compile a BEGIN_CATCH instruction, - * followed by the instructions to eval the body. + * If the body is a simple word, compile the instructions to eval the + * body. * Otherwise, compile instructions to substitute the body text before - * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the - * substituted body. + * starting the catch, then EVAL_STK to evaluate the substituted body. * Care has to be taken to make sure that substitution happens outside the * catch range so that errors in the substitution are not caught. - * [Bug 219184] - * The reason for duplicating the script is that EVAL_STK would otherwise - * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. + * [Bug 219184]. Fix the catch stackDepth to account for EVAL_STK removing + * the script from the stack. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + rangeFlags = CATCH_EXCEPTION_RANGE + | ((resultIndex != -1) ? CATCH_PUSH_RESULT : 0) + | ((optsIndex != -1) ? CATCH_PUSH_OPTIONS : 0); + range = TclCreateExceptRange(rangeFlags, envPtr); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); BODY(cmdTokenPtr, 1); } else { SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - TclEmitOpcode( INST_DUP, envPtr); + envPtr->exceptArrayPtr[range].stackDepth--; TclEmitInvoke(envPtr, INST_EVAL_STK); - /* drop the script */ - dropScript = 1; - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); } ExceptionRangeEnds(envPtr, range); - - - /* - * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, - * and jump around the "error case" code. - */ - - TclCheckStackDepth(depth+1, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + TclCheckStackDepth(depth+1, envPtr); /* - * Emit the "error case" epilogue. Push the interpreter result and the - * return code. + * Emit the "no errors" epilogue: last instruction is push "0" (TCL_OK) + * as the catch result, and jump to the end. There is some code + * duplication in order to allow the optimization of the OK case. + * + * NOTE: see comments on instruction ordering below! */ - ExceptionRangeTarget(envPtr, range, catchOffset); - TclSetStackDepth(depth + dropScript, envPtr); - - if (dropScript) { - TclEmitOpcode( INST_POP, envPtr); - } - - - /* Stack at this point is empty */ - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - - /* Stack at this point on both branches: result returnCode */ - - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", - (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } - - /* - * Push the return options if the caller wants them. This needs to happen - * before INST_END_CATCH - */ + if (rangeFlags & CATCH_PUSH_RESULT) { + Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); - if (optsIndex != -1) { + if (rangeFlags & CATCH_PUSH_OPTIONS) { TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } + TclCheckStackDepth(depth, envPtr); + + PushStringLiteral(envPtr, "0"); + TclEmitForwardJump(envPtr, JUMP, &jumpFixup); /* - * End the catch + * Emit the "error case" epilogue. Push the interpreter result and the + * return code. Note that result and return options are automatically + * pushed if requested at range creation. */ - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Save the result and return options if the caller wants them. This needs - * to happen after INST_END_CATCH (compile-3.6/7). - */ + CatchTarget(envPtr, range); if (optsIndex != -1) { Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } - - /* - * At this point, the top of the stack is inconveniently ordered: - * result returnCode - * Reverse the stack to store the result. - */ - - TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (resultIndex != -1) { Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } - TclEmitOpcode( INST_POP, envPtr); + TclFixupForwardJumpToHere(envPtr, jumpFixup); TclCheckStackDepth(depth+1, envPtr); return TCL_OK; } @@ -815,9 +776,11 @@ TclCompileContinueCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + int next = envPtr->exceptArrayNext - 1; + int i = -1; + int savedStackDepth = envPtr->currStackDepth; ExceptionRange *rangePtr; - ExceptionAux *auxPtr; - + /* * There should be no argument after the "continue". */ @@ -826,28 +789,30 @@ TclCompileContinueCmd( return TCL_ERROR; } - /* - * See if we can find a valid continueOffset (i.e., not -1) in the - * innermost containing exception range. - */ - - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr); - if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - /* - * Found the target! No need for a nasty INST_CONTINUE here. - */ - - TclCleanupStackForBreakContinue(envPtr, auxPtr); - TclAddLoopContinueFixup(envPtr, auxPtr); - } else { - /* - * Emit a real continue. - */ - - TclEmitOpcode(INST_CONTINUE, envPtr); + if (next >= 0) { + rangePtr = TclGetExceptionRange(CurrentOffset(envPtr), + TCL_CONTINUE, &envPtr->exceptArrayPtr[next], + &envPtr->exceptArrayPtr[0]); + if (rangePtr) { + i = rangePtr - envPtr->exceptArrayPtr; + if (!IS_CATCH_RANGE(rangePtr) && + ((savedStackDepth > rangePtr->stackDepth) + ||(envPtr->expandDepth > ~rangePtr->numCodeBytes))) { + /* + * (required so that we can optimize to a jump) + * + * Clear expansions and objs on the stack since this range + * started. + */ + + TclEmitInstInt4(INST_CLEAR_RANGE, + (rangePtr - envPtr->exceptArrayPtr), envPtr); + } + } } - TclAdjustStackDepth(1, envPtr); + TclEmitInstInt4(INST_CONTINUE, i, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } @@ -1226,7 +1191,7 @@ TclCompileDictMergeCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, workerIndex, infoIndex, outLoop; + int i, workerIndex, infoIndex, outLoop, jumpTarget; /* * Deal with some special edge cases. Note that in the case with one @@ -1273,10 +1238,10 @@ TclCompileDictMergeCmd( * For each of the remaining dictionaries... */ - outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); + outLoop = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, outLoop); for (i=2 ; i<parsePtr->numWords ; i++) { + int jumpPop; /* * Get the dictionary, and merge its pairs into the first dict (using * a small loop). @@ -1285,21 +1250,23 @@ TclCompileDictMergeCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr); + TclEmitForwardJump(envPtr, JUMP_TRUE, &jumpPop); + jumpTarget = CurrentOffset(envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_DICT_SET, 1, envPtr); TclEmitInt4( workerIndex, envPtr); TclAdjustStackDepth(-1, envPtr); TclEmitOpcode( INST_POP, envPtr); TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr); + jumpTarget -= CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, jumpTarget, envPtr); + TclFixupForwardJumpToHere(envPtr, jumpPop); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); } ExceptionRangeEnds(envPtr, outLoop); - TclEmitOpcode( INST_END_CATCH, envPtr); /* * Clean up any state left over. @@ -1308,23 +1275,21 @@ TclCompileDictMergeCmd( Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_JUMP1, 18, envPtr); + TclEmitForwardJump(envPtr, JUMP, &jumpTarget); /* * If an exception happens when starting to iterate over the second (and * subsequent) dicts. This is strictly not necessary, but it is nice. */ - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, outLoop, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); + CatchTarget(envPtr, outLoop); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( workerIndex, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); + TclAdjustStackDepth(-1, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); + TclFixupForwardJumpToHere(envPtr, jumpTarget); return TCL_OK; } @@ -1470,13 +1435,11 @@ CompileDictEachCmd( * started by Tcl_DictObjFirst above. */ - catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); + catchRange = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, catchRange); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + TclEmitForwardJump(envPtr, JUMP_TRUE, &emptyTargetOffset); /* * Inside the iteration, write the loop variables. @@ -1523,48 +1486,40 @@ CompileDictEachCmd( * variables if there is another pair. */ - ExceptionRangeTarget(envPtr, loopRange, continueOffset); + ContinueTarget(envPtr, loopRange); TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); + jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP1, 0, envPtr); + + TclEmitForwardJump(envPtr, JUMP, &endTargetOffset); /* * Error handler "finally" clause, which force-terminates the iteration * and rethrows the error. */ - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); + CatchTarget(envPtr, catchRange); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); if (collect == TCL_EACH_COLLECT) { TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( collectVar, envPtr); } + TclAdjustStackDepth(-1, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); /* * Otherwise we're done (the jump after the DICT_FIRST points here) and we * need to pop the bogus key/value pair (pushed to keep stack calculations - * easy!) Note that we skip the END_CATCH. [Bug 1382528] + * easy!) */ - jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; - TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, - envPtr->codeStart + emptyTargetOffset); - jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement, - envPtr->codeStart + endTargetOffset); + TclFixupForwardJumpToHere(envPtr, emptyTargetOffset); + TclFixupForwardJumpToHere(envPtr, endTargetOffset); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclEmitOpcode( INST_END_CATCH, envPtr); + BreakTarget(envPtr, loopRange); /* * Final stage of the command (normal case) is that we push an empty @@ -1597,7 +1552,7 @@ TclCompileDictUpdateCmd( int i, dictIndex, numVars, range, infoIndex; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; DictUpdateInfo *duiPtr; - JumpFixup jumpFixup; + int jumpFixup; /* * There must be at least one argument after the command. @@ -1678,8 +1633,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); BODY(bodyTokenPtr, parsePtr->numWords - 1); @@ -1690,7 +1644,6 @@ TclCompileDictUpdateCmd( * the body evaluation: swap them and finish the update code. */ - TclEmitOpcode( INST_END_CATCH, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); @@ -1699,7 +1652,7 @@ TclCompileDictUpdateCmd( * Jump around the exceptional termination code. */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + TclEmitForwardJump(envPtr, JUMP, &jumpFixup); /* * Termination code for non-ok returns: stash the result and return @@ -1707,20 +1660,19 @@ TclCompileDictUpdateCmd( * and finally return with the catched return data */ - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); + CatchTarget(envPtr, range); + TclAdjustStackDepth(1, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); - TclEmitInvoke(envPtr,INST_RETURN_STK); + TclAdjustStackDepth(-1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } + TclFixupForwardJumpToHere(envPtr, jumpFixup); TclStackFree(interp, keyTokenPtrs); return TCL_OK; @@ -1848,7 +1800,7 @@ TclCompileDictWithCmd( int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; int dictVar, bodyIsEmpty = 1; Tcl_Token *varTokenPtr, *tokenPtr; - JumpFixup jumpFixup; + int jumpFixup; const char *ptr, *end; /* @@ -2022,8 +1974,7 @@ TclCompileDictWithCmd( * Now the body of the [dict with]. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); BODY(tokenPtr, parsePtr->numWords - 1); @@ -2033,7 +1984,6 @@ TclCompileDictWithCmd( * Now fold the results back into the dictionary in the OK case. */ - TclEmitOpcode( INST_END_CATCH, envPtr); if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } @@ -2048,17 +1998,13 @@ TclCompileDictWithCmd( } else { TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); } - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + TclEmitForwardJump(envPtr, JUMP, &jumpFixup); /* * Now fold the results back into the dictionary in the exception case. */ - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); + CatchTarget(envPtr, range); if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } @@ -2073,16 +2019,14 @@ TclCompileDictWithCmd( } else { TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); } + TclAdjustStackDepth(-1, envPtr); TclEmitInvoke(envPtr, INST_RETURN_STK); /* * Prepare for the start of the next command. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", - (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } + TclFixupForwardJumpToHere(envPtr, jumpFixup); return TCL_OK; } @@ -2314,8 +2258,8 @@ TclCompileForCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; - JumpFixup jumpEvalCondFixup; - int bodyCodeOffset, nextCodeOffset, jumpDist; + int jumpEvalCondFixup; + int bodyCodeOffset, jumpDist; int bodyRange, nextRange; DefineLineInformation; /* TIP #280 */ @@ -2366,7 +2310,7 @@ TclCompileForCmd( * if (result) goto B */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); + TclEmitForwardJump(envPtr, JUMP, &jumpEvalCondFixup); /* * Compile the loop body. @@ -2385,8 +2329,9 @@ TclCompileForCmd( */ nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; - nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); + envPtr->exceptArrayPtr[nextRange].continueOffset = -1; + envPtr->exceptArrayPtr[bodyRange].continueOffset = + ExceptionRangeStarts(envPtr, nextRange); BODY(nextTokenPtr, 3); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2396,35 +2341,16 @@ TclCompileForCmd( * terminates the for. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { - bodyCodeOffset += 3; - nextCodeOffset += 3; - } + TclFixupForwardJumpToHere(envPtr, jumpEvalCondFixup); SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - /* - * Fix the starting points of the exception ranges (may have moved due to - * jump type modification) and set where the exceptions target. - */ - - envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; - envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset; - - envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; - - ExceptionRangeTarget(envPtr, bodyRange, breakOffset); - ExceptionRangeTarget(envPtr, nextRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, bodyRange); - TclFinalizeLoopExceptionRange(envPtr, nextRange); + BreakTarget(envPtr, bodyRange); + BreakTarget(envPtr, nextRange); /* * The for command's result is an empty string. @@ -2532,7 +2458,7 @@ CompileEachloopCmd( * record in the ByteCode. */ Tcl_Token *tokenPtr, *bodyTokenPtr; - int jumpBackOffset, infoIndex, range; + int infoIndex, range; int numWords, numLists, i, j, code = TCL_OK; Tcl_Obj *varListObj = NULL; DefineLineInformation; /* TIP #280 */ @@ -2632,7 +2558,7 @@ CompileEachloopCmd( * We will compile the foreach command. */ - infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr); + infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); /* * Create the collecting object, unshared. @@ -2677,21 +2603,19 @@ CompileEachloopCmd( * to terminate the loop. Set the loop's break target. */ - ExceptionRangeTarget(envPtr, range, continueOffset); + ContinueTarget(envPtr, range); TclEmitOpcode(INST_FOREACH_STEP, envPtr); - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); + BreakTarget(envPtr, range); TclEmitOpcode(INST_FOREACH_END, envPtr); TclAdjustStackDepth(-(numLists+2), envPtr); /* * Set the jumpback distance from INST_FOREACH_STEP to the start of the - * body's code. Misuse loopCtTemp for storing the jump size. + * body's code. */ - jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - + infoPtr->jumpSize = -envPtr->exceptArrayPtr[range].continueOffset + envPtr->exceptArrayPtr[range].codeOffset; - infoPtr->loopCtTemp = -jumpBackOffset; /* * The command's result is an empty string if not collecting. If @@ -2743,9 +2667,8 @@ DupForeachInfo( dupPtr = ckalloc(sizeof(ForeachInfo) + numLists * sizeof(ForeachVarList *)); + dupPtr->jumpSize = srcPtr->jumpSize; dupPtr->numLists = numLists; - dupPtr->firstValueTemp = srcPtr->firstValueTemp; - dupPtr->loopCtTemp = srcPtr->loopCtTemp; for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; @@ -2825,48 +2748,8 @@ PrintForeachInfo( register ForeachVarList *varsPtr; int i, j; - Tcl_AppendToObj(appendObj, "data=[", -1); - - for (i=0 ; i<infoPtr->numLists ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ", ", -1); - } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) (infoPtr->firstValueTemp + i)); - } - Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", - (unsigned) infoPtr->loopCtTemp); - for (i=0 ; i<infoPtr->numLists ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ",", -1); - } - Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[", - (unsigned) (infoPtr->firstValueTemp + i)); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; j<varsPtr->numVars ; j++) { - if (j) { - Tcl_AppendToObj(appendObj, ", ", -1); - } - Tcl_AppendPrintfToObj(appendObj, "%%v%u", - (unsigned) varsPtr->varIndexes[j]); - } - Tcl_AppendToObj(appendObj, "]", -1); - } -} - -static void -PrintNewForeachInfo( - ClientData clientData, - Tcl_Obj *appendObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; - int i, j; - - Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", - infoPtr->loopCtTemp); + Tcl_AppendPrintfToObj(appendObj, "jumpSize=%+d, vars=", + infoPtr->jumpSize); for (i=0 ; i<infoPtr->numLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); @@ -2897,58 +2780,11 @@ DisassembleForeachInfo( Tcl_Obj *objPtr, *innerPtr; /* - * Data stores. - */ - - objPtr = Tcl_NewObj(); - for (i=0 ; i<infoPtr->numLists ; i++) { - Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(infoPtr->firstValueTemp + i)); - } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); - - /* - * Loop counter. - */ - - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); - - /* - * Assignment targets. - */ - - objPtr = Tcl_NewObj(); - for (i=0 ; i<infoPtr->numLists ; i++) { - innerPtr = Tcl_NewObj(); - varsPtr = infoPtr->varLists[i]; - for (j=0 ; j<varsPtr->numVars ; j++) { - Tcl_ListObjAppendElement(NULL, innerPtr, - Tcl_NewIntObj(varsPtr->varIndexes[j])); - } - Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); - } - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); -} - -static void -DisassembleNewForeachInfo( - ClientData clientData, - Tcl_Obj *dictObj, - ByteCode *codePtr, - unsigned int pcOffset) -{ - register ForeachInfo *infoPtr = clientData; - register ForeachVarList *varsPtr; - int i, j; - Tcl_Obj *objPtr, *innerPtr; - - /* * Jump offset. */ - Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1), - Tcl_NewIntObj(infoPtr->loopCtTemp)); + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpSize", -1), + Tcl_NewIntObj(infoPtr->jumpSize)); /* * Assignment targets. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index e674fb0..7965ef1 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -196,7 +196,7 @@ TclCompileIfCmd( * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - int jumpFalseDist, numWords, wordIdx, numBytes, j, code; + int numWords, wordIdx, numBytes, j, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ @@ -286,7 +286,7 @@ TclCompileIfCmd( } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + TclEmitForwardJump(envPtr, JUMP_FALSE, jumpFalseFixupArray.fixup+jumpIndex); } code = TCL_OK; @@ -333,7 +333,7 @@ TclCompileIfCmd( TclExpandJumpFixupArray(&jumpEndFixupArray); } jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + TclEmitForwardJump(envPtr, JUMP, jumpEndFixupArray.fixup+jumpIndex); /* @@ -345,15 +345,7 @@ TclCompileIfCmd( */ TclAdjustStackDepth(-1, envPtr); - if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { - /* - * Adjust the code offset for the proceeding jump to the end - * of the "if" command. - */ - - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } + TclFixupForwardJumpToHere(envPtr, jumpFalseFixupArray.fixup[jumpIndex]); } else if (boolVal) { /* * We were processing an "if 1 {...}"; stop compiling scripts. @@ -428,29 +420,7 @@ TclCompileIfCmd( for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { - /* - * Adjust the immediately preceeding "ifFalse" jump. We moved it's - * target (just after this jump) down three bytes. - */ - - unsigned char *ifFalsePc = envPtr->codeStart - + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; - unsigned char opCode = *ifFalsePc; - - if (opCode == INST_JUMP_FALSE1) { - jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else if (opCode == INST_JUMP_FALSE4) { - jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); - } - } + TclFixupForwardJumpToHere(envPtr, jumpEndFixupArray.fixup[jumpIndex]); } /* @@ -644,7 +614,7 @@ TclCompileInfoCommandsCmd( TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_STR_LEN, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, 10, envPtr); TclEmitInstInt4( INST_LIST, 1, envPtr); return TCL_OK; @@ -1574,18 +1544,18 @@ TclCompileLreplaceCmd( TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); TclEmitOpcode( INST_GT, envPtr); offset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, 0, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + TclStoreInt4AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + TclStoreInt4AtPtr(CurrentOffset(envPtr) - offset2, envPtr->codeStart + offset2 + 1); TclAdjustStackDepth(-1, envPtr); } @@ -1630,18 +1600,18 @@ TclCompileLreplaceCmd( TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); TclEmitOpcode( INST_GT, envPtr); offset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); offset2 = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + TclStoreInt4AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + TclStoreInt4AtPtr(CurrentOffset(envPtr) - offset2, envPtr->codeStart + offset2 + 1); TclAdjustStackDepth(-1, envPtr); } @@ -1983,7 +1953,7 @@ TclCompileNamespaceQualifiersCmd( PushStringLiteral(envPtr, ":"); TclEmitOpcode( INST_STR_EQ, envPtr); off = off - CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, off, envPtr); TclEmitOpcode( INST_STR_RANGE, envPtr); return TCL_OK; } @@ -1999,7 +1969,7 @@ TclCompileNamespaceTailCmd( { Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); DefineLineInformation; /* TIP #280 */ - JumpFixup jumpFixup; + int jumpFixup; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -2016,10 +1986,10 @@ TclCompileNamespaceTailCmd( TclEmitOpcode( INST_DUP, envPtr); PushStringLiteral(envPtr, "0"); TclEmitOpcode( INST_GE, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); + TclEmitForwardJump(envPtr, JUMP_FALSE, &jumpFixup); PushStringLiteral(envPtr, "2"); TclEmitOpcode( INST_ADD, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + TclFixupForwardJumpToHere(envPtr, jumpFixup); PushStringLiteral(envPtr, "end"); TclEmitOpcode( INST_STR_RANGE, envPtr); return TCL_OK; @@ -2528,6 +2498,7 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); + TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } @@ -2607,29 +2578,22 @@ TclCompileReturnCmd( * We have default return options and we're in a proc ... */ - int index = envPtr->exceptArrayNext - 1; - int enclosingCatch = 0; - - while (index >= 0) { - ExceptionRange range = envPtr->exceptArrayPtr[index]; + if (envPtr->exceptArrayNext) { + int last = envPtr->exceptArrayNext -1; + ExceptionRange *rangePtr = TclGetExceptionRange(CurrentOffset(envPtr), + TCL_ERROR, &envPtr->exceptArrayPtr[last], + &envPtr->exceptArrayPtr[0]); + if (!rangePtr) { + /* + * ... and there is no enclosing catch. Issue the maximally + * efficient exit instruction. + */ - if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { - enclosingCatch = 1; - break; + Tcl_DecrRefCount(returnOpts); + TclEmitOpcode(INST_DONE, envPtr); + TclAdjustStackDepth(1, envPtr); + return TCL_OK; } - index--; - } - if (!enclosingCatch) { - /* - * ... and there is no enclosing catch. Issue the maximally - * efficient exit instruction. - */ - - Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); - TclAdjustStackDepth(1, envPtr); - return TCL_OK; } } @@ -2674,6 +2638,7 @@ TclCompileReturnCmd( * Issue the RETURN itself. */ + TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } @@ -2686,23 +2651,6 @@ CompileReturnInternal( int level, Tcl_Obj *returnOpts) { - if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) { - ExceptionRange *rangePtr; - ExceptionAux *exceptAux; - - rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux); - if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { - TclCleanupStackForBreakContinue(envPtr, exceptAux); - if (code == TCL_BREAK) { - TclAddLoopBreakFixup(envPtr, exceptAux); - } else { - TclAddLoopContinueFixup(envPtr, exceptAux); - } - Tcl_DecrRefCount(returnOpts); - return; - } - } - TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(op, code, envPtr); TclEmitInt4(level, envPtr); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index ef9340e..06f17ab 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -226,10 +226,6 @@ TclCompileSetCmd( if (localIndex < 0) { TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); } else { TclEmitInstInt4((isAssignment? INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), @@ -239,10 +235,6 @@ TclCompileSetCmd( if (localIndex < 0) { TclEmitOpcode((isAssignment? INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); } else { TclEmitInstInt4((isAssignment? INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), @@ -630,14 +622,14 @@ TclCompileStringIsCmd( OP( DUP); OP1( STR_CLASS, strClassType); - JUMP1( JUMP_TRUE, over); + JUMP4( JUMP_TRUE, over); OP( POP); PUSH( "0"); - JUMP1( JUMP, over2); - FIXJUMP1(over); + JUMP4( JUMP, over2); + FIXJUMP4(over); PUSH( ""); OP( STR_NEQ); - FIXJUMP1(over2); + FIXJUMP4(over2); } return TCL_OK; @@ -650,21 +642,21 @@ TclCompileStringIsCmd( case STR_IS_BOOL: if (allowEmpty) { - JUMP1( JUMP_TRUE, over); + JUMP4( JUMP_TRUE, over); PUSH( ""); OP( STR_EQ); - JUMP1( JUMP, over2); - FIXJUMP1(over); + JUMP4( JUMP, over2); + FIXJUMP4(over); OP( POP); PUSH( "1"); - FIXJUMP1(over2); + FIXJUMP4(over2); } else { OP4( REVERSE, 2); OP( POP); } return TCL_OK; case STR_IS_TRUE: - JUMP1( JUMP_TRUE, over); + JUMP4( JUMP_TRUE, over); if (allowEmpty) { PUSH( ""); OP( STR_EQ); @@ -672,12 +664,12 @@ TclCompileStringIsCmd( OP( POP); PUSH( "0"); } - FIXJUMP1( over); + FIXJUMP4( over); OP( LNOT); OP( LNOT); return TCL_OK; case STR_IS_FALSE: - JUMP1( JUMP_TRUE, over); + JUMP4( JUMP_TRUE, over); if (allowEmpty) { PUSH( ""); OP( STR_NEQ); @@ -685,7 +677,7 @@ TclCompileStringIsCmd( OP( POP); PUSH( "1"); } - FIXJUMP1( over); + FIXJUMP4( over); OP( LNOT); return TCL_OK; } @@ -697,24 +689,24 @@ TclCompileStringIsCmd( OP( DUP); PUSH( ""); OP( STR_EQ); - JUMP1( JUMP_TRUE, isEmpty); + JUMP4( JUMP_TRUE, isEmpty); OP( NUM_TYPE); - JUMP1( JUMP_TRUE, satisfied); + JUMP4( JUMP_TRUE, satisfied); PUSH( "0"); - JUMP1( JUMP, end); - FIXJUMP1( isEmpty); + JUMP4( JUMP, end); + FIXJUMP4( isEmpty); OP( POP); - FIXJUMP1( satisfied); + FIXJUMP4( satisfied); } else { OP( NUM_TYPE); - JUMP1( JUMP_TRUE, satisfied); + JUMP4( JUMP_TRUE, satisfied); PUSH( "0"); - JUMP1( JUMP, end); + JUMP4( JUMP, end); TclAdjustStackDepth(-1, envPtr); - FIXJUMP1( satisfied); + FIXJUMP4( satisfied); } PUSH( "1"); - FIXJUMP1( end); + FIXJUMP4( end); return TCL_OK; } @@ -727,19 +719,19 @@ TclCompileStringIsCmd( OP( DUP); OP( NUM_TYPE); OP( DUP); - JUMP1( JUMP_TRUE, testNumType); + JUMP4( JUMP_TRUE, testNumType); OP( POP); PUSH( ""); OP( STR_EQ); - JUMP1( JUMP, end); + JUMP4( JUMP, end); TclAdjustStackDepth(1, envPtr); - FIXJUMP1( testNumType); + FIXJUMP4( testNumType); OP4( REVERSE, 2); OP( POP); } else { OP( NUM_TYPE); OP( DUP); - JUMP1( JUMP_FALSE, end); + JUMP4( JUMP_FALSE, end); } switch (t) { @@ -756,22 +748,21 @@ TclCompileStringIsCmd( OP( LE); break; } - FIXJUMP1( end); + FIXJUMP4( end); return TCL_OK; case STR_IS_LIST: range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); - OP( DUP); OP( LIST_LENGTH); OP( POP); + PUSH( "1"); + JUMP4( JUMP, end); ExceptionRangeEnds(envPtr, range); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( LNOT); + CatchTarget(envPtr, range); + TclAdjustStackDepth(-1, envPtr); + OP( LNOT); + FIXJUMP4( end); return TCL_OK; } @@ -1077,15 +1068,15 @@ TclCompileStringReplaceCmd( OP4( OVER, 1); PUSH( ""); OP( STR_EQ); - JUMP1( JUMP_FALSE, notEq); + JUMP4( JUMP_FALSE, notEq); OP( POP); - JUMP1( JUMP, end); - FIXJUMP1(notEq); + JUMP4( JUMP, end); + FIXJUMP4(notEq); TclAdjustStackDepth(1, envPtr); OP4( REVERSE, 2); OP44( STR_RANGE_IMM, 1, INDEX_END); OP1( STR_CONCAT1, 2); - FIXJUMP1(end); + FIXJUMP4(end); return TCL_OK; } else if (idx1 == INDEX_END && idx2 == INDEX_END) { @@ -1106,16 +1097,16 @@ TclCompileStringReplaceCmd( OP4( OVER, 1); PUSH( ""); OP( STR_EQ); - JUMP1( JUMP_FALSE, notEq); + JUMP4( JUMP_FALSE, notEq); OP( POP); - JUMP1( JUMP, end); - FIXJUMP1(notEq); + JUMP4( JUMP, end); + FIXJUMP4(notEq); TclAdjustStackDepth(1, envPtr); OP4( REVERSE, 2); OP44( STR_RANGE_IMM, 0, INDEX_END-1); OP4( REVERSE, 2); OP1( STR_CONCAT1, 2); - FIXJUMP1(end); + FIXJUMP4(end); return TCL_OK; } else { @@ -1424,10 +1415,10 @@ TclSubstCompile( CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0, bline = line; + int breakOffset = -1, count = 0, bline = line; Tcl_Parse parse; Tcl_InterpState state = NULL; - + TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); if (state != NULL) { Tcl_ResetResult(interp); @@ -1449,10 +1440,9 @@ TclSubstCompile( for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { - int length, literal, catchRange, breakJump; + int length, literal, catchRange, loopRange; char buf[TCL_UTF_MAX]; - JumpFixup startFixup, okFixup, returnFixup, breakFixup; - JumpFixup continueFixup, otherFixup, endFixup; + int startFixup, okFixup, returnFixup; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: @@ -1509,25 +1499,25 @@ TclSubstCompile( count = 1; } - if (breakOffset == 0) { + if (breakOffset == -1) { /* Jump to the start (jump over the jump to end) */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup); + JUMP4(JUMP, startFixup); /* Jump to the end (all BREAKs land here) */ - breakOffset = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + JUMP4(JUMP, breakOffset); /* Start */ - if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", - (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); - } + FIXJUMP4(startFixup); } envPtr->line = bline; - catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, catchRange); + + catchRange = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); ExceptionRangeStarts(envPtr, catchRange); + ExceptionRangeStarts(envPtr, loopRange); + + (envPtr)->exceptArrayPtr[loopRange].mainOffset = breakOffset; switch (tokenPtr->type) { case TCL_TOKEN_COMMAND: @@ -1544,96 +1534,43 @@ TclSubstCompile( tokenPtr->type); } + ExceptionRangeEnds(envPtr, loopRange); ExceptionRangeEnds(envPtr, catchRange); /* Substitution produced TCL_OK */ - OP( END_CATCH); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); - TclAdjustStackDepth(-1, envPtr); + JUMP4(JUMP, okFixup); /* Exceptional return codes processed here */ - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RESULT); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( RETURN_CODE_BRANCH); + /* Exceptional return codes processed here */ + + CatchTarget(envPtr, catchRange); + OP4( REVERSE, 3); + PUSH("1"); + OP( EQ); + JUMP4(JUMP_FALSE, returnFixup); /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ + OP4( REVERSE, 2); OP( RETURN_STK); - OP( NOP); - - /* RETURN */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); - - /* BREAK */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup); - - /* CONTINUE */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup); - - /* OTHER */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); - - TclAdjustStackDepth(1, envPtr); - /* BREAK destination */ - if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", - (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); - } - OP( POP); - OP( POP); - - breakJump = CurrentOffset(envPtr) - breakOffset; - if (breakJump > 127) { - OP4(JUMP4, -breakJump); - } else { - OP1(JUMP1, -breakJump); - } - TclAdjustStackDepth(2, envPtr); - /* CONTINUE destination */ - if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", - (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); - } - OP( POP); - OP( POP); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); - TclAdjustStackDepth(2, envPtr); - /* RETURN + other destination */ - if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", - (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); - } - if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", - (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); - } - - /* + /* RETURN + other destination * Pull the result to top of stack, discard options dict. */ - + FIXJUMP4(returnFixup); OP4( REVERSE, 2); OP( POP); /* OK destination */ - if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", - (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); - } + FIXJUMP4(okFixup); + if (count > 1) { OP1(STR_CONCAT1, count); count = 1; } /* CONTINUE jump to here */ - if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", - (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); - } + ContinueTarget(envPtr, loopRange); bline = envPtr->line; } @@ -1654,9 +1591,8 @@ TclSubstCompile( } /* Final target of the multi-jump from all BREAKs */ - if (breakOffset > 0) { - TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, - envPtr->codeStart + breakOffset); + if (breakOffset != -1) { + FIXJUMP4(breakOffset); } } @@ -2027,7 +1963,7 @@ IssueSwitchChainedTests( enum {Switch_Exact, Switch_Glob, Switch_Regexp}; int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ - JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ + int *fixupArray; /* Array of forward-jump fixup records. */ int *fixupTargetArray; /* Array of places for fixups to point at. */ int fixupCount; /* Number of places to fix up. */ int contFixIndex; /* Where the first of the jumps due to a group @@ -2045,7 +1981,7 @@ IssueSwitchChainedTests( contFixIndex = -1; contFixCount = 0; - fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens); + fixupArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens); fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens); memset(fixupTargetArray, 0, numBodyTokens * sizeof(int)); fixupCount = 0; @@ -2140,14 +2076,14 @@ IssueSwitchChainedTests( contFixIndex = fixupCount; contFixCount = 0; } - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, + TclEmitForwardJump(envPtr, JUMP_TRUE, &fixupArray[contFixIndex+contFixCount]); fixupCount++; contFixCount++; continue; } - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + TclEmitForwardJump(envPtr, JUMP_FALSE, &fixupArray[fixupCount]); nextArmFixupIndex = fixupCount; fixupCount++; @@ -2193,7 +2129,7 @@ IssueSwitchChainedTests( TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); if (!foundDefault) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + TclEmitForwardJump(envPtr, JUMP, &fixupArray[fixupCount]); fixupCount++; fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); @@ -2219,30 +2155,13 @@ IssueSwitchChainedTests( for (i=0 ; i<fixupCount ; i++) { if (fixupTargetArray[i] == 0) { - fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart; + TclFixupForwardJumpToHere(envPtr, fixupArray[i]); + } else { + TclFixupForwardJump(envPtr, fixupArray[i], + fixupTargetArray[i] - fixupArray[i]); } } - /* - * Now scan backwards over all the jumps (all of which are forward jumps) - * doing each one. When we do one and there is a size changes, we must - * scan back over all the previous ones and see if they need adjusting - * before proceeding with further jump fixups (the interleaved nature of - * all the jumps makes this impossible to do without nested loops). - */ - - for (i=fixupCount-1 ; i>=0 ; i--) { - if (TclFixupForwardJump(envPtr, &fixupArray[i], - fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { - int j; - - for (j=i-1 ; j>=0 ; j--) { - if (fixupTargetArray[j] > fixupArray[i].codeOffset) { - fixupTargetArray[j] += 3; - } - } - } - } TclStackFree(interp, fixupTargetArray); TclStackFree(interp, fixupArray); } @@ -2675,7 +2594,7 @@ TclCompileThrowCmd( OP4( REVERSE, 3); OP( DUP); OP( LIST_LENGTH); - OP1( JUMP_FALSE1, 16); + OP4( JUMP_FALSE4, 19); OP4( LIST, 2); OP44( RETURN_IMM, TCL_ERROR, 0); TclAdjustStackDepth(2, envPtr); @@ -2958,6 +2877,7 @@ IssueTryClausesInstructions( int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; int *noError; char buf[TCL_INTEGER_SPACE]; + int newTarget = -1; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -2984,31 +2904,31 @@ IssueTryClausesInstructions( * (and it's never called when there's a finally clause). */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); if (!trapZero) { - OP( END_CATCH); JUMP4( JUMP, afterBody); - TclAdjustStackDepth(-1, envPtr); } else { + STORE( resultVar); + OP( POP); + OP( PUSH_RETURN_OPTIONS); + STORE( optionsVar); + OP( POP); PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - TclAdjustStackDepth(-2, envPtr); + JUMP4( JUMP, newTarget); } - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( END_CATCH); + CatchTarget(envPtr, range); STORE( optionsVar); OP( POP); STORE( resultVar); OP( POP); + if (newTarget != -1) { + FIXJUMP4(newTarget); + } + /* * Now we handle all the registered 'on' and 'trap' handlers in order. * For us to be here, there must be at least one handler. @@ -3083,22 +3003,17 @@ IssueTryClausesInstructions( forwardsToFix[j] = -1; } } - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); BODY( handlerTokens[i], 5+i*4); ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); JUMP4( JUMP, noError[i]); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclAdjustStackDepth(-1, envPtr); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); + CatchTarget(envPtr, range); + OP4( REVERSE, 2); + OP4( REVERSE, 3); PUSH( "1"); OP( EQ); - JUMP1( JUMP_FALSE, dontChangeOptions); + JUMP4( JUMP_FALSE, dontChangeOptions); LOAD( optionsVar); OP4( REVERSE, 2); STORE( optionsVar); @@ -3107,8 +3022,7 @@ IssueTryClausesInstructions( OP4( REVERSE, 2); OP44( DICT_SET, 1, optionsVar); TclAdjustStackDepth(-1, envPtr); - FIXJUMP1( dontChangeOptions); - OP4( REVERSE, 2); + FIXJUMP4( dontChangeOptions); INVOKE( RETURN_STK); } @@ -3126,8 +3040,8 @@ IssueTryClausesInstructions( */ OP( POP); - LOAD( optionsVar); LOAD( resultVar); + LOAD( optionsVar); INVOKE( RETURN_STK); /* @@ -3168,6 +3082,7 @@ IssueTryClausesFinallyInstructions( int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; + int newTarget = -1; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -3192,13 +3107,11 @@ IssueTryClausesFinallyInstructions( * (if any trap matches) and run a finally clause. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); if (!trapZero) { - OP( END_CATCH); STORE( resultVar); OP( POP); PUSH( "-level 0 -code 0"); @@ -3206,21 +3119,26 @@ IssueTryClausesFinallyInstructions( OP( POP); JUMP4( JUMP, afterBody); } else { + STORE( resultVar); + OP( POP); + OP( PUSH_RETURN_OPTIONS); + STORE( optionsVar); + OP( POP); PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - TclAdjustStackDepth(-2, envPtr); + JUMP4( JUMP, newTarget); + TclAdjustStackDepth(-1, envPtr); } - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( END_CATCH); + CatchTarget(envPtr, range); STORE( optionsVar); OP( POP); STORE( resultVar); OP( POP); + if (newTarget != -1) { + FIXJUMP4(newTarget); + newTarget = -1; + } + /* * Now we handle all the registered 'on' and 'trap' handlers in order. * @@ -3268,8 +3186,7 @@ IssueTryClausesFinallyInstructions( */ if (resultVars[i] >= 0 || handlerTokens[i]) { - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); } if (resultVars[i] >= 0) { @@ -3290,7 +3207,6 @@ IssueTryClausesFinallyInstructions( */ ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); goto finishTrapCatchHandling; @@ -3314,7 +3230,7 @@ IssueTryClausesFinallyInstructions( if (forwardsNeedFixing) { forwardsNeedFixing = 0; - OP1( JUMP1, 7); + OP4( JUMP4, 10); for (j=0 ; j<i ; j++) { if (forwardsToFix[j] == -1) { continue; @@ -3322,14 +3238,13 @@ IssueTryClausesFinallyInstructions( FIXJUMP4( forwardsToFix[j]); forwardsToFix[j] = -1; } - OP4( BEGIN_CATCH4, range); } BODY( handlerTokens[i], 5+i*4); ExceptionRangeEnds(envPtr, range); PUSH( "0"); OP( PUSH_RETURN_OPTIONS); OP4( REVERSE, 3); - OP1( JUMP1, 5); + JUMP4(JUMP, newTarget); TclAdjustStackDepth(-3, envPtr); forwardsToFix[i] = -1; @@ -3341,16 +3256,17 @@ IssueTryClausesFinallyInstructions( */ finishTrapCatchHandling: - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); - OP( END_CATCH); + CatchTarget(envPtr, range); + OP4( REVERSE, 3); + OP4( REVERSE, 2); + if (newTarget != -1) { + FIXJUMP4(newTarget); + } STORE( resultVar); OP( POP); PUSH( "1"); OP( EQ); - JUMP1( JUMP_FALSE, noTrapError); + JUMP4( JUMP_FALSE, noTrapError); LOAD( optionsVar); PUSH( "-during"); OP4( REVERSE, 3); @@ -3358,10 +3274,10 @@ IssueTryClausesFinallyInstructions( OP( POP); OP44( DICT_SET, 1, optionsVar); TclAdjustStackDepth(-1, envPtr); - JUMP1( JUMP, trapError); - FIXJUMP1( noTrapError); + JUMP4( JUMP, trapError); + FIXJUMP4( noTrapError); STORE( optionsVar); - FIXJUMP1( trapError); + FIXJUMP4( trapError); /* Skip POP at end; can clean up with subsequent POP */ if (i+1 < numHandlers) { OP( POP); @@ -3402,22 +3318,18 @@ IssueTryClausesFinallyInstructions( if (!trapZero) { FIXJUMP4( afterBody); } - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); BODY( finallyToken, 3 + 4*numHandlers); ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); OP( POP); - JUMP1( JUMP, finalOK); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); + JUMP4( JUMP, finalOK); + CatchTarget(envPtr, range); + OP4( REVERSE, 2); + OP4( REVERSE, 3); PUSH( "1"); OP( EQ); - JUMP1( JUMP_FALSE, noFinalError); + JUMP4( JUMP_FALSE, noFinalError); LOAD( optionsVar); PUSH( "-during"); OP4( REVERSE, 3); @@ -3426,17 +3338,17 @@ IssueTryClausesFinallyInstructions( OP44( DICT_SET, 1, optionsVar); TclAdjustStackDepth(-1, envPtr); OP( POP); - JUMP1( JUMP, finalError); + JUMP4( JUMP, finalError); TclAdjustStackDepth(1, envPtr); - FIXJUMP1( noFinalError); + FIXJUMP4( noFinalError); STORE( optionsVar); OP( POP); - FIXJUMP1( finalError); + FIXJUMP4( finalError); STORE( resultVar); OP( POP); - FIXJUMP1( finalOK); - LOAD( optionsVar); + FIXJUMP4( finalOK); LOAD( resultVar); + LOAD( optionsVar); INVOKE( RETURN_STK); return TCL_OK; @@ -3450,52 +3362,47 @@ IssueTryFinallyInstructions( Tcl_Token *finallyToken) { DefineLineInformation; /* TIP #280 */ - int range, jumpOK, jumpSplice; + int range, jumpOK, jumpSplice, newTarget; /* * Note that this one is simple enough that we can issue it without * needing a local variable table, making it a universal compilation. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); - OP1( JUMP1, 3); - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); OP( PUSH_RETURN_OPTIONS); - OP( END_CATCH); - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + JUMP4( JUMP, newTarget); + CatchTarget(envPtr, range); + OP4( REVERSE, 2); + OP4( REVERSE, 3); + OP( POP); + FIXJUMP4( newTarget); + + range = TclCreateExceptRange(CATCH_EXCEPTION_FULL, envPtr); ExceptionRangeStarts(envPtr, range); BODY( finallyToken, 3); ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); OP( POP); - JUMP1( JUMP, jumpOK); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); + JUMP4( JUMP, jumpOK); + CatchTarget(envPtr, range); + OP4( REVERSE, 2); + OP4( REVERSE, 3); PUSH( "1"); OP( EQ); - JUMP1( JUMP_FALSE, jumpSplice); + JUMP4( JUMP_FALSE, jumpSplice); PUSH( "-during"); OP4( OVER, 3); OP4( LIST, 2); OP( LIST_CONCAT); - FIXJUMP1( jumpSplice); + FIXJUMP4( jumpSplice); OP4( REVERSE, 4); OP( POP); OP( POP); - OP1( JUMP1, 7); - FIXJUMP1( jumpOK); - OP4( REVERSE, 2); + OP4( REVERSE, 2); + FIXJUMP4( jumpOK); INVOKE( RETURN_STK); return TCL_OK; } @@ -3666,7 +3573,7 @@ TclCompileWhileCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *testTokenPtr, *bodyTokenPtr; - JumpFixup jumpEvalCondFixup; + int jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ @@ -3742,17 +3649,7 @@ TclCompileWhileCmd( */ if (loopMayEnd) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpEvalCondFixup); - testCodeOffset = 0; /* Avoid compiler warning. */ - } else { - /* - * Make sure that the first command in the body is preceded by an - * INST_START_CMD, and hence counted properly. [Bug 1752146] - */ - - envPtr->atCmdStart &= ~1; - testCodeOffset = CurrentOffset(envPtr); + TclEmitForwardJump(envPtr, JUMP, &jumpEvalCondFixup); } /* @@ -3760,10 +3657,6 @@ TclCompileWhileCmd( */ bodyCodeOffset = ExceptionRangeStarts(envPtr, range); - if (!loopMayEnd) { - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - } BODY(bodyTokenPtr, 2); ExceptionRangeEnds(envPtr, range); OP( POP); @@ -3775,27 +3668,17 @@ TclCompileWhileCmd( if (loopMayEnd) { testCodeOffset = CurrentOffset(envPtr); - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { - bodyCodeOffset += 3; - testCodeOffset += 3; - } + jumpDist = testCodeOffset - jumpEvalCondFixup; + TclFixupForwardJump(envPtr, jumpEvalCondFixup, jumpDist); SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { + testCodeOffset = bodyCodeOffset; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); - } + TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); } /* @@ -3804,8 +3687,7 @@ TclCompileWhileCmd( envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); + BreakTarget(envPtr, range); /* * The while command's result is an empty string. diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 50edbec..a29fcb4 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -487,13 +487,22 @@ static const unsigned char Lexeme[] = { */ typedef struct JumpList { - JumpFixup jump; /* Pass this argument to matching calls of + int jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; /* + * Macro to convert a jump to a different type + */ + +#define CONVERT_JUMP(which, type) \ + TclUpdateInstInt4AtPc(INST_##type##4, 0, \ + envPtr->codeStart + (which)) + + +/* * Declarations for local functions to this file: */ @@ -2290,17 +2299,16 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); + TclEmitForwardJump(envPtr, JUMP_FALSE, &jumpPtr->jump); break; case COLON: newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->jump); + TclEmitForwardJump(envPtr, JUMP, &jumpPtr->jump); TclAdjustStackDepth(-1, envPtr); if (convert) { - jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + CONVERT_JUMP(jumpPtr->jump, JUMP_TRUE); } convert = 1; break; @@ -2309,8 +2317,11 @@ CompileExprTree( newJump = TclStackAlloc(interp, sizeof(JumpList)); newJump->next = jumpPtr; jumpPtr = newJump; - TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); + if (nodePtr->lexeme == AND) { + TclEmitForwardJump(envPtr, JUMP_FALSE, &jumpPtr->jump); + } else { + TclEmitForwardJump(envPtr, JUMP_TRUE, &jumpPtr->jump); + } break; } } else { @@ -2355,19 +2366,19 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); - if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { - jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; + if (*(envPtr->codeStart + jumpPtr->jump) == + INST_JUMP_TRUE4) { + CONVERT_JUMP(jumpPtr->jump, JUMP); convert = 1; } - target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - target += 3; - } + target = jumpPtr->jump + 5; + TclFixupForwardJumpToHere(envPtr, jumpPtr->jump); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); - TclFixupForwardJump(envPtr, &jumpPtr->jump, - target - jumpPtr->jump.codeOffset, 127); + TclFixupForwardJump(envPtr, jumpPtr->jump, + target - jumpPtr->jump); freePtr = jumpPtr; jumpPtr = jumpPtr->next; @@ -2377,21 +2388,19 @@ CompileExprTree( case OR: CLANG_ASSERT(jumpPtr); pc1 = CurrentOffset(envPtr); - TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 - : INST_JUMP_TRUE1, 0, envPtr); + TclEmitInstInt4((nodePtr->lexeme == AND) ? INST_JUMP_FALSE4 + : INST_JUMP_TRUE4, 0, envPtr); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); pc2 = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, 0, envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); TclAdjustStackDepth(-1, envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + TclStoreInt4AtPtr(CurrentOffset(envPtr) - pc1, envPtr->codeStart + pc1 + 1); - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - pc2 += 3; - } + TclFixupForwardJumpToHere(envPtr, jumpPtr->jump); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + TclStoreInt4AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; freePtr = jumpPtr; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f62ec14..031300b 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -138,10 +138,6 @@ InstructionDesc const tclInstructionTable[] = { {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ - {"lor", 1, -1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"land", 1, -1, 0, {OPERAND_NONE}}, - /* Logical and: push (stknext && stktop) */ {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ {"bitxor", 1, -1, 0, {OPERAND_NONE}}, @@ -189,30 +185,12 @@ InstructionDesc const tclInstructionTable[] = { {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ - {"break", 1, 0, 0, {OPERAND_NONE}}, + {"break", 5, 0, 1, {OPERAND_INT4}}, /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ - {"continue", 1, 0, 0, {OPERAND_NONE}}, + {"continue", 5, 0, 1, {OPERAND_INT4}}, /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ - {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}}, - /* Initialize execution of a foreach loop. Operand is aux data index - * of the ForeachInfo structure for the foreach command. */ - {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}}, - /* "Step" or begin next iteration of foreach loop. Push 0 if to - * terminate loop, else push 1. */ - - {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, - /* Record start of catch with the operand's exception index. Push the - * current stack depth onto a special catch stack. */ - {"endCatch", 1, 0, 0, {OPERAND_NONE}}, - /* End of last catch. Pop the bytecode interpreter's catch stack. */ - {"pushResult", 1, +1, 0, {OPERAND_NONE}}, - /* Push the interpreter's object result onto the stack. */ - {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, - /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new - * object onto the stack. */ - {"streq", 1, -1, 0, {OPERAND_NONE}}, /* Str Equal: push (stknext eq stktop) */ {"strneq", 1, -1, 0, {OPERAND_NONE}}, @@ -287,9 +265,10 @@ InstructionDesc const tclInstructionTable[] = { * See the comments further down in this file, where INST_INVOKE_EXPANDED * is emitted. */ - {"expandStart", 1, 0, 0, {OPERAND_NONE}}, - /* Start of command with {*} (expanded) arguments */ - {"expandStkTop", 5, 0, 1, {OPERAND_UINT4}}, + {"expandStart", 5, 0, 1, {OPERAND_UINT4}}, + /* Start of command with {*} (expanded) arguments; operand is the + * current nominal stack depth, as seen by the compiler */ + {"expandStkTop", 1, 0, 0, {OPERAND_NONE}}, /* Expand the list at stacktop: push its elements on the stack */ {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, /* Invoke the command marked by the last 'expandStart' */ @@ -298,9 +277,6 @@ InstructionDesc const tclInstructionTable[] = { /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_OFFSET4, OPERAND_UINT4}}, - /* Start of bytecoded command: op is the length of the cmd's code, op2 - * is number of commands here */ {"listIn", 1, -1, 0, {OPERAND_NONE}}, /* List containment: push [lsearch stktop stknext]>=0) */ @@ -404,11 +380,6 @@ InstructionDesc const tclInstructionTable[] = { {"nop", 1, 0, 0, {OPERAND_NONE}}, /* Do nothing */ - {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, - /* Jump to next instruction based on the return code on top of stack - * ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7; - * Other non-OK: +9 - */ {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}}, /* Make scalar variable at index op2 in call frame cease to exist; @@ -542,10 +513,6 @@ InstructionDesc const tclInstructionTable[] = { * list and pushes that resulting list onto the stack. * Stack: ... list1 list2 => ... [lconcat list1 list2] */ - {"expandDrop", 1, 0, 0, {OPERAND_NONE}}, - /* Drops an element from the auxiliary stack, popping stack elements - * until the matching stack depth is reached. */ - /* New foreach implementation */ {"foreach_start", 5, +2, 1, {OPERAND_AUX4}}, /* Initialize execution of a foreach loop. Operand is aux data index @@ -663,6 +630,12 @@ InstructionDesc const tclInstructionTable[] = { /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ + {"clearRange", 5, 0, 1, {OPERAND_UINT4}}, + /* Removes expansions and stack elements to restore the state required + * for the corresponding range exception targets. The actual stack + * effect cannot be computed at compile time, as it depends on the + * expansions that may have occurred */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -683,15 +656,12 @@ static void EnterCmdStartData(CompileEnv *envPtr, static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); -static int IsCompactibleCompileEnv(Tcl_Interp *interp, - CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void StartExpanding(CompileEnv *envPtr); /* * TIP #280: Helper for building the per-word line information of all compiled @@ -775,7 +745,6 @@ TclSetByteCodeFromAny( * in frame. */ int length, result = TCL_OK; const char *stringPtr; - Proc *procPtr = iPtr->compiledProcPtr; ContLineLoc *clLocPtr; #ifdef TCL_COMPILE_DEBUG @@ -825,33 +794,13 @@ TclSetByteCodeFromAny( TclEmitOpcode(INST_DONE, &compEnv); /* - * Check for optimizations! - * - * Test if the generated code is free of most hazards; if so, recompile - * but with generation of INST_START_CMD disabled. This produces somewhat - * faster code in some cases, and more compact code in more. - */ - - if (Tcl_GetMaster(interp) == NULL && - !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME) - && IsCompactibleCompileEnv(interp, &compEnv)) { - TclFreeCompileEnv(&compEnv); - iPtr->compiledProcPtr = procPtr; - TclInitCompileEnv(interp, &compEnv, stringPtr, length, - iPtr->invokeCmdFramePtr, iPtr->invokeWord); - if (clLocPtr) { - compEnv.clNext = &clLocPtr->loc[0]; - } - compEnv.atCmdStart = 2; /* The disabling magic. */ - TclCompileScript(interp, stringPtr, length, &compEnv); - assert (compEnv.atCmdStart > 1); - TclEmitOpcode(INST_DONE, &compEnv); - assert (compEnv.atCmdStart > 1); - } - - /* * Apply some peephole optimizations that can cross specific/generic * instruction generator boundaries. + * + * TODO: should this go to InitByteCode instead? Compilations from + * CompileExprObj, ExecConstantExprTree, CompileAssembleObj currently skip + * the optimization ... certainly OK for the last two, iffy for the + * first? */ if (iPtr->extra.optimizer) { @@ -1126,77 +1075,6 @@ TclCleanupByteCode( } /* - * --------------------------------------------------------------------- - * - * IsCompactibleCompileEnv -- - * - * Checks to see if we may apply some basic compaction optimizations to a - * piece of bytecode. Idempotent. - * - * --------------------------------------------------------------------- - */ - -static int -IsCompactibleCompileEnv( - Tcl_Interp *interp, - CompileEnv *envPtr) -{ - unsigned char *pc; - int size; - - /* - * Special: procedures in the '::tcl' namespace (or its children) are - * considered to be well-behaved and so can have compaction applied even - * if it would otherwise be invalid. - */ - - if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL - && envPtr->procPtr->cmdPtr->nsPtr != NULL) { - Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr; - - if (strcmp(nsPtr->fullName, "::tcl") == 0 - || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) { - return 1; - } - } - - /* - * Go through and ensure that no operation involved can cause a desired - * change of bytecode sequence during running. This comes down to ensuring - * that there are no mapped variables (due to traces) or calls to external - * commands (traces, [uplevel] trickery). This is actually a very - * conservative check; it turns down a lot of code that is OK in practice. - */ - - for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { - switch (*pc) { - /* Invokes */ - case INST_INVOKE_STK1: - case INST_INVOKE_STK4: - case INST_INVOKE_EXPANDED: - case INST_INVOKE_REPLACE: - return 0; - /* Runtime evals */ - case INST_EVAL_STK: - case INST_EXPR_STK: - case INST_YIELD: - return 0; - /* Upvars */ - case INST_UPVAR: - case INST_NSUPVAR: - case INST_VARIABLE: - return 0; - default: - size = tclInstructionTable[*pc].numBytes; - assert (size > 0); - break; - } - } - - return 1; -} - -/* *---------------------------------------------------------------------- * * Tcl_SubstObj -- @@ -1428,8 +1306,7 @@ TclInitCompileEnv( envPtr->procPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = NULL; envPtr->numCommands = 0; - envPtr->exceptDepth = 0; - envPtr->maxExceptDepth = 0; + envPtr->expandDepth = 0; envPtr->maxStackDepth = 0; envPtr->currStackDepth = 0; TclInitLiteralTable(&envPtr->localLitTable); @@ -1445,7 +1322,6 @@ TclInitCompileEnv( envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; - envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; @@ -1453,8 +1329,6 @@ TclInitCompileEnv( envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; - envPtr->atCmdStart = 1; - envPtr->expandCount = 0; /* * TIP #280: Set up the extended command location information, based on @@ -1657,7 +1531,6 @@ TclFreeCompileEnv( } if (envPtr->mallocedExceptArray) { ckfree(envPtr->exceptArrayPtr); - ckfree(envPtr->exceptAuxArrayPtr); } if (envPtr->mallocedCmdMap) { ckfree(envPtr->cmdMapPtr); @@ -1857,7 +1730,8 @@ CompileExpanded( DefineLineInformation; int depth = TclGetStackDepth(envPtr); - StartExpanding(envPtr); + TclEmitInstInt4(INST_EXPAND_START, envPtr->currStackDepth, envPtr); + envPtr->expandDepth++; if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; @@ -1872,8 +1746,7 @@ CompileExpanded( if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); + TclEmitOpcode(INST_EXPAND_STKTOP, envPtr); } continue; } @@ -1902,6 +1775,7 @@ CompileExpanded( */ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); + envPtr->expandDepth--; TclCheckStackDepth(depth+1, envPtr); } @@ -1912,62 +1786,14 @@ CompileCmdCompileProc( Command *cmdPtr, CompileEnv *envPtr) { - int unwind = 0, incrOffset = -1; DefineLineInformation; int depth = TclGetStackDepth(envPtr); - /* - * Emit of the INST_START_CMD instruction is controlled by the value of - * envPtr->atCmdStart: - * - * atCmdStart == 2 : We are not using the INST_START_CMD instruction. - * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. - * : We do not need to emit another. Instead we - * : increment the number of cmds started at it (except - * : for the special case at the start of a script.) - * atCmdStart == 0 : The last instruction was something else. We need - * : to emit INST_START_CMD here. - */ - - switch (envPtr->atCmdStart) { - case 0: - unwind = tclInstructionTable[INST_START_CMD].numBytes; - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - incrOffset = envPtr->codeNext - envPtr->codeStart; - TclEmitInt4(0, envPtr); - break; - case 1: - if (envPtr->codeNext > envPtr->codeStart) { - incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; - } - break; - case 2: - /* Nothing to do */ - ; - } - if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { - if (incrOffset >= 0) { - /* - * We successfully compiled a command. Increment the number of - * commands that start at the currently active INST_START_CMD. - */ - - unsigned char *incrPtr = envPtr->codeStart + incrOffset; - unsigned char *startPtr = incrPtr - 5; - - TclIncrUInt4AtPtr(incrPtr, 1); - if (unwind) { - /* We started the INST_START_CMD. Record the code length. */ - TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); - } - } TclCheckStackDepth(depth+1, envPtr); return TCL_OK; } - envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ - /* * Throw out any line information generated by the failed compile attempt. */ @@ -2080,10 +1906,10 @@ CompileCommandTokens( Tcl_DecrRefCount(cmdObj); - TclEmitOpcode(INST_POP, envPtr); EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + TclEmitOpcode(INST_POP, envPtr); /* * TIP #280: Free full form of per-word line data and insert the reduced @@ -2225,7 +2051,6 @@ TclCompileScript( * here removes that trailing INST_POP. */ - envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; envPtr->currStackDepth++; } @@ -2778,7 +2603,6 @@ TclInitByteCodeObj( codePtr->numExceptRanges = envPtr->exceptArrayNext; codePtr->numAuxDataItems = envPtr->auxDataArrayNext; codePtr->numCmdLocBytes = cmdLocBytes; - codePtr->maxExceptDepth = envPtr->maxExceptDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; p += sizeof(ByteCode); @@ -3282,12 +3106,11 @@ EnterCmdWordData( int TclCreateExceptRange( - ExceptionRangeType type, /* The kind of ExceptionRange desired. */ + int type, /* The kind of ExceptionRange desired. */ register CompileEnv *envPtr)/* Points to CompileEnv for which to create a * new ExceptionRange structure. */ { register ExceptionRange *rangePtr; - register ExceptionAux *auxPtr; int index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { @@ -3299,16 +3122,12 @@ TclCreateExceptRange( size_t currBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); - size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); - size_t newBytes2 = newElems * sizeof(ExceptionAux); if (envPtr->mallocedExceptArray) { envPtr->exceptArrayPtr = ckrealloc(envPtr->exceptArrayPtr, newBytes); - envPtr->exceptAuxArrayPtr = - ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2); } else { /* * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must @@ -3316,12 +3135,9 @@ TclCreateExceptRange( */ ExceptionRange *newPtr = ckalloc(newBytes); - ExceptionAux *newPtr2 = ckalloc(newBytes2); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); - memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2); envPtr->exceptArrayPtr = newPtr; - envPtr->exceptAuxArrayPtr = newPtr2; envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayEnd = newElems; @@ -3329,298 +3145,17 @@ TclCreateExceptRange( envPtr->exceptArrayNext++; rangePtr = &envPtr->exceptArrayPtr[index]; - rangePtr->type = type; - rangePtr->nestingLevel = envPtr->exceptDepth; + rangePtr->stackDepth = -1; + rangePtr->flags = type; rangePtr->codeOffset = -1; rangePtr->numCodeBytes = -1; - rangePtr->breakOffset = -1; - rangePtr->continueOffset = -1; - rangePtr->catchOffset = -1; - auxPtr = &envPtr->exceptAuxArrayPtr[index]; - auxPtr->supportsContinue = 1; - auxPtr->stackDepth = envPtr->currStackDepth; - auxPtr->expandTarget = envPtr->expandCount; - auxPtr->expandTargetDepth = -1; - auxPtr->numBreakTargets = 0; - auxPtr->breakTargets = NULL; - auxPtr->allocBreakTargets = 0; - auxPtr->numContinueTargets = 0; - auxPtr->continueTargets = NULL; - auxPtr->allocContinueTargets = 0; - return index; -} - -/* - * --------------------------------------------------------------------- - * - * TclGetInnermostExceptionRange -- - * - * Returns the innermost exception range that covers the current code - * creation point, and (optionally) the stack depth that is expected at - * that point. Relies on the fact that the range has a numCodeBytes = -1 - * when it is being populated and that inner ranges come after outer - * ranges. - * - * --------------------------------------------------------------------- - */ - -ExceptionRange * -TclGetInnermostExceptionRange( - CompileEnv *envPtr, - int returnCode, - ExceptionAux **auxPtrPtr) -{ - int exnIdx = -1, i; - - for (i=0 ; i<envPtr->exceptArrayNext ; i++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; - - if (CurrentOffset(envPtr) >= rangePtr->codeOffset && - (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < - rangePtr->codeOffset+rangePtr->numCodeBytes) && - (returnCode != TCL_CONTINUE || - envPtr->exceptAuxArrayPtr[i].supportsContinue)) { - exnIdx = i; - } - } - if (exnIdx == -1) { - return NULL; - } - if (auxPtrPtr) { - *auxPtrPtr = &envPtr->exceptAuxArrayPtr[exnIdx]; - } - return &envPtr->exceptArrayPtr[exnIdx]; -} - -/* - * --------------------------------------------------------------------- - * - * TclAddLoopBreakFixup, TclAddLoopContinueFixup -- - * - * Adds a place that wants to break/continue to the loop exception range - * tracking that will be fixed up once the loop can be finalized. These - * functions will generate an INST_JUMP4 that will be fixed up during the - * loop finalization. - * - * --------------------------------------------------------------------- - */ - -void -TclAddLoopBreakFixup( - CompileEnv *envPtr, - ExceptionAux *auxPtr) -{ - int range = auxPtr - envPtr->exceptAuxArrayPtr; - - if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { - Tcl_Panic("trying to add 'break' fixup to full exception range"); - } - - if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) { - auxPtr->allocBreakTargets *= 2; - auxPtr->allocBreakTargets += 2; - if (auxPtr->breakTargets) { - auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets, - sizeof(int) * auxPtr->allocBreakTargets); - } else { - auxPtr->breakTargets = - ckalloc(sizeof(int) * auxPtr->allocBreakTargets); - } - } - auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); -} - -void -TclAddLoopContinueFixup( - CompileEnv *envPtr, - ExceptionAux *auxPtr) -{ - int range = auxPtr - envPtr->exceptAuxArrayPtr; - - if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { - Tcl_Panic("trying to add 'continue' fixup to full exception range"); - } - - if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) { - auxPtr->allocContinueTargets *= 2; - auxPtr->allocContinueTargets += 2; - if (auxPtr->continueTargets) { - auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets, - sizeof(int) * auxPtr->allocContinueTargets); - } else { - auxPtr->continueTargets = - ckalloc(sizeof(int) * auxPtr->allocContinueTargets); - } - } - auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = - CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); -} - -/* - * --------------------------------------------------------------------- - * - * TclCleanupStackForBreakContinue -- - * - * Ditch the extra elements from the auxiliary stack and the main stack. - * How to do this exactly depends on whether there are any elements on - * the auxiliary stack to pop. - * - * --------------------------------------------------------------------- - */ - -void -TclCleanupStackForBreakContinue( - CompileEnv *envPtr, - ExceptionAux *auxPtr) -{ - int savedStackDepth = envPtr->currStackDepth; - int toPop = envPtr->expandCount - auxPtr->expandTarget; - - if (toPop > 0) { - while (toPop --> 0) { - TclEmitOpcode(INST_EXPAND_DROP, envPtr); - } - TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, - envPtr); - envPtr->currStackDepth = auxPtr->expandTargetDepth; - } - toPop = envPtr->currStackDepth - auxPtr->stackDepth; - while (toPop --> 0) { - TclEmitOpcode(INST_POP, envPtr); - } - envPtr->currStackDepth = savedStackDepth; -} - -/* - * --------------------------------------------------------------------- - * - * StartExpanding -- - * - * Pushes an INST_EXPAND_START and does some additional housekeeping so - * that the [break] and [continue] compilers can use an exception-free - * issue to discard it. - * - * --------------------------------------------------------------------- - */ - -static void -StartExpanding( - CompileEnv *envPtr) -{ - int i; - - TclEmitOpcode(INST_EXPAND_START, envPtr); - - /* - * Update inner exception ranges with information about the environment - * where this expansion started. - */ - - for (i=0 ; i<envPtr->exceptArrayNext ; i++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; - ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; - - /* - * Ignore loops unless they're still being built. - */ - - if (rangePtr->codeOffset > CurrentOffset(envPtr)) { - continue; - } - if (rangePtr->numCodeBytes != -1) { - continue; - } - - /* - * Adequate condition: further out loops and further in exceptions - * don't actually need this information. - */ - - if (auxPtr->expandTarget == envPtr->expandCount) { - auxPtr->expandTargetDepth = envPtr->currStackDepth; - } - } - - /* - * There's now one more expansion being processed on the auxiliary stack. - */ - - envPtr->expandCount++; -} - -/* - * --------------------------------------------------------------------- - * - * TclFinalizeLoopExceptionRange -- - * - * Finalizes a loop exception range, binding the registered [break] and - * [continue] implementations so that they jump to the correct place. - * Note that this must only be called after *all* the exception range - * target offsets have been set. - * - * --------------------------------------------------------------------- - */ - -void -TclFinalizeLoopExceptionRange( - CompileEnv *envPtr, - int range) -{ - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range]; - ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range]; - int i, offset; - unsigned char *site; - - if (rangePtr->type != LOOP_EXCEPTION_RANGE) { - Tcl_Panic("trying to finalize a loop exception range"); - } - - /* - * Do the jump fixups. Note that these are always issued as INST_JUMP4 so - * there is no need to fuss around with updating code offsets. - */ - - for (i=0 ; i<auxPtr->numBreakTargets ; i++) { - site = envPtr->codeStart + auxPtr->breakTargets[i]; - offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; - TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); - } - for (i=0 ; i<auxPtr->numContinueTargets ; i++) { - site = envPtr->codeStart + auxPtr->continueTargets[i]; - if (rangePtr->continueOffset == -1) { - int j; - - /* - * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough - * space to do anything else. - */ - - *site = INST_CONTINUE; - for (j=0 ; j<4 ; j++) { - *++site = INST_NOP; - } - } else { - offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; - TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); - } - } - - /* - * Drop the arrays we were holding the only reference to. - */ - - if (auxPtr->breakTargets) { - ckfree(auxPtr->breakTargets); - auxPtr->breakTargets = NULL; - auxPtr->numBreakTargets = 0; - } - if (auxPtr->continueTargets) { - ckfree(auxPtr->continueTargets); - auxPtr->continueTargets = NULL; - auxPtr->numContinueTargets = 0; + rangePtr->mainOffset = -1; + if (type == LOOP_EXCEPTION_RANGE) { + rangePtr->continueOffset = -2; + } else { + rangePtr->continueOffset = -1; } + return index; } /* @@ -3719,7 +3254,7 @@ TclInitJumpFixupArray( /* Points to the JumpFixupArray structure to * initialize. */ { - fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; + fixupArrayPtr->fixup = fixupArrayPtr->staticCodeOffsets; fixupArrayPtr->next = 0; fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1; fixupArrayPtr->mallocedArray = 0; @@ -3757,9 +3292,9 @@ TclExpandJumpFixupArray( * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. */ - size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); + size_t currBytes = fixupArrayPtr->next * sizeof(int); int newElems = 2*(fixupArrayPtr->end + 1); - size_t newBytes = newElems * sizeof(JumpFixup); + size_t newBytes = newElems * sizeof(int); if (fixupArrayPtr->mallocedArray) { fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes); @@ -3769,7 +3304,7 @@ TclExpandJumpFixupArray( * ckrealloc equivalent for ourselves. */ - JumpFixup *newPtr = ckalloc(newBytes); + int *newPtr = ckalloc(newBytes); memcpy(newPtr, fixupArrayPtr->fixup, currBytes); fixupArrayPtr->fixup = newPtr; @@ -3808,203 +3343,6 @@ TclFreeJumpFixupArray( /* *---------------------------------------------------------------------- * - * TclEmitForwardJump -- - * - * Procedure to emit a two-byte forward jump of kind "jumpType". Since - * the jump may later have to be grown to five bytes if the jump target - * is more than, say, 127 bytes away, this procedure also initializes a - * JumpFixup record with information about the jump. - * - * Results: - * None. - * - * Side effects: - * The JumpFixup record pointed to by "jumpFixupPtr" is initialized with - * information needed later if the jump is to be grown. Also, a two byte - * jump of the designated type is emitted at the current point in the - * bytecode stream. - * - *---------------------------------------------------------------------- - */ - -void -TclEmitForwardJump( - CompileEnv *envPtr, /* Points to the CompileEnv structure that - * holds the resulting instruction. */ - TclJumpType jumpType, /* Indicates the kind of jump: if true or - * false or unconditional. */ - JumpFixup *jumpFixupPtr) /* Points to the JumpFixup structure to - * initialize with information about this - * forward jump. */ -{ - /* - * Initialize the JumpFixup structure: - * - codeOffset is offset of first byte of jump below - * - cmdIndex is index of the command after the current one - * - exceptIndex is the index of the first ExceptionRange after the - * current one. - */ - - jumpFixupPtr->jumpType = jumpType; - jumpFixupPtr->codeOffset = envPtr->codeNext - envPtr->codeStart; - jumpFixupPtr->cmdIndex = envPtr->numCommands; - jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; - - switch (jumpType) { - case TCL_UNCONDITIONAL_JUMP: - TclEmitInstInt1(INST_JUMP1, 0, envPtr); - break; - case TCL_TRUE_JUMP: - TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); - break; - default: - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - break; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclFixupForwardJump -- - * - * Procedure that updates a previously-emitted forward jump to jump a - * specified number of bytes, "jumpDist". If necessary, the jump is grown - * from two to five bytes; this is done if the jump distance is greater - * than "distThreshold" (normally 127 bytes). The jump is described by a - * JumpFixup record previously initialized by TclEmitForwardJump. - * - * Results: - * 1 if the jump was grown and subsequent instructions had to be moved; - * otherwise 0. This result is returned to allow callers to update any - * additional code offsets they may hold. - * - * Side effects: - * The jump may be grown and subsequent instructions moved. If this - * happens, the code offsets for any commands and any ExceptionRange - * records between the jump and the current code address will be updated - * to reflect the moved code. Also, the bytecode instruction array in the - * CompileEnv structure may be grown and reallocated. - * - *---------------------------------------------------------------------- - */ - -int -TclFixupForwardJump( - CompileEnv *envPtr, /* Points to the CompileEnv structure that - * holds the resulting instruction. */ - JumpFixup *jumpFixupPtr, /* Points to the JumpFixup structure that - * describes the forward jump. */ - int jumpDist, /* Jump distance to set in jump instr. */ - int distThreshold) /* Maximum distance before the two byte jump - * is grown to five bytes. */ -{ - unsigned char *jumpPc, *p; - int firstCmd, lastCmd, firstRange, lastRange, k; - unsigned numBytes; - - if (jumpDist <= distThreshold) { - jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; - switch (jumpFixupPtr->jumpType) { - case TCL_UNCONDITIONAL_JUMP: - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); - break; - case TCL_TRUE_JUMP: - TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); - break; - default: - TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); - break; - } - return 0; - } - - /* - * We must grow the jump then move subsequent instructions down. Note that - * if we expand the space for generated instructions, code addresses might - * change; be careful about updating any of these addresses held in - * variables. - */ - - if ((envPtr->codeNext + 3) > envPtr->codeEnd) { - TclExpandCodeArray(envPtr); - } - jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; - numBytes = envPtr->codeNext-jumpPc-2; - p = jumpPc+2; - memmove(p+3, p, numBytes); - - envPtr->codeNext += 3; - jumpDist += 3; - switch (jumpFixupPtr->jumpType) { - case TCL_UNCONDITIONAL_JUMP: - TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); - break; - case TCL_TRUE_JUMP: - TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); - break; - default: - TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); - break; - } - - /* - * Adjust the code offsets for any commands and any ExceptionRange records - * between the jump and the current code address. - */ - - firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = envPtr->numCommands - 1; - if (firstCmd < lastCmd) { - for (k = firstCmd; k <= lastCmd; k++) { - envPtr->cmdMapPtr[k].codeOffset += 3; - } - } - - firstRange = jumpFixupPtr->exceptIndex; - lastRange = envPtr->exceptArrayNext - 1; - for (k = firstRange; k <= lastRange; k++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[k]; - - rangePtr->codeOffset += 3; - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - rangePtr->breakOffset += 3; - if (rangePtr->continueOffset != -1) { - rangePtr->continueOffset += 3; - } - break; - case CATCH_EXCEPTION_RANGE: - rangePtr->catchOffset += 3; - break; - default: - Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d", - rangePtr->type); - } - } - - for (k = 0 ; k < envPtr->exceptArrayNext ; k++) { - ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; - int i; - - for (i=0 ; i<auxPtr->numBreakTargets ; i++) { - if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { - auxPtr->breakTargets[i] += 3; - } - } - for (i=0 ; i<auxPtr->numContinueTargets ; i++) { - if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { - auxPtr->continueTargets[i] += 3; - } - } - } - - return 1; /* the jump was grown */ -} - -/* - *---------------------------------------------------------------------- - * * TclEmitInvoke -- * * Emit one of the invoke-related instructions, wrapping it if necessary @@ -4017,8 +3355,8 @@ TclFixupForwardJump( * * Side effects: * Issues the jump with all correct stack management. May create another - * loop exception range; pointers to ExceptionRange and ExceptionAux - * structures should not be held across this call. + * loop exception range; pointers to ExceptionRange structures should not + * be held across this call. * *---------------------------------------------------------------------- */ @@ -4030,10 +3368,7 @@ TclEmitInvoke( ...) { va_list argList; - ExceptionRange *rangePtr; - ExceptionAux *auxBreakPtr, *auxContinuePtr; - int arg1, arg2, wordCount = 0, expandCount = 0; - int loopRange = 0, breakRange = 0, continueRange = 0; + int arg1, arg2; int cleanup, depth = TclGetStackDepth(envPtr); /* @@ -4043,74 +3378,36 @@ TclEmitInvoke( va_start(argList, opcode); switch (opcode) { case INST_INVOKE_STK1: - wordCount = arg1 = cleanup = va_arg(argList, int); + arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; case INST_INVOKE_STK4: - wordCount = arg1 = cleanup = va_arg(argList, int); + arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; case INST_INVOKE_REPLACE: arg1 = va_arg(argList, int); arg2 = va_arg(argList, int); - wordCount = arg1 + arg2 - 1; cleanup = arg1 + 1; break; default: Tcl_Panic("unexpected opcode"); case INST_EVAL_STK: - wordCount = cleanup = 1; + cleanup = 1; arg1 = arg2 = 0; break; case INST_RETURN_STK: - wordCount = cleanup = 2; + cleanup = 2; arg1 = arg2 = 0; break; case INST_INVOKE_EXPANDED: - wordCount = arg1 = cleanup = va_arg(argList, int); + arg1 = cleanup = va_arg(argList, int); arg2 = 0; - expandCount = 1; break; } va_end(argList); /* - * Determine if we need to handle break and continue exceptions with a - * special handling exception range (so that we can correctly unwind the - * stack). - * - * These must be done separately; they can be different (especially for - * calls from inside a [for] increment clause). - */ - - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, - &auxContinuePtr); - if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { - auxContinuePtr = NULL; - } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount - && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { - auxContinuePtr = NULL; - } else { - continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr; - } - - rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); - if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { - auxBreakPtr = NULL; - } else if (auxContinuePtr == NULL - && auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount - && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { - auxBreakPtr = NULL; - } else { - breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; - } - - if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - ExceptionRangeStarts(envPtr, loopRange); - } - - /* * Issue the invoke itself. */ @@ -4123,7 +3420,6 @@ TclEmitInvoke( break; case INST_INVOKE_EXPANDED: TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; TclAdjustStackDepth(1 - arg1, envPtr); break; case INST_EVAL_STK: @@ -4138,60 +3434,6 @@ TclEmitInvoke( TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ break; } - - /* - * If we're generating a special wrapper exception range, we need to - * finish that up now. - */ - - if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - int savedStackDepth = envPtr->currStackDepth; - int savedExpandCount = envPtr->expandCount; - JumpFixup nonTrapFixup; - - if (auxBreakPtr != NULL) { - auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; - } - if (auxContinuePtr != NULL) { - auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange; - } - - ExceptionRangeEnds(envPtr, loopRange); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); - - /* - * Careful! When generating these stack unwinding sequences, the depth - * of stack in the cases where they are taken is not the same as if - * the exception is not taken. - */ - - if (auxBreakPtr != NULL) { - TclAdjustStackDepth(-1, envPtr); - - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); - TclAddLoopBreakFixup(envPtr, auxBreakPtr); - TclAdjustStackDepth(1, envPtr); - - envPtr->currStackDepth = savedStackDepth; - envPtr->expandCount = savedExpandCount; - } - - if (auxContinuePtr != NULL) { - TclAdjustStackDepth(-1, envPtr); - - ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); - TclAddLoopContinueFixup(envPtr, auxContinuePtr); - TclAdjustStackDepth(1, envPtr); - - envPtr->currStackDepth = savedStackDepth; - envPtr->expandCount = savedExpandCount; - } - - TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); - } TclCheckStackDepth(depth+1-cleanup, envPtr); } @@ -4345,7 +3587,6 @@ TclInitAuxDataTypeTable(void) */ RegisterAuxDataType(&tclForeachInfoType); - RegisterAuxDataType(&tclNewForeachInfoType); RegisterAuxDataType(&tclJumptableInfoType); RegisterAuxDataType(&tclDictUpdateInfoType); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b89346d..0a34e34 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -69,92 +69,55 @@ MODULE_SCOPE const Tcl_ObjType tclLambdaType; * ExceptionRange structure describes a range of code (e.g., a loop body), the * kind of exceptions (e.g., a break or continue) that might occur, and the PC * offsets to jump to if a matching exception does occur. Exception ranges can - * nest so this structure includes a nesting level that is used at runtime to - * find the closest exception range surrounding a PC. For example, when a - * break command is executed, the ExceptionRange structure for the most deeply - * nested loop, if any, is found and used. These structures are also generated - * for the "next" subcommands of for loops since a break there terminates the - * for command. This means a for command actually generates two LoopInfo - * structures. - */ - -typedef enum { - LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. Break - * and continue "exceptions" cause jumps to - * appropriate PC offsets. */ - CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch - * command. Errors in the range cause a jump - * to a catch PC offset. */ -} ExceptionRangeType; + * nest, so we have to find the closest exception range surrounding a PC. For + * example, when a break command is executed, the ExceptionRange structure for + * the most deeply nested loop, if any, is found and used. + * + * The code ASSUMES that nested ranges come after their containing range in + * the arrays contained in CompileEnv and Bytecode structures, so this + * convention has to be respected by the compiler. The code also assumes that + * the range targets are *always* at the same stack depth as the range start. + * + * These structures are also generated for the "next" subcommands of for loops + * since a break there terminates the for command. This means a for command + * actually generates two of these structures. + */ + +/* + * Flags indicating the kind of ExceptionRange + */ + +#define LOOP_EXCEPTION_RANGE 0x00 +#define CATCH_EXCEPTION_RANGE 0x01 +#define CATCH_PUSH_RESULT 0x02 +#define CATCH_PUSH_OPTIONS 0x04 +#define CATCH_EXCEPTION_FULL 0x07 + +#define IS_CATCH_RANGE(rPtr) ((rPtr)->flags != 0) typedef struct ExceptionRange { - ExceptionRangeType type; /* The kind of ExceptionRange. */ - int nestingLevel; /* Static depth of the exception range. Used - * to find the most deeply-nested range - * surrounding a PC at runtime. */ + int stackDepth; /* Stack depth at range start and targets */ + int flags; /* Flags indicating the kind of ExceptionRange */ int codeOffset; /* Offset of the first instruction byte of the * code range. */ - int numCodeBytes; /* Number of bytes in the code range. */ - int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC - * offset for a break command in the range. */ + int numCodeBytes; /* Number of bytes in the code range. This is + * negative while compiling, before the range + * end is registered (used for keeping the + * initial expand depth, as a negative number) */ + int mainOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC + * offset for any "exception" in range. If + * LOOP_EXCEPTION_RANGE, the target PC offset + * for a break command in the range. */ int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the * target PC offset for a continue command in * the code range. Otherwise, ignore this * range when processing a continue - * command. */ - int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC - * offset for any "exception" in range. */ + * command. During compilation, it may have + * the value -2 to indicate that it will get + * a proper value later on. */ } ExceptionRange; /* - * Auxiliary data used when issuing (currently just loop) exception ranges, - * but which is not required during execution. - */ - -typedef struct ExceptionAux { - int supportsContinue; /* Whether this exception range will have a - * continueOffset created for it; if it is a - * loop exception range that *doesn't* have - * one (see [for] next-clause) then we must - * not pick up the range when scanning for a - * target to continue to. */ - int stackDepth; /* The stack depth at the point where the - * exception range was created. This is used - * to calculate the number of POPs required to - * restore the stack to its prior state. */ - int expandTarget; /* The number of expansions expected on the - * auxData stack at the time the loop starts; - * we can't currently discard them except by - * doing INST_INVOKE_EXPANDED; this is a known - * problem. */ - int expandTargetDepth; /* The stack depth expected at the outermost - * expansion within the loop. Not meaningful - * if there are no open expansions between the - * looping level and the point of jump - * issue. */ - int numBreakTargets; /* The number of [break]s that want to be - * targeted to the place where this loop - * exception will be bound to. */ - int *breakTargets; /* The offsets of the INST_JUMP4 instructions - * issued by the [break]s that we must - * update. Note that resizing a jump (via - * TclFixupForwardJump) can cause the contents - * of this array to be updated. When - * numBreakTargets==0, this is NULL. */ - int allocBreakTargets; /* The size of the breakTargets array. */ - int numContinueTargets; /* The number of [continue]s that want to be - * targeted to the place where this loop - * exception will be bound to. */ - int *continueTargets; /* The offsets of the INST_JUMP4 instructions - * issued by the [continue]s that we must - * update. Note that resizing a jump (via - * TclFixupForwardJump) can cause the contents - * of this array to be updated. When - * numContinueTargets==0, this is NULL. */ - int allocContinueTargets; /* The size of the continueTargets array. */ -} ExceptionAux; - -/* * Structure used to map between instruction pc and source locations. It * defines for each compiled Tcl command its code's starting offset and its * source's starting offset and length. Note that the code offset increases @@ -297,10 +260,7 @@ typedef struct CompileEnv { * information provided by ObjInterpProc in * tclProc.c. */ int numCommands; /* Number of commands compiled. */ - int exceptDepth; /* Current exception range nesting level; -1 - * if not in any range currently. */ - int maxExceptDepth; /* Max nesting level of exception ranges; -1 - * if no ranges have been compiled. */ + int expandDepth; /* Current expansion nesting level. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. Set by compilation * procedures before returning. */ @@ -333,11 +293,6 @@ typedef struct CompileEnv { * entry. */ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ - ExceptionAux *exceptAuxArrayPtr; - /* Array of information used to restore the - * state when processing BREAK/CONTINUE - * exceptions. Must be the same size as the - * exceptArrayPtr. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index @@ -359,9 +314,6 @@ typedef struct CompileEnv { /* Initial storage of LiteralEntry array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ - ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; - /* Initial static except auxiliary info array - * storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; @@ -372,16 +324,6 @@ typedef struct CompileEnv { int line; /* First line of the script, based on the * invoking context, then the line of the * command currently compiled. */ - int atCmdStart; /* Flag to say whether an INST_START_CMD - * should be issued; they should never be - * issued repeatedly, as that is significantly - * inefficient. If set to 2, that instruction - * should not be issued at all (by the generic - * part of the command compiler). */ - int expandCount; /* Number of INST_EXPAND_START instructions - * encountered that have not yet been paired - * with a corresponding - * INST_INVOKE_EXPANDED. */ int *clNext; /* If not NULL, it refers to the next slot in * clLoc to check for an invisible * continuation line. */ @@ -457,8 +399,6 @@ typedef struct ByteCode { int numAuxDataItems; /* Number of AuxData items. */ int numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ - int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; - * -1 if no ranges were compiled. */ int maxStackDepth; /* Maximum number of stack elements needed to * execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. This @@ -572,257 +512,244 @@ typedef struct ByteCode { #define INST_JUMP_FALSE4 39 /* Opcodes 40 to 64 */ -#define INST_LOR 40 -#define INST_LAND 41 -#define INST_BITOR 42 -#define INST_BITXOR 43 -#define INST_BITAND 44 -#define INST_EQ 45 -#define INST_NEQ 46 -#define INST_LT 47 -#define INST_GT 48 -#define INST_LE 49 -#define INST_GE 50 -#define INST_LSHIFT 51 -#define INST_RSHIFT 52 -#define INST_ADD 53 -#define INST_SUB 54 -#define INST_MULT 55 -#define INST_DIV 56 -#define INST_MOD 57 -#define INST_UPLUS 58 -#define INST_UMINUS 59 -#define INST_BITNOT 60 -#define INST_LNOT 61 -#define INST_CALL_BUILTIN_FUNC1 62 -#define INST_CALL_FUNC1 63 -#define INST_TRY_CVT_TO_NUMERIC 64 +#define INST_BITOR 40 +#define INST_BITXOR 41 +#define INST_BITAND 42 +#define INST_EQ 43 +#define INST_NEQ 44 +#define INST_LT 45 +#define INST_GT 46 +#define INST_LE 47 +#define INST_GE 48 +#define INST_LSHIFT 49 +#define INST_RSHIFT 50 +#define INST_ADD 51 +#define INST_SUB 52 +#define INST_MULT 53 +#define INST_DIV 54 +#define INST_MOD 55 +#define INST_UPLUS 56 +#define INST_UMINUS 57 +#define INST_BITNOT 58 +#define INST_LNOT 59 +#define INST_CALL_BUILTIN_FUNC1 60 +#define INST_CALL_FUNC1 61 +#define INST_TRY_CVT_TO_NUMERIC 62 /* Opcodes 65 to 66 */ -#define INST_BREAK 65 -#define INST_CONTINUE 66 - -/* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 67 /* DEPRECATED */ -#define INST_FOREACH_STEP4 68 /* DEPRECATED */ +#define INST_BREAK 63 +#define INST_CONTINUE 64 /* Opcodes 69 to 72 */ -#define INST_BEGIN_CATCH4 69 -#define INST_END_CATCH 70 -#define INST_PUSH_RESULT 71 -#define INST_PUSH_RETURN_CODE 72 /* Opcodes 73 to 78 */ -#define INST_STR_EQ 73 -#define INST_STR_NEQ 74 -#define INST_STR_CMP 75 -#define INST_STR_LEN 76 -#define INST_STR_INDEX 77 -#define INST_STR_MATCH 78 +#define INST_STR_EQ 65 +#define INST_STR_NEQ 66 +#define INST_STR_CMP 67 +#define INST_STR_LEN 68 +#define INST_STR_INDEX 69 +#define INST_STR_MATCH 70 /* Opcodes 78 to 81 */ -#define INST_LIST 79 -#define INST_LIST_INDEX 80 -#define INST_LIST_LENGTH 81 +#define INST_LIST 71 +#define INST_LIST_INDEX 72 +#define INST_LIST_LENGTH 73 /* Opcodes 82 to 87 */ -#define INST_APPEND_SCALAR1 82 -#define INST_APPEND_SCALAR4 83 -#define INST_APPEND_ARRAY1 84 -#define INST_APPEND_ARRAY4 85 -#define INST_APPEND_ARRAY_STK 86 -#define INST_APPEND_STK 87 +#define INST_APPEND_SCALAR1 74 +#define INST_APPEND_SCALAR4 75 +#define INST_APPEND_ARRAY1 76 +#define INST_APPEND_ARRAY4 77 +#define INST_APPEND_ARRAY_STK 78 +#define INST_APPEND_STK 79 /* Opcodes 88 to 93 */ -#define INST_LAPPEND_SCALAR1 88 -#define INST_LAPPEND_SCALAR4 89 -#define INST_LAPPEND_ARRAY1 90 -#define INST_LAPPEND_ARRAY4 91 -#define INST_LAPPEND_ARRAY_STK 92 -#define INST_LAPPEND_STK 93 +#define INST_LAPPEND_SCALAR1 80 +#define INST_LAPPEND_SCALAR4 81 +#define INST_LAPPEND_ARRAY1 82 +#define INST_LAPPEND_ARRAY4 83 +#define INST_LAPPEND_ARRAY_STK 84 +#define INST_LAPPEND_STK 85 /* TIP #22 - LINDEX operator with flat arg list */ -#define INST_LIST_INDEX_MULTI 94 +#define INST_LIST_INDEX_MULTI 86 /* * TIP #33 - 'lset' command. Code gen also required a Forth-like * OVER operation. */ -#define INST_OVER 95 -#define INST_LSET_LIST 96 -#define INST_LSET_FLAT 97 +#define INST_OVER 87 +#define INST_LSET_LIST 88 +#define INST_LSET_FLAT 89 /* TIP#90 - 'return' command. */ -#define INST_RETURN_IMM 98 +#define INST_RETURN_IMM 90 /* TIP#123 - exponentiation operator. */ -#define INST_EXPON 99 +#define INST_EXPON 91 /* TIP #157 - {*}... (word expansion) language syntax support. */ -#define INST_EXPAND_START 100 -#define INST_EXPAND_STKTOP 101 -#define INST_INVOKE_EXPANDED 102 +#define INST_EXPAND_START 92 +#define INST_EXPAND_STKTOP 93 +#define INST_INVOKE_EXPANDED 94 /* * TIP #57 - 'lassign' command. Code generation requires immediate * LINDEX and LRANGE operators. */ -#define INST_LIST_INDEX_IMM 103 -#define INST_LIST_RANGE_IMM 104 - -#define INST_START_CMD 105 +#define INST_LIST_INDEX_IMM 95 +#define INST_LIST_RANGE_IMM 96 -#define INST_LIST_IN 106 -#define INST_LIST_NOT_IN 107 +#define INST_LIST_IN 97 +#define INST_LIST_NOT_IN 98 -#define INST_PUSH_RETURN_OPTIONS 108 -#define INST_RETURN_STK 109 +#define INST_PUSH_RETURN_OPTIONS 99 +#define INST_RETURN_STK 100 /* * Dictionary (TIP#111) related commands. */ -#define INST_DICT_GET 110 -#define INST_DICT_SET 111 -#define INST_DICT_UNSET 112 -#define INST_DICT_INCR_IMM 113 -#define INST_DICT_APPEND 114 -#define INST_DICT_LAPPEND 115 -#define INST_DICT_FIRST 116 -#define INST_DICT_NEXT 117 -#define INST_DICT_DONE 118 -#define INST_DICT_UPDATE_START 119 -#define INST_DICT_UPDATE_END 120 +#define INST_DICT_GET 101 +#define INST_DICT_SET 102 +#define INST_DICT_UNSET 103 +#define INST_DICT_INCR_IMM 104 +#define INST_DICT_APPEND 105 +#define INST_DICT_LAPPEND 106 +#define INST_DICT_FIRST 107 +#define INST_DICT_NEXT 108 +#define INST_DICT_DONE 109 +#define INST_DICT_UPDATE_START 110 +#define INST_DICT_UPDATE_END 111 /* * Instruction to support jumps defined by tables (instead of the classic * [switch] technique of chained comparisons). */ -#define INST_JUMP_TABLE 121 +#define INST_JUMP_TABLE 112 /* * Instructions to support compilation of global, variable, upvar and * [namespace upvar]. */ -#define INST_UPVAR 122 -#define INST_NSUPVAR 123 -#define INST_VARIABLE 124 +#define INST_UPVAR 113 +#define INST_NSUPVAR 114 +#define INST_VARIABLE 115 /* Instruction to support compiling syntax error to bytecode */ -#define INST_SYNTAX 125 +#define INST_SYNTAX 116 /* Instruction to reverse N items on top of stack */ -#define INST_REVERSE 126 +#define INST_REVERSE 117 /* regexp instruction */ -#define INST_REGEXP 127 +#define INST_REGEXP 118 /* For [info exists] compilation */ -#define INST_EXIST_SCALAR 128 -#define INST_EXIST_ARRAY 129 -#define INST_EXIST_ARRAY_STK 130 -#define INST_EXIST_STK 131 +#define INST_EXIST_SCALAR 119 +#define INST_EXIST_ARRAY 120 +#define INST_EXIST_ARRAY_STK 121 +#define INST_EXIST_STK 122 /* For [subst] compilation */ -#define INST_NOP 132 -#define INST_RETURN_CODE_BRANCH 133 +#define INST_NOP 123 /* For [unset] compilation */ -#define INST_UNSET_SCALAR 134 -#define INST_UNSET_ARRAY 135 -#define INST_UNSET_ARRAY_STK 136 -#define INST_UNSET_STK 137 +#define INST_UNSET_SCALAR 124 +#define INST_UNSET_ARRAY 125 +#define INST_UNSET_ARRAY_STK 126 +#define INST_UNSET_STK 127 /* For [dict with], [dict exists], [dict create] and [dict merge] */ -#define INST_DICT_EXPAND 138 -#define INST_DICT_RECOMBINE_STK 139 -#define INST_DICT_RECOMBINE_IMM 140 -#define INST_DICT_EXISTS 141 -#define INST_DICT_VERIFY 142 +#define INST_DICT_EXPAND 128 +#define INST_DICT_RECOMBINE_STK 129 +#define INST_DICT_RECOMBINE_IMM 130 +#define INST_DICT_EXISTS 131 +#define INST_DICT_VERIFY 132 /* For [string map] and [regsub] compilation */ -#define INST_STR_MAP 143 -#define INST_STR_FIND 144 -#define INST_STR_FIND_LAST 145 -#define INST_STR_RANGE_IMM 146 -#define INST_STR_RANGE 147 +#define INST_STR_MAP 133 +#define INST_STR_FIND 134 +#define INST_STR_FIND_LAST 135 +#define INST_STR_RANGE_IMM 136 +#define INST_STR_RANGE 137 /* For operations to do with coroutines and other NRE-manipulators */ -#define INST_YIELD 148 -#define INST_COROUTINE_NAME 149 -#define INST_TAILCALL 150 +#define INST_YIELD 138 +#define INST_COROUTINE_NAME 139 +#define INST_TAILCALL 140 /* For compilation of basic information operations */ -#define INST_NS_CURRENT 151 -#define INST_INFO_LEVEL_NUM 152 -#define INST_INFO_LEVEL_ARGS 153 -#define INST_RESOLVE_COMMAND 154 +#define INST_NS_CURRENT 141 +#define INST_INFO_LEVEL_NUM 142 +#define INST_INFO_LEVEL_ARGS 143 +#define INST_RESOLVE_COMMAND 144 /* For compilation relating to TclOO */ -#define INST_TCLOO_SELF 155 -#define INST_TCLOO_CLASS 156 -#define INST_TCLOO_NS 157 -#define INST_TCLOO_IS_OBJECT 158 +#define INST_TCLOO_SELF 145 +#define INST_TCLOO_CLASS 146 +#define INST_TCLOO_NS 147 +#define INST_TCLOO_IS_OBJECT 148 /* For compilation of [array] subcommands */ -#define INST_ARRAY_EXISTS_STK 159 -#define INST_ARRAY_EXISTS_IMM 160 -#define INST_ARRAY_MAKE_STK 161 -#define INST_ARRAY_MAKE_IMM 162 +#define INST_ARRAY_EXISTS_STK 149 +#define INST_ARRAY_EXISTS_IMM 150 +#define INST_ARRAY_MAKE_STK 151 +#define INST_ARRAY_MAKE_IMM 152 -#define INST_INVOKE_REPLACE 163 +#define INST_INVOKE_REPLACE 153 -#define INST_LIST_CONCAT 164 - -#define INST_EXPAND_DROP 165 +#define INST_LIST_CONCAT 154 /* New foreach implementation */ -#define INST_FOREACH_START 166 -#define INST_FOREACH_STEP 167 -#define INST_FOREACH_END 168 -#define INST_LMAP_COLLECT 169 +#define INST_FOREACH_START 155 +#define INST_FOREACH_STEP 156 +#define INST_FOREACH_END 157 +#define INST_LMAP_COLLECT 158 /* For compilation of [string trim] and related */ -#define INST_STR_TRIM 170 -#define INST_STR_TRIM_LEFT 171 -#define INST_STR_TRIM_RIGHT 172 +#define INST_STR_TRIM 159 +#define INST_STR_TRIM_LEFT 160 +#define INST_STR_TRIM_RIGHT 161 + +#define INST_CONCAT_STK 162 -#define INST_CONCAT_STK 173 +#define INST_STR_UPPER 163 +#define INST_STR_LOWER 164 +#define INST_STR_TITLE 165 +#define INST_STR_REPLACE 166 -#define INST_STR_UPPER 174 -#define INST_STR_LOWER 175 -#define INST_STR_TITLE 176 -#define INST_STR_REPLACE 177 +#define INST_ORIGIN_COMMAND 167 -#define INST_ORIGIN_COMMAND 178 +#define INST_TCLOO_NEXT 168 +#define INST_TCLOO_NEXT_CLASS 169 -#define INST_TCLOO_NEXT 179 -#define INST_TCLOO_NEXT_CLASS 180 +#define INST_YIELD_TO_INVOKE 170 -#define INST_YIELD_TO_INVOKE 181 +#define INST_NUM_TYPE 171 +#define INST_TRY_CVT_TO_BOOLEAN 172 +#define INST_STR_CLASS 173 -#define INST_NUM_TYPE 182 -#define INST_TRY_CVT_TO_BOOLEAN 183 -#define INST_STR_CLASS 184 +#define INST_LAPPEND_LIST 174 +#define INST_LAPPEND_LIST_ARRAY 175 +#define INST_LAPPEND_LIST_ARRAY_STK 176 +#define INST_LAPPEND_LIST_STK 177 -#define INST_LAPPEND_LIST 185 -#define INST_LAPPEND_LIST_ARRAY 186 -#define INST_LAPPEND_LIST_ARRAY_STK 187 -#define INST_LAPPEND_LIST_STK 188 +#define INST_CLEAR_RANGE 178 /* The last opcode */ -#define LAST_INST_OPCODE 188 +#define LAST_INST_OPCODE 178 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -920,38 +847,15 @@ MODULE_SCOPE StringClassDesc const tclStringClassTable[]; * commands between the jump and the target. */ -typedef enum { - TCL_UNCONDITIONAL_JUMP, - TCL_TRUE_JUMP, - TCL_FALSE_JUMP -} TclJumpType; - -typedef struct JumpFixup { - TclJumpType jumpType; /* Indicates the kind of jump. */ - int codeOffset; /* Offset of the first byte of the one-byte - * forward jump's code. */ - int cmdIndex; /* Index of the first command after the one - * for which the jump was emitted. Used to - * update the code offsets for subsequent - * commands if the two-byte jump at jumpPc - * must be replaced with a five-byte one. */ - int exceptIndex; /* Index of the first range entry in the - * ExceptionRange array after the current one. - * This field is used to adjust the code - * offsets in subsequent ExceptionRange - * records when a jump is grown from 2 bytes - * to 5 bytes. */ -} JumpFixup; - #define JUMPFIXUP_INIT_ENTRIES 10 typedef struct JumpFixupArray { - JumpFixup *fixup; /* Points to start of jump fixup array. */ + int *fixup; /* Points to start of codeOffset array. */ int next; /* Index of next free array entry. */ int end; /* Index of last usable entry in array. */ int mallocedArray; /* 1 if array was expanded and fixups points * into the heap, else 0. */ - JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; + int staticCodeOffsets[JUMPFIXUP_INIT_ENTRIES]; /* Initial storage for jump fixup array. */ } JumpFixupArray; @@ -980,23 +884,18 @@ typedef struct ForeachVarList { */ typedef struct ForeachInfo { + int jumpSize; /* Size of the jump between the the start of + * the range and the continue target. */ int numLists; /* The number of both the variable and value * lists of the foreach command. */ - int firstValueTemp; /* Index of the first temp var in a proc frame - * used to point to a value list. */ - int loopCtTemp; /* Index of temp var in a proc frame holding - * the loop's iteration count. Used to - * determine next value list element to assign - * each loop var. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large - * enough to numVars indexes. THIS MUST BE THE - * LAST FIELD IN THE STRUCTURE! */ + * enough contain to numLists structs. THIS + * MUST BE THE LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; MODULE_SCOPE const AuxDataType tclForeachInfoType; -MODULE_SCOPE const AuxDataType tclNewForeachInfoType; #define FOREACHINFO(envPtr, index) \ ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) @@ -1079,8 +978,6 @@ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); -MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, - ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); @@ -1104,8 +1001,7 @@ MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE int TclCreateAuxData(ClientData clientData, const AuxDataType *typePtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, - CompileEnv *envPtr); +MODULE_SCOPE int TclCreateExceptRange(int type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, int length, unsigned int hash, int *newPtr, @@ -1114,11 +1010,9 @@ MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); -MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, - TclJumpType jumpType, JumpFixup *jumpFixupPtr); MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...); -MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, - int catchOnly, ByteCode *codePtr); +MODULE_SCOPE ExceptionRange * TclGetExceptionRange(int pcOffset, int catchOnly, + ExceptionRange *startPtr, ExceptionRange *endPtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); @@ -1126,9 +1020,6 @@ MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); -MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, - JumpFixup *jumpFixupPtr, int jumpDist, - int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitAuxDataTypeTable(void); @@ -1139,14 +1030,7 @@ MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, int numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); -MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, - int returnCode, ExceptionAux **auxPtrPtr); -MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, - ExceptionAux *auxPtr); -MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr, - ExceptionAux *auxPtr); -MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, - int range); + #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); @@ -1300,18 +1184,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, } while (0) /* - * Macros used to update the flag that indicates if we are at the start of a - * command, based on whether the opcode is INST_START_COMMAND. - * - * void TclUpdateAtCmdStart(unsigned char op, CompileEnv *envPtr); - */ - -#define TclUpdateAtCmdStart(op, envPtr) \ - if ((envPtr)->atCmdStart < 2) { \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD ? 1 : 0); \ - } - -/* * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C * "prototype" for this macro is: * @@ -1324,7 +1196,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, TclExpandCodeArray(envPtr); \ } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ - TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, 0, envPtr); \ } while (0) @@ -1376,7 +1247,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, i, envPtr); \ } while (0) @@ -1394,7 +1264,6 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, (unsigned char) ((unsigned int) (i) >> 8); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) ); \ - TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, i, envPtr); \ } while (0) @@ -1410,11 +1279,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define TclEmitPush(objIndex, envPtr) \ do { \ register int objIndexCopy = (objIndex); \ - if (objIndexCopy <= 255) { \ - TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \ - } else { \ - TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ - } \ + TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ } while (0) /* @@ -1467,10 +1332,30 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, * int threshold); */ -#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ - TclFixupForwardJump((envPtr), (fixupPtr), \ - (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ - (threshold)) +#define TclEmitForwardJump(envPtr, type, pcPtr) \ + *(pcPtr) = (envPtr)->codeNext - (envPtr)->codeStart; \ + TclEmitInstInt4(INST_##type##4, 0, (envPtr)) + +#define TclEmitForwardJump1(envPtr, type, pcPtr) \ + *(pcPtr) = (envPtr)->codeNext - (envPtr)->codeStart; \ + TclEmitInstInt1(INST_##type##1, 0, (envPtr)) + +#define TclFixupForwardJump(envPtr, pc, jumpDist) \ + TclStoreInt4AtPtr((jumpDist), (envPtr)->codeStart + (pc) + 1) + +#define TclFixupForwardJump1(envPtr, pc, jumpDist) \ + if (((jumpDist) > 127) && ((jumpDist) < -127)) { \ + Tcl_Panic("TclFixupForwardJump1: bad jump distance %li", jumpDist); \ + } \ + TclStoreInt1AtPtr((jumpDist), (envPtr)->codeStart + (pc) + 1) + +#define TclFixupForwardJumpToHere(envPtr, fixup) \ + TclFixupForwardJump((envPtr), (fixup), \ + (envPtr)->codeNext-(envPtr)->codeStart-(fixup)) + +#define TclFixupForwardJumpToHere1(envPtr, fixup) \ + TclFixupForwardJump1((envPtr), (fixup), \ + (envPtr)->codeNext-(envPtr)->codeStart-(fixup)) /* * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int @@ -1585,28 +1470,42 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, ((envPtr)->codeNext - (envPtr)->codeStart) /* - * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the - * maximal depth of nested CATCH ranges in order to alloc runtime - * memory. These macros should compute precisely that? OTOH, the nesting depth - * of LOOP ranges is an interesting datum for debugging purposes, and that is - * what we compute now. - * * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); */ -#define ExceptionRangeStarts(envPtr, index) \ - (((envPtr)->exceptDepth++), \ - ((envPtr)->maxExceptDepth = \ - TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ +#define ExceptionRangeStarts(envPtr, index) \ + (((envPtr)->exceptArrayPtr[(index)].stackDepth = (envPtr)->currStackDepth), \ + ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = ~(envPtr)->expandDepth), \ ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) -#define ExceptionRangeEnds(envPtr, index) \ - (((envPtr)->exceptDepth--), \ + +#define ExceptionRangeEnds(envPtr, index) \ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ - CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) -#define ExceptionRangeTarget(envPtr, index, targetType) \ - ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) + CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset) + +#define CatchTarget(envPtr, index) \ + do { \ + ExceptionRange *rPtr = &(envPtr)->exceptArrayPtr[(index)]; \ + (envPtr)->currStackDepth = rPtr->stackDepth + 1 + \ + ((rPtr->flags&CATCH_PUSH_RESULT)? 1 : 0) + \ + ((rPtr->flags&CATCH_PUSH_OPTIONS)? 1 : 0); \ + rPtr->mainOffset = CurrentOffset(envPtr); \ + } while (0) + +#define BreakTarget(envPtr, index) \ + do { \ + ExceptionRange *rPtr = &(envPtr)->exceptArrayPtr[(index)]; \ + (envPtr)->currStackDepth = rPtr->stackDepth; \ + rPtr->mainOffset = CurrentOffset(envPtr); \ + } while (0) + +#define ContinueTarget(envPtr, index) \ + do { \ + ExceptionRange *rPtr = &(envPtr)->exceptArrayPtr[(index)]; \ + (envPtr)->currStackDepth = rPtr->stackDepth; \ + rPtr->continueOffset = CurrentOffset(envPtr); \ + } while (0) /* * Check if there is an LVT for compiled locals diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b022d3c..64c1c67 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1516,9 +1516,7 @@ EXTERN int Tcl_LimitReady(Tcl_Interp *interp); EXTERN int Tcl_LimitCheck(Tcl_Interp *interp); /* 524 */ EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp); -/* 525 */ -EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp, - int commandLimit); +/* Slot 525 is reserved */ /* 526 */ EXTERN void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); @@ -1533,8 +1531,7 @@ EXTERN int Tcl_LimitTypeExceeded(Tcl_Interp *interp, int type); EXTERN void Tcl_LimitTypeSet(Tcl_Interp *interp, int type); /* 531 */ EXTERN void Tcl_LimitTypeReset(Tcl_Interp *interp, int type); -/* 532 */ -EXTERN int Tcl_LimitGetCommands(Tcl_Interp *interp); +/* Slot 532 is reserved */ /* 533 */ EXTERN void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); @@ -2376,14 +2373,14 @@ typedef struct TclStubs { int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */ int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */ - void (*tcl_LimitSetCommands) (Tcl_Interp *interp, int commandLimit); /* 525 */ + void (*reserved525)(void); void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */ void (*tcl_LimitSetGranularity) (Tcl_Interp *interp, int type, int granularity); /* 527 */ int (*tcl_LimitTypeEnabled) (Tcl_Interp *interp, int type); /* 528 */ int (*tcl_LimitTypeExceeded) (Tcl_Interp *interp, int type); /* 529 */ void (*tcl_LimitTypeSet) (Tcl_Interp *interp, int type); /* 530 */ void (*tcl_LimitTypeReset) (Tcl_Interp *interp, int type); /* 531 */ - int (*tcl_LimitGetCommands) (Tcl_Interp *interp); /* 532 */ + void (*reserved532)(void); void (*tcl_LimitGetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 533 */ int (*tcl_LimitGetGranularity) (Tcl_Interp *interp, int type); /* 534 */ Tcl_InterpState (*tcl_SaveInterpState) (Tcl_Interp *interp, int status); /* 535 */ @@ -3562,8 +3559,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_LimitCheck) /* 523 */ #define Tcl_LimitExceeded \ (tclStubsPtr->tcl_LimitExceeded) /* 524 */ -#define Tcl_LimitSetCommands \ - (tclStubsPtr->tcl_LimitSetCommands) /* 525 */ +/* Slot 525 is reserved */ #define Tcl_LimitSetTime \ (tclStubsPtr->tcl_LimitSetTime) /* 526 */ #define Tcl_LimitSetGranularity \ @@ -3576,8 +3572,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_LimitTypeSet) /* 530 */ #define Tcl_LimitTypeReset \ (tclStubsPtr->tcl_LimitTypeReset) /* 531 */ -#define Tcl_LimitGetCommands \ - (tclStubsPtr->tcl_LimitGetCommands) /* 532 */ +/* Slot 532 is reserved */ #define Tcl_LimitGetTime \ (tclStubsPtr->tcl_LimitGetTime) /* 533 */ #define Tcl_LimitGetGranularity \ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 86f0e1d..8190100 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -286,29 +286,24 @@ TclDisassembleByteCodeObj( */ if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d\n", + codePtr->numExceptRanges); for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", - i, rangePtr->nestingLevel, - (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), + " %d: %s, pc %d-%d, stkDepth %d, ", + i, + (IS_CATCH_RANGE(rangePtr) ? "catch" : "loop"), rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1), + rangePtr->stackDepth); + if (IS_CATCH_RANGE(rangePtr)) { Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", - rangePtr->catchOffset); - break; - default: - Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", - rangePtr->type); + rangePtr->mainOffset); + } else { + Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->mainOffset); } } } @@ -502,10 +497,6 @@ FormatInstruction( break; case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_START_CMD) { - sprintf(suffixBuffer+strlen(suffixBuffer), - ", %u cmds start here", opnd); - } Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; case OPERAND_OFFSET1: @@ -515,11 +506,7 @@ FormatInstruction( break; case OPERAND_OFFSET4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); - } else { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_LIT1: @@ -1083,21 +1070,18 @@ DisassembleByteCodeAsDicts( for (i=0 ; i<codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: + if (IS_CATCH_RANGE(rangePtr)) { Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d break %d continue %d", - "loop", rangePtr->nestingLevel, rangePtr->codeOffset, + "type %s from %d to %d catch %d", + "catch", rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, - rangePtr->breakOffset, rangePtr->continueOffset)); - break; - case CATCH_EXCEPTION_RANGE: + rangePtr->mainOffset)); + } else { Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d catch %d", - "catch", rangePtr->nestingLevel, rangePtr->codeOffset, + "type %s from %d to %d break %d continue %d", + "loop", rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, - rangePtr->catchOffset)); - break; + rangePtr->mainOffset, rangePtr->continueOffset)); } } @@ -1172,8 +1156,6 @@ DisassembleByteCodeAsDicts( Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), Tcl_NewIntObj(codePtr->maxStackDepth)); - Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), - Tcl_NewIntObj(codePtr->maxExceptDepth)); return description; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b10af65..c5e267d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -77,7 +77,7 @@ int tclTraceExec = 0; */ static const char *const operatorStrings[] = { - "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!" }; @@ -160,29 +160,39 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { #define LAST_BUILTIN_FUNC 25 #endif +#define firstRangePtr \ + (codePtr->numExceptRanges? (codePtr->exceptArrayPtr) : NULL) +#define defaultRangePtr \ + (firstRangePtr + codePtr->numExceptRanges - 1) + +#define GetExceptRange(result) \ + TclGetExceptionRange(CURR_OFFSET, (result), \ + (rangePtr ? rangePtr : defaultRangePtr), firstRangePtr) + /* * NR_TEBC * Helpers for NR - non-recursive calls to TEBC * Minimal data required to fully reconstruct the execution state. */ +typedef struct expandAux { + struct expandAux *next; + int actualDepth; /* where the expansion started */ + int nominalDepth; /* where we thought it started */ + int extra; /* extra elements up to now, all expansions */ +} expandAux; + typedef struct TEBCdata { - ByteCode *codePtr; /* Constant until the BC returns */ - /* -----------------------------------------*/ - ptrdiff_t *catchTop; /* These fields are used on return TO this */ - Tcl_Obj *auxObjList; /* this level: they record the state when a */ - CmdFrame cmdFrame; /* new codePtr was received for NR */ - /* execution. */ - void *stack[1]; /* Start of the actual combined catch and obj - * stacks; the struct will be expanded as - * necessary */ + ByteCode *codePtr; + CmdFrame cmdFrame; + void *stack[1]; } TEBCdata; #define TEBC_YIELD() \ do { \ esPtr->tosPtr = tosPtr; \ TclNRAddCallback(interp, TEBCresume, \ - TD, pc, INT2PTR(cleanup), NULL); \ + TD, pc, INT2PTR(cleanup), expandList); \ } while (0) #define TEBC_DATA_DIG() \ @@ -190,20 +200,22 @@ typedef struct TEBCdata { tosPtr = esPtr->tosPtr; \ } while (0) -#define PUSH_TAUX_OBJ(objPtr) \ +#define PUSH_TAUX(d, n) \ do { \ - if (auxObjList) { \ - objPtr->length += auxObjList->length; \ - } \ - objPtr->internalRep.twoPtrValue.ptr1 = auxObjList; \ - auxObjList = objPtr; \ + expandAux *new; \ + TclSmallAllocEx(interp, sizeof(expandAux), new); \ + new->actualDepth = (d); \ + new->nominalDepth = (n); \ + new->extra = (d) - (n); \ + new->next = expandList; \ + expandList = new; \ } while (0) -#define POP_TAUX_OBJ() \ - do { \ - tmpPtr = auxObjList; \ - auxObjList = tmpPtr->internalRep.twoPtrValue.ptr1; \ - Tcl_DecrRefCount(tmpPtr); \ +#define POP_TAUX() \ + do { \ + expandAux *tmpPtr = expandList; \ + expandList = tmpPtr->next; \ + TclSmallFreeEx(interp, tmpPtr); \ } while (0) /* @@ -253,8 +265,9 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG #define CHECK_STACK() \ do { \ - ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ - /*checkStack*/ !(starting || auxObjList)); \ + if (!(starting || expandList)) { \ + ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH); \ + } \ starting = 0; \ } while (0) #else @@ -383,7 +396,7 @@ VarHashCreateVar( */ #define CACHE_STACK_INFO() \ - checkInterp = 1 + if (!cmdLoc.numCodeBytes) cmdLoc.numCodeBytes = 0 #define DECACHE_STACK_INFO() \ esPtr->tosPtr = tosPtr @@ -418,6 +431,8 @@ VarHashCreateVar( #define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) +#define CURR_OFFSET (pc - codePtr->codeStart) + /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is @@ -739,8 +754,7 @@ static const char * GetOpcodeName(const unsigned char *pc); static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, - const unsigned char *pc, int stackTop, - int checkStack); + const unsigned char *pc, int stackTop); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); @@ -754,11 +768,11 @@ static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); -static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, - int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, const unsigned char **pcBeg, int *cmdIdxPtr); +static void GetISCInfoForPc(const unsigned char *pc, + ByteCode *codePtr, CmdLocation *cmdLocPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, @@ -2018,8 +2032,7 @@ ArgumentBCEnter( *---------------------------------------------------------------------- */ #define bcFramePtr (&TD->cmdFrame) -#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1])) -#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) +#define initTosPtr ((Tcl_Obj **) (&TD->stack[-1])) #define esPtr (iPtr->execEnvPtr->execStackPtr) int @@ -2029,9 +2042,7 @@ TclNRExecuteByteCode( { Interp *iPtr = (Interp *) interp; TEBCdata *TD; - int size = sizeof(TEBCdata) - 1 - + (codePtr->maxStackDepth + codePtr->maxExceptDepth) - * sizeof(void *); + int size = sizeof(TEBCdata) + sizeof(Tcl_Obj *)*(codePtr->maxStackDepth - 1); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); codePtr->refCount++; @@ -2040,20 +2051,16 @@ TclNRExecuteByteCode( * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame * * The execution uses a unified stack: first a TEBCdata, immediately - * above it a CmdFrame, then the catch stack, then the execution stack. + * above it a CmdFrame, then the execution stack. * - * Make sure the catch stack is large enough to hold the maximum number of - * catch commands that could ever be executing at the same time (this will - * be no more than the exception range array's depth). Make sure the - * execution stack is large enough to execute this ByteCode. + * Make sure the execution stack is large enough to execute this + * ByteCode. */ TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); esPtr->tosPtr = initTosPtr; TD->codePtr = codePtr; - TD->catchTop = initCatchTop; - TD->auxObjList = NULL; /* * TIP #280: Initialize the frame. Do not push it yet: it will be pushed @@ -2082,8 +2089,16 @@ TclNRExecuteByteCode( * Push the callback for bytecode execution */ +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + PrintByteCodeInfo(codePtr); + fprintf(stdout, " Starting stack top=0\n"); + fflush(stdout); + } +#endif + TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, - /* cleanup */ INT2PTR(0), NULL); + /* cleanup */ INT2PTR(0), /* expandList */ NULL); return TCL_OK; } @@ -2136,8 +2151,6 @@ TEBCresume( */ TEBCdata *TD = data[0]; -#define auxObjList (TD->auxObjList) -#define catchTop (TD->catchTop) #define codePtr (TD->codePtr) /* @@ -2157,9 +2170,21 @@ TEBCresume( int cleanup = PTR2INT(data[2]); Tcl_Obj *objResultPtr; - int checkInterp; /* Indicates when a check of interp readyness - * is necessary. Set by CACHE_STACK_INFO() */ - + expandAux *expandList = data[3]; + ExceptionRange *rangePtr = NULL; + /* Points to closest loop or catch exception + * range enclosing the pc. Used by various + * instructions and processCatch to process + * break, continue, and errors. */ + CmdLocation cmdLoc; /* Holds data for ISC. CACHE_STACK_INFO() + * indicates when a check of interp readyness + * is necessary by setting .pcStart to NULL*/ + int *iCEpochPtr = &iPtr->compileEpoch; + int *iREpochPtr = &iPtr->varFramePtr->nsPtr->resolverEpoch; + int cCEpoch = codePtr->compileEpoch; + int cREpoch = codePtr->nsEpoch;; + + /* * Locals - variables that are used within opcodes or bounded sections of * the file (jumps between opcodes within a family). @@ -2179,25 +2204,16 @@ TEBCresume( int starting = 1; traceInstructions = (tclTraceExec == 3); #endif - TEBC_DATA_DIG(); -#ifdef TCL_COMPILE_DEBUG - if (!pc && (tclTraceExec >= 2)) { - PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); - fflush(stdout); - } -#endif - if (!pc) { /* bytecode is starting from scratch */ - checkInterp = 0; + cmdLoc.numCodeBytes = 0; pc = codePtr->codeStart; goto cleanup0; } else { /* resume from invocation */ - CACHE_STACK_INFO(); + cmdLoc.numCodeBytes = -1; NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); if (bcFramePtr->cmdObj) { @@ -2375,6 +2391,11 @@ TEBCresume( TCL_DTRACE_INST_NEXT(); + if (cmdLoc.numCodeBytes) { + goto ISC_implementation; + } + ISC_continue: + if (inst == INST_LOAD_SCALAR1) { goto instLoadScalar1; } else if (inst == INST_PUSH1) { @@ -2382,22 +2403,6 @@ TEBCresume( TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS); inst = *(pc += 2); goto peepholeStart; - } else if (inst == INST_START_CMD) { - /* - * Peephole: do not run INST_START_CMD, just skip it - */ - - iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - if (checkInterp) { - checkInterp = 0; - if (((codePtr->compileEpoch != iPtr->compileEpoch) || - (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && - !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - goto instStartCmdFailed; - } - } - inst = *(pc += 9); - goto peepholeStart; } else if (inst == INST_NOP) { #ifndef TCL_COMPILE_DEBUG while (inst == INST_NOP) @@ -2429,38 +2434,35 @@ TEBCresume( if (*pc == INST_SYNTAX) { iPtr->flags &= ~ERR_ALREADY_LOGGED; } - cleanup = 2; TRACE_APPEND(("\n")); goto processExceptionReturn; } case INST_RETURN_STK: + /* + * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr. + */ + TRACE(("=> ")); - objResultPtr = POP_OBJECT(); result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); if (result == TCL_OK) { - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", - O2S(objResultPtr))); - NEXT_INST_F(1, 0, 0); - } else if (result == TCL_ERROR) { + O2S(OBJ_UNDER_TOS))); + NEXT_INST_F(1, 1, 0); + } else { /* * BEWARE! Must do this in this order, because an error in the * option dictionary overrides the result (and can be verified by * test). */ - Tcl_SetObjResult(interp, objResultPtr); - Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - } else { - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - Tcl_SetObjResult(interp, objResultPtr); + objPtr = POP_OBJECT(); + Tcl_SetObjResult(interp, OBJ_AT_TOS); + if (result == TCL_ERROR) { + Tcl_SetReturnOptions(interp, objPtr); + } + Tcl_DecrRefCount(objPtr); } - cleanup = 1; TRACE_APPEND(("\n")); goto processExceptionReturn; @@ -2615,31 +2617,24 @@ TEBCresume( iPtr->varFramePtr->tailcallPtr = listPtr; result = TCL_RETURN; - cleanup = opnd; goto processExceptionReturn; } case INST_DONE: - if (tosPtr > initTosPtr) { - /* - * Set the interpreter's object result to point to the topmost - * object from the stack, and check for a possible [catch]. The - * stackTop's level and refCount will be handled by "processCatch" - * or "abnormalReturn". - */ + /* + * Set the interpreter's object result to point to the topmost + * object from the stack. + */ - Tcl_SetObjResult(interp, OBJ_AT_TOS); #ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("=> return code=%d, result=", result), - iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); - } -#endif - goto checkForCatch; + TRACE_WITH_OBJ(("=> return code=%d, result=", result), + OBJ_AT_TOS); + if (traceInstructions) { + fprintf(stdout, "\n"); } - (void) POP_OBJECT(); - goto abnormalReturn; +#endif + Tcl_SetObjResult(interp, OBJ_AT_TOS); + goto normalReturn; case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; @@ -2841,41 +2836,13 @@ TEBCresume( case INST_EXPAND_START: /* - * Push an element to the auxObjList. This records the current + * Push an element to the expandList. This records the current * stack depth - i.e., the point in the stack where the expanded * command starts. - * - * Use a Tcl_Obj as linked list element; slight mem waste, but faster - * allocation than ckalloc. This also abuses the Tcl_Obj structure, as - * we do not define a special tclObjType for it. It is not dangerous - * as the obj is never passed anywhere, so that all manipulations are - * performed here and in INST_INVOKE_EXPANDED (in case of an expansion - * error, also in INST_EXPAND_STKTOP). - */ - - TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH); - objPtr->length = 0; - PUSH_TAUX_OBJ(objPtr); - TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); - NEXT_INST_F(1, 0, 0); - - case INST_EXPAND_DROP: - /* - * Drops an element of the auxObjList, popping stack elements to - * restore the stack to the state before the point where the aux - * element was created. */ - CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); - POP_TAUX_OBJ(); -#ifdef TCL_COMPILE_DEBUG - /* Ugly abuse! */ - starting = 1; -#endif - TRACE(("=> drop %d items\n", objc)); - NEXT_INST_V(1, objc, 0); + PUSH_TAUX(CURR_DEPTH, TclGetUInt4AtPtr(pc+1)); + NEXT_INST_F(5, 0, 0); case INST_EXPAND_STKTOP: { int i; @@ -2898,15 +2865,17 @@ TEBCresume( /* * Make sure there is enough room in the stack to expand this list * *and* process the rest of the command (at least up to the next - * argument expansion or command end). The operand is the current - * stack depth, as seen by the compiler. + * argument expansion or command end). */ - auxObjList->length += objc - 1; - if ((objc > 1) && (auxObjList->length > 0)) { - length = auxObjList->length /* Total expansion room we need */ - + codePtr->maxStackDepth /* Beyond the original max */ - - CURR_DEPTH; /* Relative to where we are */ + if (objc > 1) { + /* We need (objc-1) extra slots additional to what we already + * accounted for; note that previously expanded lists already + * accounted for their own needs */ + + length = objc-1 + codePtr->maxStackDepth /*we think we need*/ + - expandList->nominalDepth; /*we've got*/ + DECACHE_STACK_INFO(); moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - (Tcl_Obj **) TD; @@ -2919,7 +2888,6 @@ TEBCresume( TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); - catchTop += moved; tosPtr += moved; } } @@ -2932,10 +2900,11 @@ TEBCresume( for (i = 0; i < objc; i++) { PUSH_OBJECT(objv[i]); } - + expandList->extra += objc-1; + TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); - NEXT_INST_F(5, 0, 0); + NEXT_INST_F(1, 0, 0); } case INST_EXPR_STK: { @@ -2967,9 +2936,9 @@ TEBCresume( return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0); case INST_INVOKE_EXPANDED: - CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); - POP_TAUX_OBJ(); + CLANG_ASSERT(expandList); + objc = CURR_DEPTH - expandList->actualDepth; + POP_TAUX(); if (objc) { pcAdjustment = 1; goto doInvocation; @@ -4589,50 +4558,6 @@ TEBCresume( } /* - * These two instructions are now redundant: the complete logic of the LOR - * and LAND is now handled by the expression compiler. - */ - - case INST_LOR: - case INST_LAND: { - /* - * Operands must be boolean or numeric. No int->double conversions are - * performed. - */ - - int i1, i2, iResult; - - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, valuePtr); - CACHE_STACK_INFO(); - goto gotError; - } - - if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), - (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - DECACHE_STACK_INFO(); - IllegalExprOperandType(interp, pc, value2Ptr); - CACHE_STACK_INFO(); - goto gotError; - } - - if (*pc == INST_LOR) { - iResult = (i1 || i2); - } else { - iResult = (i1 && i2); - } - objResultPtr = TCONST(iResult); - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); - NEXT_INST_F(1, 2, 1); - } - - /* * ----------------------------------------------------------------- * Start of general introspector instructions. */ @@ -6859,190 +6784,44 @@ TEBCresume( NEXT_INST_F(1, 0, 1); case INST_BREAK: - /* - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); - */ - result = TCL_BREAK; - cleanup = 0; - TRACE(("=> BREAK!\n")); - goto processExceptionReturn; - - case INST_CONTINUE: - /* - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); - */ - result = TCL_CONTINUE; - cleanup = 0; + case INST_CONTINUE: { + int range = TclGetInt4AtPtr(pc+1); + result = (*pc == INST_BREAK ? TCL_BREAK : TCL_CONTINUE); + if (range == -1) { + TRACE_APPEND(("no encl. loop or catch, returning %s\n", + StringForResultCode(result))); + goto abnormalReturn; + } + rangePtr = codePtr->exceptArrayPtr + range; + rangePtr = GetExceptRange(result); TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; - - { - ForeachInfo *infoPtr; - Var *iterVarPtr, *listVarPtr; - Tcl_Obj *oldValuePtr, *listPtr, **elements; - ForeachVarList *varListPtr; - int numLists, iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, continueLoop, j, iterTmpIndex; - long i; - - case INST_FOREACH_START4: /* DEPRECATED */ - /* - * Initialize the temporary local var that holds the count of the - * number of iterations of the loop body to -1. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; - iterTmpIndex = infoPtr->loopCtTemp; - iterVarPtr = LOCAL(iterTmpIndex); - oldValuePtr = iterVarPtr->value.objPtr; - - if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); - Tcl_IncrRefCount(iterVarPtr->value.objPtr); - } else { - TclSetLongObj(oldValuePtr, -1); - } - TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); - -#ifndef TCL_COMPILE_DEBUG - /* - * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately - * after INST_FOREACH_START4 - let us just fall through instead of - * jumping back to the top. - */ - - pc += 5; - TCL_DTRACE_INST_NEXT(); -#else - NEXT_INST_F(5, 0, 0); -#endif - - case INST_FOREACH_STEP4: /* DEPRECATED */ - /* - * "Step" a foreach loop (i.e., begin its next iteration) by assigning - * the next value list element to each loop var. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; - numLists = infoPtr->numLists; - - /* - * Increment the temp holding the loop iteration number. - */ - - iterVarPtr = LOCAL(infoPtr->loopCtTemp); - valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.longValue + 1; - TclSetLongObj(valuePtr, iterNum); - - /* - * Check whether all value lists are exhausted and we should stop the - * loop. - */ - - continueLoop = 0; - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - listPtr = listVarPtr->value.objPtr; - if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", - i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - if (listLen > iterNum * numVars) { - continueLoop = 1; - } - listTmpIndex++; - } - - /* - * If some var in some var list still has a remaining list element - * iterate one more time. Assign to var the next element from its - * value list. We already checked above that each list temp holds a - * valid list object (by calling Tcl_ListObjLength), but cannot rely - * on that check remaining valid: one list could have been shimmered - * as a side effect of setting a traced variable. - */ - - if (continueLoop) { - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = LOCAL(listTmpIndex); - listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr); - TclListObjGetElements(interp, listPtr, &listLen, &elements); - - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { - if (valIndex >= listLen) { - TclNewObj(valuePtr); - } else { - valuePtr = elements[valIndex]; - } - - varIndex = varListPtr->varIndexes[j]; - varPtr = LOCAL(varIndex); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectWritable(varPtr)) { - value2Ptr = varPtr->value.objPtr; - if (valuePtr != value2Ptr) { - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = valuePtr; - Tcl_IncrRefCount(valuePtr); - } - } else { - DECACHE_STACK_INFO(); - if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ - CACHE_STACK_INFO(); - TRACE_APPEND(( - "ERROR init. index temp %d: %s\n", - varIndex, O2S(Tcl_GetObjResult(interp)))); - TclDecrRefCount(listPtr); - goto gotError; - } - CACHE_STACK_INFO(); - } - valIndex++; - } - TclDecrRefCount(listPtr); - listTmpIndex++; + } + + case INST_CLEAR_RANGE: { + /* + * Drops elements of the auxObjList and stack elements to + * restore the stack to the state corresponding to the ranges's exception + * targets + */ + + int range = TclGetInt4AtPtr(pc+1); + int limit; + ExceptionRange *rangePtr = codePtr->exceptArrayPtr + range; + + while (expandList + && (rangePtr->stackDepth <= expandList->nominalDepth)) { + POP_TAUX(); + } + limit = rangePtr->stackDepth + (expandList? expandList->extra : 0); + + while (CURR_DEPTH > limit) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); } } - TRACE_APPEND(("%d lists, iter %d, %s loop\n", - numLists, iterNum, (continueLoop? "continue" : "exit"))); - - /* - * Run-time peep-hole optimisation: the compiler ALWAYS follows - * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that - * instruction and jump direct from here. - */ - - pc += 5; - if (*pc == INST_JUMP_FALSE1) { - NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - } else { - NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - } - - } + NEXT_INST_F(5, 0, 0); + { ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements, *tmpPtr; @@ -7113,13 +6892,17 @@ TEBCresume( PUSH_OBJECT(tmpPtr); /* infoPtr object */ TRACE_APPEND(("jump to loop step\n")); +#ifdef TCL_COMPILE_DEBUG + NEXT_INST_F(5- infoPtr->jumpSize, 0, 0); +#else /* * Jump directly to the INST_FOREACH_STEP instruction; the C code just * falls through. */ - pc += 5 - infoPtr->loopCtTemp; - + pc += 5 - infoPtr->jumpSize; +#endif + case INST_FOREACH_STEP: /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning @@ -7194,8 +6977,7 @@ TEBCresume( listTmpDepth--; } TRACE_APPEND(("jump to loop start\n")); - /* loopCtTemp being 'misused' for storing the jump size */ - NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); + NEXT_INST_F(infoPtr->jumpSize, 0, 0); } TRACE_APPEND(("loop has no more iterations\n")); @@ -7237,46 +7019,6 @@ TEBCresume( NEXT_INST_F(1, 1, 0); } - case INST_BEGIN_CATCH4: - /* - * Record start of the catch command with exception range index equal - * to the operand. Push the current stack depth onto the special catch - * stack. - */ - - *(++catchTop) = CURR_DEPTH; - TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1), - (int) CURR_DEPTH)); - NEXT_INST_F(5, 0, 0); - - case INST_END_CATCH: - catchTop--; - DECACHE_STACK_INFO(); - Tcl_ResetResult(interp); - CACHE_STACK_INFO(); - result = TCL_OK; - TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); - NEXT_INST_F(1, 0, 0); - - case INST_PUSH_RESULT: - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("=> "), objResultPtr); - - /* - * See the comments at INST_INVOKE_STK - */ - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_F(1, 0, -1); - - case INST_PUSH_RETURN_CODE: - TclNewIntObj(objResultPtr, result); - TRACE(("=> %u\n", result)); - NEXT_INST_F(1, 0, 1); - case INST_PUSH_RETURN_OPTIONS: DECACHE_STACK_INFO(); objResultPtr = Tcl_GetReturnOptions(interp, result); @@ -7284,22 +7026,6 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - case INST_RETURN_CODE_BRANCH: { - int code; - - if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); - } - if (code == TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!"); - } - if (code < TCL_ERROR || code > TCL_CONTINUE) { - code = TCL_CONTINUE + 1; - } - TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); - NEXT_INST_F(2*code-1, 1, 0); - } - /* * ----------------------------------------------------------------- * Start of dictionary-related instructions. @@ -7914,20 +7640,16 @@ TEBCresume( */ { - ExceptionRange *rangePtr; - /* Points to closest loop or catch exception - * range enclosing the pc. Used by various - * instructions and processCatch to process - * break, continue, and errors. */ const char *bytes; - + int limit; + + processExceptionReturn: /* * An external evaluation (INST_INVOKE or INST_EVAL) returned * something different from TCL_OK, or else INST_BREAK or * INST_CONTINUE were called. */ - processExceptionReturn: #ifdef TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: @@ -7951,38 +7673,53 @@ TEBCresume( } #endif if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { - rangePtr = GetExceptRangeForPc(pc, result, codePtr); - if (rangePtr == NULL) { + if (!rangePtr) { + rangePtr = GetExceptRange(result); + } + if (!rangePtr) { TRACE_APPEND(("no encl. loop or catch, returning %s\n", - StringForResultCode(result))); + StringForResultCode(result))); goto abnormalReturn; } - if (rangePtr->type == CATCH_EXCEPTION_RANGE) { + if (IS_CATCH_RANGE(rangePtr)) { TRACE_APPEND(("%s ...\n", StringForResultCode(result))); goto processCatch; } - while (cleanup--) { + + while (expandList + && (rangePtr->stackDepth <= expandList->nominalDepth)) { + POP_TAUX(); + } + limit = rangePtr->stackDepth + (expandList? expandList->extra : 0); + while (CURR_DEPTH > limit) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } if (result == TCL_BREAK) { - result = TCL_OK; - pc = (codePtr->codeStart + rangePtr->breakOffset); + pc = (codePtr->codeStart + rangePtr->mainOffset); TRACE_APPEND(("%s, range at %d, new pc %d\n", StringForResultCode(result), - rangePtr->codeOffset, rangePtr->breakOffset)); - NEXT_INST_F(0, 0, 0); - } - if (rangePtr->continueOffset == -1) { - TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", - StringForResultCode(result))); - goto checkForCatch; + rangePtr->codeOffset, rangePtr->mainOffset)); + } else { + if (rangePtr->continueOffset == -1) { + rangePtr = GetExceptRange(result); + } + if (!rangePtr) { + TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", + StringForResultCode(result))); + goto checkForCatch; + } + pc = (codePtr->codeStart + rangePtr->continueOffset); + TRACE_APPEND(("%s, range at %d, new pc %d\n", + StringForResultCode(result), + rangePtr->codeOffset, rangePtr->continueOffset)); } + restart: + rangePtr = NULL; + DECACHE_STACK_INFO(); + Tcl_ResetResult(interp); + CACHE_STACK_INFO(); result = TCL_OK; - pc = (codePtr->codeStart + rangePtr->continueOffset); - TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(result), - rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); } #ifdef TCL_COMPILE_DEBUG @@ -8056,20 +7793,6 @@ TEBCresume( iPtr->flags &= ~ERR_ALREADY_LOGGED; /* - * Clear all expansions that may have started after the last - * INST_BEGIN_CATCH. - */ - - while (auxObjList) { - if ((catchTop != initCatchTop) - && (*catchTop > (ptrdiff_t) - auxObjList->internalRep.twoPtrValue.ptr2)) { - break; - } - POP_TAUX_OBJ(); - } - - /* * We must not catch if the script in progress has been canceled with * the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we * either hit another interpreter (presumably where the script in @@ -8103,23 +7826,9 @@ TEBCresume( #endif goto abnormalReturn; } - if (catchTop == initCatchTop) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(result)); - } -#endif - goto abnormalReturn; - } - rangePtr = GetExceptRangeForPc(pc, TCL_ERROR, codePtr); - if (rangePtr == NULL) { - /* - * This is only possible when compiling a [catch] that sends its - * script to INST_EVAL. Cannot correct the compiler without - * breaking compat with previous .tbc compiled scripts. - */ + rangePtr = GetExceptRange(TCL_ERROR); + if (!rangePtr) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... no enclosing catch, returning %s\n", @@ -8138,20 +7847,39 @@ TEBCresume( */ processCatch: - while (CURR_DEPTH > *catchTop) { + /* + * Clear all expansions that may have started after the last + * INST_BEGIN_CATCH. + */ + + while (expandList + && (rangePtr->stackDepth <= expandList->nominalDepth)) { + POP_TAUX(); + } + + limit = rangePtr->stackDepth + (expandList? expandList->extra : 0); + while (CURR_DEPTH > limit) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, " - "unwound to %ld, new pc %u\n", - rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), - (long) *catchTop, (unsigned) rangePtr->catchOffset); + fprintf(stdout, " ... found catch at %d, " + "unwound to %d, new pc %u\n", + rangePtr->codeOffset, + rangePtr->stackDepth, (unsigned) rangePtr->mainOffset); } #endif - pc = (codePtr->codeStart + rangePtr->catchOffset); - NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ + PUSH_OBJECT(Tcl_NewIntObj(result)); + if (rangePtr->flags & CATCH_PUSH_RESULT) { + PUSH_OBJECT(Tcl_GetObjResult(interp)); + } + if (rangePtr->flags & CATCH_PUSH_OPTIONS) { + PUSH_OBJECT(Tcl_GetReturnOptions(interp, result)); + } + pc = (codePtr->codeStart + rangePtr->mainOffset); + + goto restart; /* * end of infinite loop dispatching on instructions. @@ -8164,6 +7892,7 @@ TEBCresume( */ abnormalReturn: + normalReturn: TCL_DTRACE_INST_LAST(); /* @@ -8173,8 +7902,8 @@ TEBCresume( * markers. */ - while (auxObjList) { - POP_TAUX_OBJ(); + while (expandList) { + POP_TAUX(); } while (tosPtr > initTosPtr) { objPtr = POP_OBJECT(); @@ -8199,52 +7928,70 @@ TEBCresume( TclStackFree(interp, TD); /* free my stack */ return result; + /* - * INST_START_CMD failure case removed where it doesn't bother that much - * - * Remark that if the interpreter is marked for deletion its - * compileEpoch is modified, so that the epoch check also verifies - * that the interp is not deleted. If no outside call has been made - * since the last check, it is safe to omit the check. - - * case INST_START_CMD: + * ISC - New INST_START_CMD implementation */ - instStartCmdFailed: - { - const char *bytes; - - checkInterp = 1; - length = 0; - - /* - * We used to switch to direct eval; for NRE-awareness we now - * compile and eval the command so that this evaluation does not - * add a new TEBC instance. [Bug 2910748] - */ + ISC_implementation: + if ((cmdLoc.numCodeBytes == -1) && + (((cCEpoch == *iCEpochPtr) && (cREpoch == *iREpochPtr)) || + (codePtr->flags & TCL_BYTECODE_PRECOMPILED))) { + /* + * Some external call returned, we need to verify that it didn't + * change the interp's readyness. If it didn't, we go on with + * evaluation. If it did, we jump to ISC_failed where a call to + * GetISCInfoForPc computes the data needed to re-compile the next + * command and then arranges for its evaluation. + */ + + cmdLoc.numCodeBytes = 0; + goto ISC_continue; + } + /* + * Compute the next pc where a command starts; there is no need to + * do anything until we hit that one. + * + * FIXME: We recompute the next start at each new instruction, to make + * sure we do not miss the command start even in presence of + * jumps. This is probably suboptimal. OTOH, the cost will be paid + * only for the 'few' intructions of the commands that were running when + * the change was detected, and doesn't have to be recompiled. If the + * transitional speed in this last hybrid run is important (the next + * run will use a fully recompiled body), more work is needed here. + * + * We used to switch to direct eval; for NRE-awareness we now + * compile and eval the command so that this evaluation does not + * add a new TEBC instance. [Bug 2910748] + */ + + if (cmdLoc.numCodeBytes) { + GetISCInfoForPc(pc, codePtr, &cmdLoc); + if (CURR_OFFSET == cmdLoc.codeOffset) { if (TclInterpReady(interp) == TCL_ERROR) { goto gotError; } - + codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - assert(bytes); - PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); + PUSH_OBJECT(Tcl_NewStringObj(codePtr->source + cmdLoc.srcOffset, cmdLoc.numSrcBytes)); + pc += cmdLoc.numCodeBytes-1; + if (traceInstructions) { + TRACE(("[%.15s] => ISC to pc %i\n", codePtr->source + cmdLoc.srcOffset, + (int)(pc-codePtr->codeStart))); + } goto instEvalStk; } + } + goto ISC_continue; } #undef codePtr #undef iPtr #undef bcFramePtr -#undef initCatchTop #undef initTosPtr -#undef auxObjList -#undef catchTop +#undef expandList #undef TCONST #undef esPtr @@ -9749,11 +9496,9 @@ ValidatePcAndStackTop( * stdout. */ const unsigned char *pc, /* Points to first byte of a bytecode * instruction. The program counter. */ - int stackTop, /* Current stack top. Must be between + int stackTop) /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ - int checkStack) /* 0 if the stack depth check should be - * skipped. */ { int stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ @@ -9773,8 +9518,7 @@ ValidatePcAndStackTop( (unsigned) opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } - if (checkStack && - ((stackTop < 0) || (stackTop > stackUpperBound))) { + if ((stackTop < 0) || (stackTop > stackUpperBound)) { int numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); @@ -9831,7 +9575,7 @@ IllegalExprOperandType( if (opcode == INST_EXPON) { operator = "**"; } else if (opcode <= INST_LNOT) { - operator = operatorStrings[opcode - INST_LOR]; + operator = operatorStrings[opcode - INST_BITOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { @@ -10101,8 +9845,100 @@ GetSrcInfoForPc( /* *---------------------------------------------------------------------- + * GetISCInfoForPc -- * - * GetExceptRangeForPc -- + * A close relative of GetSrcInfoForPc, GetISCInfoForPc computes the data + * needed for a temporary reversion to running from source - the job + * previously handled by INST_START_CMD. + * + * Given the current pc (and the knowledge that the bytecodes are obsoleted by + * an epoch change), this function computes the range of pc that implement the + * NEXT command to be run, as well as the source string for that command. + */ + +static void +GetISCInfoForPc( + const unsigned char *pc, /* The program counter value for which to + * return the closest command's source info. + * This points within a bytecode instruction + * in codePtr's code. */ + ByteCode *codePtr, /* The bytecode sequence in which to look up + * the command source for the pc. */ + CmdLocation *cmdLocPtr) /* The address of the struct that will hold + * the result. */ +{ + register int pcOffset = (pc - codePtr->codeStart); + int numCmds = codePtr->numCommands; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, delta, i; + + /* The pc must point within the bytecode */ + assert ((pcOffset >= 0) && (pcOffset < codePtr->numCodeBytes)); + + /* + * Decode the code and source offset and length for each command. The + * next command is the first one whose code starts after pcOffset. In case + * of several commands starting at that pc, we want them all; with our + * compiler, it is the first one we encounter after pc. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + if (codePtr->codeStart + codeOffset >= pc) { /* we have found the next command */ + break; + } + } + + *cmdLocPtr = (CmdLocation) {codeOffset, codeLen, srcOffset, srcLen}; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetExceptionRangeForPc -- * * Given a program counter value, return the closest enclosing * ExceptionRange. @@ -10124,9 +9960,9 @@ GetSrcInfoForPc( *---------------------------------------------------------------------- */ -static ExceptionRange * -GetExceptRangeForPc( - const unsigned char *pc, /* The program counter value for which to +ExceptionRange * +TclGetExceptionRange( + int pcOffset, /* The program counter value for which to * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */ @@ -10136,39 +9972,35 @@ GetExceptRangeForPc( * closer loop ranges). If TCL_CONTINUE, look * for loop ranges that define a continue * point or a catch range. */ - ByteCode *codePtr) /* Points to the ByteCode in which to search - * for the enclosing ExceptionRange. */ + ExceptionRange *startPtr, /* Starting range for the backwards search. */ + ExceptionRange *endPtr) /* Ending range for the backwards search. */ { - ExceptionRange *rangeArrayPtr; - int numRanges = codePtr->numExceptRanges; - register ExceptionRange *rangePtr; - int pcOffset = pc - codePtr->codeStart; register int start; - if (numRanges == 0) { + if (endPtr == NULL) { return NULL; } - + /* * This exploits peculiarities of our compiler: nested ranges are always * *after* their containing ranges, so that by scanning backwards we are * sure that the first matching range is indeed the deepest. */ - rangeArrayPtr = codePtr->exceptArrayPtr; - rangePtr = rangeArrayPtr + numRanges; - while (--rangePtr >= rangeArrayPtr) { - start = rangePtr->codeOffset; - if ((start <= pcOffset) && - (pcOffset < (start + rangePtr->numCodeBytes))) { - if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - return rangePtr; + startPtr++; + while (--startPtr >= endPtr) { + start = startPtr->codeOffset; + if ((start <= pcOffset) && + ((pcOffset - start < startPtr->numCodeBytes) + || (startPtr->numCodeBytes < 0))) { + if (IS_CATCH_RANGE(startPtr)) { + return startPtr; } if (searchMode == TCL_BREAK) { - return rangePtr; + return startPtr; } - if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){ - return rangePtr; + if (searchMode == TCL_CONTINUE && startPtr->continueOffset != -1){ + return startPtr; } } } diff --git a/generic/tclInt.h b/generic/tclInt.h index 082fab4..fd03155 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1876,8 +1876,6 @@ typedef struct Interp { * Miscellaneous information: */ - int cmdCount; /* Total number of times a command procedure - * has been called for this interpreter. */ int evalFlags; /* Flags to control next call to Tcl_Eval. * Normally zero, but may be set before * calling Tcl_Eval. See below for valid @@ -1964,14 +1962,6 @@ typedef struct Interp { * as flag values the same as the 'active' * field. */ - int cmdCount; /* Limit for how many commands to execute in - * the interpreter. */ - LimitHandler *cmdHandlers; - /* Handlers to execute when the limit is - * reached. */ - int cmdGranularity; /* Mod factor used to determine how often to - * evaluate the limit check. */ - Tcl_Time time; /* Time limit for execution within the * interpreter. */ LimitHandler *timeHandlers; @@ -3230,15 +3220,6 @@ MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, 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[]); @@ -3910,10 +3891,6 @@ 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 * by the bytecode compiler and engine. Some of these could later be placed in @@ -4692,14 +4669,9 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #define TclLimitReady(limit) \ (((limit).active == 0) ? 0 : \ (++(limit).granularityTicker, \ - ((((limit).active & TCL_LIMIT_COMMANDS) && \ - (((limit).cmdGranularity == 1) || \ - ((limit).granularityTicker % (limit).cmdGranularity == 0))) \ - ? 1 : \ (((limit).active & TCL_LIMIT_TIME) && \ (((limit).timeGranularity == 1) || \ - ((limit).granularityTicker % (limit).timeGranularity == 0)))\ - ? 1 : 0))) + ((limit).granularityTicker % (limit).timeGranularity == 0))))) /* * Compile-time assertions: these produce a compile time error if the diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 0da5d47..660e6fa 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -263,9 +263,6 @@ static void SlaveObjCmdDeleteProc(ClientData clientData); static int SlaveRecursionLimit(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); -static int SlaveCommandLimitCmd(Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int consumedObjc, - int objc, Tcl_Obj *const objv[]); static int SlaveTimeLimitCmd(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); @@ -986,8 +983,6 @@ NRInterpCmd( return TCL_ERROR; } switch ((enum LimitTypes) limitType) { - case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); case LIMIT_TYPE_TIME: return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } @@ -2645,8 +2640,6 @@ NRSlaveCmd( return TCL_ERROR; } switch ((enum LimitTypes) limitType) { - case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); case LIMIT_TYPE_TIME: return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); } @@ -3346,11 +3339,6 @@ Tcl_LimitReady( if (iPtr->limit.active != 0) { register int ticker = ++iPtr->limit.granularityTicker; - if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && - ((iPtr->limit.cmdGranularity == 1) || - (ticker % iPtr->limit.cmdGranularity == 0))) { - return 1; - } if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || (ticker % iPtr->limit.timeGranularity == 0))) { @@ -3394,25 +3382,6 @@ Tcl_LimitCheck( return TCL_OK; } - if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && - ((iPtr->limit.cmdGranularity == 1) || - (ticker % iPtr->limit.cmdGranularity == 0)) && - (iPtr->limit.cmdCount < iPtr->cmdCount)) { - iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS; - Tcl_Preserve(interp); - RunLimitHandlers(iPtr->limit.cmdHandlers, interp); - if (iPtr->limit.cmdCount >= iPtr->cmdCount) { - iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; - } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command count limit exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); - Tcl_Release(interp); - return TCL_ERROR; - } - Tcl_Release(interp); - } - if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || (ticker % iPtr->limit.timeGranularity == 0))) { @@ -3567,14 +3536,6 @@ Tcl_LimitAddHandler( */ switch (type) { - case TCL_LIMIT_COMMANDS: - handlerPtr->nextPtr = iPtr->limit.cmdHandlers; - if (handlerPtr->nextPtr != NULL) { - handlerPtr->nextPtr->prevPtr = handlerPtr; - } - iPtr->limit.cmdHandlers = handlerPtr; - return; - case TCL_LIMIT_TIME: handlerPtr->nextPtr = iPtr->limit.timeHandlers; if (handlerPtr->nextPtr != NULL) { @@ -3617,9 +3578,6 @@ Tcl_LimitRemoveHandler( LimitHandler *handlerPtr; switch (type) { - case TCL_LIMIT_COMMANDS: - handlerPtr = iPtr->limit.cmdHandlers; - break; case TCL_LIMIT_TIME: handlerPtr = iPtr->limit.timeHandlers; break; @@ -3650,9 +3608,6 @@ Tcl_LimitRemoveHandler( if (handlerPtr->prevPtr == NULL) { switch (type) { - case TCL_LIMIT_COMMANDS: - iPtr->limit.cmdHandlers = handlerPtr->nextPtr; - break; case TCL_LIMIT_TIME: iPtr->limit.timeHandlers = handlerPtr->nextPtr; break; @@ -3706,39 +3661,6 @@ TclLimitRemoveAllHandlers( LimitHandler *handlerPtr, *nextHandlerPtr; /* - * Delete all command-limit handlers. - */ - - for (handlerPtr=iPtr->limit.cmdHandlers, iPtr->limit.cmdHandlers=NULL; - handlerPtr!=NULL; handlerPtr=nextHandlerPtr) { - nextHandlerPtr = handlerPtr->nextPtr; - - /* - * Do not delete here if it has already been marked for deletion. - */ - - if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { - continue; - } - handlerPtr->flags |= LIMIT_HANDLER_DELETED; - handlerPtr->prevPtr = NULL; - handlerPtr->nextPtr = NULL; - - /* - * If nothing is currently executing the handler, delete its client - * data and the overall handler structure now. Otherwise it will all - * go away when the handler returns. - */ - - if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { - if (handlerPtr->deleteProc != NULL) { - handlerPtr->deleteProc(handlerPtr->clientData); - } - ckfree(handlerPtr); - } - } - - /* * Delete all time-limit handlers. */ @@ -3896,61 +3818,6 @@ Tcl_LimitTypeReset( /* *---------------------------------------------------------------------- * - * Tcl_LimitSetCommands -- - * - * Set the command limit for an interpreter. - * - * Results: - * None. - * - * Side effects: - * Also resets whether the command limit was exceeded. This might permit - * a small amount of further execution in the interpreter even if the - * limit itself is theoretically exceeded. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_LimitSetCommands( - Tcl_Interp *interp, - int commandLimit) -{ - Interp *iPtr = (Interp *) interp; - - iPtr->limit.cmdCount = commandLimit; - iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LimitGetCommands -- - * - * Get the number of commands that may be executed in the interpreter - * before the command-limit is reached. - * - * Results: - * An upper bound on the number of commands. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_LimitGetCommands( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - - return iPtr->limit.cmdCount; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_LimitSetTime -- * * Set the time limit for an interpreter by copying it from the value @@ -4091,9 +3958,6 @@ Tcl_LimitSetGranularity( } switch (type) { - case TCL_LIMIT_COMMANDS: - iPtr->limit.cmdGranularity = granularity; - return; case TCL_LIMIT_TIME: iPtr->limit.timeGranularity = granularity; return; @@ -4125,8 +3989,6 @@ Tcl_LimitGetGranularity( Interp *iPtr = (Interp *) interp; switch (type) { - case TCL_LIMIT_COMMANDS: - return iPtr->limit.cmdGranularity; case TCL_LIMIT_TIME: return iPtr->limit.timeGranularity; } @@ -4339,9 +4201,6 @@ TclInitLimitSupport( iPtr->limit.active = 0; iPtr->limit.granularityTicker = 0; iPtr->limit.exceeded = 0; - iPtr->limit.cmdCount = 0; - iPtr->limit.cmdHandlers = NULL; - iPtr->limit.cmdGranularity = 1; memset(&iPtr->limit.time, 0, sizeof(Tcl_Time)); iPtr->limit.timeHandlers = NULL; iPtr->limit.timeEvent = NULL; @@ -4378,11 +4237,6 @@ InheritLimitsFromMaster( Interp *slavePtr = (Interp *) slaveInterp; Interp *masterPtr = (Interp *) masterInterp; - if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) { - slavePtr->limit.active |= TCL_LIMIT_COMMANDS; - slavePtr->limit.cmdCount = 0; - slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity; - } if (masterPtr->limit.active & TCL_LIMIT_TIME) { slavePtr->limit.active |= TCL_LIMIT_TIME; memcpy(&slavePtr->limit.time, &masterPtr->limit.time, @@ -4394,195 +4248,6 @@ InheritLimitsFromMaster( /* *---------------------------------------------------------------------- * - * SlaveCommandLimitCmd -- - * - * Implementation of the [interp limit $i commands] and [$i limit - * commands] subcommands. See the interp manual page for a full - * description. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Depends on the arguments. - * - *---------------------------------------------------------------------- - */ - -static int -SlaveCommandLimitCmd( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ - int consumedObjc, /* Number of args already parsed. */ - int objc, /* Total number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const options[] = { - "-command", "-granularity", "-value", NULL - }; - enum Options { - OPT_CMD, OPT_GRAN, OPT_VAL - }; - Interp *iPtr = (Interp *) interp; - int index; - ScriptLimitCallbackKey key; - ScriptLimitCallback *limitCBPtr; - Tcl_HashEntry *hPtr; - - /* - * First, ensure that we are not reading or writing the calling - * interpreter's limits; it may only manipulate its children. Note that - * the low level API enforces this with Tcl_Panic, which we want to - * avoid. [Bug 3398794] - */ - - if (interp == slaveInterp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "limits on current interpreter inaccessible", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL); - return TCL_ERROR; - } - - if (objc == consumedObjc) { - Tcl_Obj *dictPtr; - - TclNewObj(dictPtr); - key.interp = slaveInterp; - key.type = TCL_LIMIT_COMMANDS; - hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); - if (hPtr != NULL) { - limitCBPtr = Tcl_GetHashValue(hPtr); - if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), - limitCBPtr->scriptObj); - } else { - goto putEmptyCommandInDict; - } - } else { - Tcl_Obj *empty; - - putEmptyCommandInDict: - TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[0], -1), empty); - } - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, - TCL_LIMIT_COMMANDS))); - - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { - Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); - } else { - Tcl_Obj *empty; - - TclNewObj(empty); - Tcl_DictObjPut(NULL, dictPtr, - Tcl_NewStringObj(options[2], -1), empty); - } - Tcl_SetObjResult(interp, dictPtr); - return TCL_OK; - } else if (objc == consumedObjc+1) { - if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum Options) index) { - case OPT_CMD: - key.interp = slaveInterp; - key.type = TCL_LIMIT_COMMANDS; - hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); - if (hPtr != NULL) { - limitCBPtr = Tcl_GetHashValue(hPtr); - if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { - Tcl_SetObjResult(interp, limitCBPtr->scriptObj); - } - } - break; - case OPT_GRAN: - Tcl_SetObjResult(interp, Tcl_NewIntObj( - Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); - break; - case OPT_VAL: - if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { - Tcl_SetObjResult(interp, - Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); - } - break; - } - return TCL_OK; - } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); - return TCL_ERROR; - } else { - int i, scriptLen = 0, limitLen = 0; - Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL; - int gran = 0, limit = 0; - - for (i=consumedObjc ; i<objc ; i+=2) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum Options) index) { - case OPT_CMD: - scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); - break; - case OPT_GRAN: - granObj = objv[i+1]; - if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { - return TCL_ERROR; - } - if (gran < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "granularity must be at least 1", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADVALUE", NULL); - return TCL_ERROR; - } - break; - case OPT_VAL: - limitObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); - if (limitLen == 0) { - break; - } - if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) { - return TCL_ERROR; - } - if (limit < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command limit value must be at least 0", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", - "BADVALUE", NULL); - return TCL_ERROR; - } - break; - } - } - if (scriptObj != NULL) { - SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp, - (scriptLen > 0 ? scriptObj : NULL)); - } - if (granObj != NULL) { - Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran); - } - if (limitObj != NULL) { - if (limitLen > 0) { - Tcl_LimitSetCommands(slaveInterp, limit); - Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS); - } else { - Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS); - } - } - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * * SlaveTimeLimitCmd -- * * Implementation of the [interp limit $i time] and [$i limit time] diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 827d89d..7249eb6 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -3,292 +3,1021 @@ * * This file contains the bytecode optimizer. * - * Copyright (c) 2013 by Donal Fellows. + * Copyright (c) 2013 by Miguel Sofer. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" #include "tclCompile.h" #include <assert.h> -/* - * Forward declarations. - */ +typedef struct optPad { + int codeSize; + int cache; + int *npaths; + int *scratch; + int modified; + Tcl_HashTable stack; + int first; +} optPad; + +static void markPath(CompileEnv *envPtr, int pc, optPad *padPtr, + int mark); +static int effectivePC(CompileEnv *envPtr, int pc, optPad *padPtr, int unshared); +static void optimizePush(CompileEnv *envPtr,optPad *padPtr, int pc); +static void MoveUnreachable(CompileEnv *envPtr, optPad *padPtr); +static void CompactCode(CompileEnv *envPtr, optPad *padPtr, + int shrinkInst); +static void Optimize(CompileEnv *envPtr, optPad *padPtr); + +static void Initialize(CompileEnv *envPtr, optPad *padPtr, int move); + +#define INIT_SIZE \ + int codeSize = padPtr->codeSize + +#define INIT_PATHS \ + int *PATHS = padPtr->npaths -static void AdvanceJumps(CompileEnv *envPtr); -static void ConvertZeroEffectToNOP(CompileEnv *envPtr); -static void LocateTargetAddresses(CompileEnv *envPtr, - Tcl_HashTable *tablePtr); -static void TrimUnreachable(CompileEnv *envPtr); +#define INIT_STACK \ + Tcl_HashTable *stackPtr = &padPtr->stack /* * Helper macros. */ -#define DefineTargetAddress(tablePtr, address) \ - ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew)) -#define IsTargetAddress(tablePtr, address) \ - (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL) #define AddrLength(address) \ (tclInstructionTable[*(unsigned char *)(address)].numBytes) #define InstLength(instruction) \ (tclInstructionTable[(unsigned char)(instruction)].numBytes) +#define InstEffect(instruction) \ + (tclInstructionTable[(unsigned char)(instruction)].stackEffect) +#define Op1Type(instruction) \ + (tclInstructionTable[(unsigned char)(instruction)].opTypes[0]) + +/* + * Macros used in the code compactor. + */ + +#define GET_INT1_AT_PC(pc) \ + TclGetInt1AtPtr(envPtr->codeStart + (pc)) + +#define GET_INT4_AT_PC(pc) \ + TclGetInt4AtPtr(envPtr->codeStart + (pc)) + +#define GET_UINT1_AT_PC(pc) \ + TclGetUInt1AtPtr(envPtr->codeStart + (pc)) + +#define GET_UINT4_AT_PC(pc) \ + TclGetUInt4AtPtr(envPtr->codeStart + (pc)) + +#define SET_INT1_AT_PC(i, pc) \ + TclStoreInt1AtPtr((i), envPtr->codeStart + (pc)) + +#define SET_INT4_AT_PC(i, pc) \ + TclStoreInt4AtPtr((i), envPtr->codeStart + (pc)) + +#define INST_AT_PC(pc) \ + (*(envPtr->codeStart + (pc))) + +#define NEXT_PC(pc) \ + pc + InstLength(INST_AT_PC(pc)) + +#define MARK(pc) \ + markPath(envPtr, (pc), padPtr, /* mark */ 1) + +#define UNMARK(pc) \ + markPath(envPtr, (pc), padPtr, /* mark */ 0) + +#define REPLACE(old, new) \ + MARK(new); UNMARK(old) + +#define UNSHARED(pc) (PATHS[pc] == 1) + +#define MODIFIED() padPtr->modified++ + +/* + * The code for following a path from a given PC. + */ + +#define FOLLOW(pc, unshared) \ + effectivePC(envPtr, (pc), padPtr, (unshared)) + /* * ---------------------------------------------------------------------- * - * LocateTargetAddresses -- + * OptimizeBytecode -- * - * Populate a hash table with places that we need to be careful around - * because they're the targets of various kinds of jumps and other - * non-local behavior. + * An optimizer for bytecode to replace TclOptimizeBytecode. * * ---------------------------------------------------------------------- */ +void +TclOptimizeBytecode( + void *env1Ptr) +{ + CompileEnv *envPtr = (CompileEnv *) env1Ptr; + int codeSize = (envPtr->codeNext - envPtr->codeStart); + int padSize = sizeof(optPad) + 4*codeSize*sizeof(int); + optPad *padPtr; + + padPtr = (optPad *) Tcl_AttemptAlloc(padSize); + if (!padPtr) { + /* Not enough memory to optimize this code */ + Tcl_Panic("** Not enough mem to optimize! **"); + return; + } + padPtr->codeSize = codeSize; + padPtr->cache = -1; + padPtr->npaths = &padPtr->first; + padPtr->scratch = &padPtr->npaths[2*codeSize + 1]; + + Tcl_InitHashTable(&padPtr->stack, TCL_ONE_WORD_KEYS); + + /* Simplify the code as much as possible without knowing the paths */ + + /* 1. Initial path marking, move unreachable code to after INST_DONE and + * compress */ + + Initialize(envPtr, padPtr, 1); + CompactCode(envPtr, padPtr, 0); + + /* 2. Iterate optimizations until all done */ + /* TODO: there MUST be a more efficient approach than relaxation? + * Possibly save the visit order on init, and process inverting that + * order. */ + + Optimize(envPtr, padPtr); + + /* 3. Initialize again to thread jumps and detect dead code. Finally + * remove all nops and unreachable code, reduce code size. */ + + Initialize(envPtr, padPtr, 0); + CompactCode(envPtr, padPtr, 1); + + Tcl_DeleteHashTable(&padPtr->stack); + Tcl_Free((char *) padPtr); +} + static void -LocateTargetAddresses( +Initialize( CompileEnv *envPtr, - Tcl_HashTable *tablePtr) + optPad *padPtr, + int move) { - unsigned char *currentInstPtr, *targetInstPtr; - int isNew, i; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; + INIT_PATHS; INIT_SIZE; + int i, last; + + /* + * Initialize PATHS to 0. + */ - Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS); + for (i=0; i < codeSize; i++) { + PATHS[i] = 0; + } /* - * The starts of commands represent target addresses. + * Compute the paths to reachable code */ - for (i=0 ; i<envPtr->numCommands ; i++) { - DefineTargetAddress(tablePtr, - envPtr->codeStart + envPtr->cmdMapPtr[i].codeOffset); - } + MARK(0); /* - * Find places where we should be careful about replacing instructions - * because they are the targets of various types of jumps. + * Note that "jumps" from ISC (INST_START_CMD) decompilation bailouts may + * hit targets that become otherwise unreachable after optimization. They + * need to be marked as reachable. + * Until we modify the implementation details of the ISC bailout, this needs + * to happen BEFORE the unreachable code is moved. */ - for (currentInstPtr = envPtr->codeStart ; - currentInstPtr < envPtr->codeNext ; - currentInstPtr += AddrLength(currentInstPtr)) { - switch (*currentInstPtr) { - case INST_JUMP1: - case INST_JUMP_TRUE1: - case INST_JUMP_FALSE1: - targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1); - goto storeTarget; - case INST_JUMP4: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE4: - case INST_START_CMD: - targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1); - goto storeTarget; - case INST_BEGIN_CATCH4: - targetInstPtr = envPtr->codeStart + envPtr->exceptArrayPtr[ - TclGetUInt4AtPtr(currentInstPtr+1)].codeOffset; - storeTarget: - DefineTargetAddress(tablePtr, targetInstPtr); - break; - case INST_JUMP_TABLE: - hPtr = Tcl_FirstHashEntry( - &JUMPTABLEINFO(envPtr, currentInstPtr+1)->hashTable, - &hSearch); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { - targetInstPtr = currentInstPtr + - PTR2INT(Tcl_GetHashValue(hPtr)); - DefineTargetAddress(tablePtr, targetInstPtr); - } - break; - case INST_RETURN_CODE_BRANCH: - for (i=TCL_ERROR ; i<TCL_CONTINUE+1 ; i++) { - DefineTargetAddress(tablePtr, currentInstPtr + 2*i - 1); + last = -1; + for (i = 0; i < envPtr->numCommands; i++) { + CmdLocation *cmdMapPtr = &envPtr->cmdMapPtr[i]; + if (cmdMapPtr->codeOffset == last) continue; + last = cmdMapPtr->codeOffset; + MARK(last + cmdMapPtr->numCodeBytes); + } + + /* + * Make sure that instructions that are only reachable as loop targets of + * reachable ranges are recognized as shared and reachable. Do not yet + * mark catch targets. + */ + + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + if (!IS_CATCH_RANGE(rangePtr) && + PATHS[rangePtr->codeOffset]) { + rangePtr->mainOffset = FOLLOW(rangePtr->mainOffset, 0); + MARK(rangePtr->mainOffset); + if (rangePtr->continueOffset != -1) { + rangePtr->continueOffset = FOLLOW(rangePtr->continueOffset, 0); + MARK(rangePtr->continueOffset); } - break; } } + if (move) { + //MoveUnreachable(envPtr, padPtr);//// + } + + /* + * Now insure that all remaining targets are marked as reachable, and also + * that they are properly marked as being multiple targets + */ + + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + if (IS_CATCH_RANGE(rangePtr)) { + MARK(rangePtr->mainOffset); + } + } +} + +/* + * ---------------------------------------------------------------------- + * + * CompactCode -- + * + * Remove all INST_NOPS and unreachable code. This also shrinks 4-insts + * to 1-insts where possible, reduces the code size, and updates all + * structs so that the CompileEnv remains consistent. + * + * ---------------------------------------------------------------------- + */ + +void +CompactCode( + CompileEnv *envPtr, + optPad *padPtr, + int shrinkInst) +{ + int codeSize = padPtr->codeSize; + int *PATHS = padPtr->npaths; + int *NEW = padPtr->scratch; + int pc, nops, i, nextpc; + unsigned char inst; + + /* + * Update range targets + */ + + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + int target; + + if (!PATHS[rangePtr->codeOffset]) continue; + target = FOLLOW(rangePtr->mainOffset, 0); + if (rangePtr->mainOffset != target) { + REPLACE(rangePtr->mainOffset, target); + rangePtr->mainOffset = target; + } + if (rangePtr->continueOffset >= 0) { + target = FOLLOW(rangePtr->continueOffset, 0); + if (rangePtr->continueOffset != target) { + REPLACE(rangePtr->continueOffset, target); + rangePtr->continueOffset = target; + } + } + } + /* - * Add a marker *after* the last bytecode instruction. WARNING: points to - * one past the end! + * First pass: compute new positions, shrink push and var access if required */ - DefineTargetAddress(tablePtr, currentInstPtr); + restart: + pc = 0; + nops = 0; + for (pc = 0; pc < codeSize; pc = nextpc) { + int arg, resize; + nextpc = NEXT_PC(pc); + inst = INST_AT_PC(pc); + NEW[pc] = pc - nops; /* new position */ + + if ((inst == INST_NOP) || !PATHS[pc]) { + nops += nextpc - pc; + continue; + } + if (!shrinkInst) continue; + + resize = 0; + switch (inst) { + case INST_PUSH4: + case INST_LOAD_SCALAR4: + case INST_LOAD_ARRAY4: + case INST_STORE_SCALAR4: + case INST_STORE_ARRAY4: + arg = GET_UINT4_AT_PC(pc+1); + resize = (arg < 256); + break; + + case INST_JUMP4: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + arg = GET_INT4_AT_PC(pc+1); + resize = ((arg <= 127) && (arg >= -128)); + break; + } + + if (resize) { + /* + * INST_XXX1 is always one less than INST_XXX4 + */ + + INST_AT_PC(pc) -= 1; + SET_INT1_AT_PC(arg, pc+1); + INST_AT_PC(pc+2) = INST_NOP; + INST_AT_PC(pc+3) = INST_NOP; + INST_AT_PC(pc+4) = INST_NOP; + nops +=3; + } + } + + if (nops == 0) { + return; + } + NEW[codeSize] = codeSize - nops; + /* - * Enter in the targets of exception ranges. + * Update range targets */ for (i=0 ; i<envPtr->exceptArrayNext ; i++) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + int target, after; + + if (!PATHS[rangePtr->codeOffset]) continue; + target = rangePtr->codeOffset; + after = rangePtr->codeOffset + rangePtr->numCodeBytes; + if (rangePtr->numCodeBytes < 0) { + /* + * A non-existent range; disable it completely + */ - if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - targetInstPtr = envPtr->codeStart + rangePtr->catchOffset; - DefineTargetAddress(tablePtr, targetInstPtr); - } else { - targetInstPtr = envPtr->codeStart + rangePtr->breakOffset; - DefineTargetAddress(tablePtr, targetInstPtr); - if (rangePtr->continueOffset >= 0) { - targetInstPtr = envPtr->codeStart + rangePtr->continueOffset; - DefineTargetAddress(tablePtr, targetInstPtr); + after = target; + } + rangePtr->codeOffset = NEW[target]; + rangePtr->numCodeBytes = NEW[after] - NEW[target]; + + target = FOLLOW(rangePtr->mainOffset, 0); + rangePtr->mainOffset = NEW[target]; + if (rangePtr->continueOffset >= 0) { + target = FOLLOW(rangePtr->continueOffset, 0); + rangePtr->continueOffset = NEW[target]; + } + } + + /* + * Update CmdLoc data + */ + + { + CmdLocation *mapPtr = envPtr->cmdMapPtr; + + for (i=0; i < envPtr->numCommands; i++) { + /* After the end of this command's code there is either another + * instruction, or else the end of the bytecode. Notice that + * numCodeBytes may lie miserably: fix that! + */ + + int start = mapPtr[i].codeOffset; + int next = start + mapPtr[i].numCodeBytes; + + if (next > codeSize) { + next = codeSize; } + mapPtr[i].codeOffset = NEW[start]; + mapPtr[i].numCodeBytes = NEW[next] - NEW[start]; } } + + /* + * Second pass: move code, update jump offsets, resize the code. + */ + + nops = 0; + for (pc = 0; pc < codeSize; pc = nextpc) { + int target, i; + + nextpc = NEXT_PC(pc); + inst = INST_AT_PC(pc); + if ((inst == INST_NOP) || !PATHS[pc]) { + continue; + } + + /* update jump offsets */ + + switch (inst) { + int offset; + ForeachInfo *infoPtr; + JumptableInfo *info2Ptr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + case INST_JUMP1: + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + target = pc + GET_INT1_AT_PC(pc+1); + offset = NEW[target]-NEW[pc]; + if ((offset == 2) && (inst == INST_JUMP1)) { + INST_AT_PC(pc) = INST_NOP; + INST_AT_PC(pc+1) = INST_NOP; + nops += 2; + } else { + SET_INT1_AT_PC(offset, pc+1); + } + break; + + case INST_JUMP4: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + target = pc + GET_INT4_AT_PC(pc+1); + offset = NEW[target]-NEW[pc]; + SET_INT4_AT_PC(offset, pc+1); + if (offset == 5) { + if (inst == INST_JUMP4) { + INST_AT_PC(pc) = INST_NOP; + INST_AT_PC(pc+1) = INST_NOP; + nops += 2; + goto push3nops; + } + } else if (shrinkInst && + (offset < 127) && (offset > -128)) { + INST_AT_PC(pc) -= 1; + SET_INT1_AT_PC(offset, pc+1); + push3nops: + INST_AT_PC(pc+2) = INST_NOP; + INST_AT_PC(pc+3) = INST_NOP; + INST_AT_PC(pc+4) = INST_NOP; + nops += 3; + } + break; + + case INST_FOREACH_START: + i = GET_UINT4_AT_PC(pc+1); + infoPtr = (ForeachInfo *) TclFetchAuxData(envPtr, i); + target = pc + 5 - infoPtr->jumpSize; + infoPtr->jumpSize = NEW[pc] + 5 - NEW[target]; + break; + + case INST_JUMP_TABLE: + i = GET_UINT4_AT_PC(pc+1); + info2Ptr = (JumptableInfo *) TclFetchAuxData(envPtr, i); + hPtr = Tcl_FirstHashEntry(&info2Ptr->hashTable, &hSearch); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { + target = pc + PTR2INT(Tcl_GetHashValue(hPtr)); + Tcl_SetHashValue(hPtr, INT2PTR(NEW[target]-NEW[pc])); + } + break; + } + + /* move up opcode and operands, en block */ + for (i=0; pc+i < nextpc; i++) { + int old = pc+i, new = NEW[pc] + i; + INST_AT_PC(new) = INST_AT_PC(old); + PATHS[new] += PATHS[old]; + } + } + envPtr->codeNext = envPtr->codeStart + NEW[codeSize]; + padPtr->codeSize = NEW[codeSize]; + + /* + * Restart until all done; should be rare. Other possible criteria: + * - restart if (nops > x*codeSize), if new jumps, ... + * - use back jumps as loop indicators, restart only if some backjmp is + * reduced in size + * - don't restart, bet that there's not much more to be done + */ + + if (nops) { + codeSize = padPtr->codeSize; + goto restart; + } } /* * ---------------------------------------------------------------------- * - * TrimUnreachable -- + * effectivePC -- * - * Converts code that provably can't be executed into NOPs and reduces - * the overall reported length of the bytecode where that is possible. + * Utility functions. Find the effective newpc that will be executed when + * we get at pc, by following through jumps and nops. * * ---------------------------------------------------------------------- */ -static void -TrimUnreachable( - CompileEnv *envPtr) +int +effectivePC( + CompileEnv *envPtr, + int pc, + optPad *padPtr, + int unshared) { - unsigned char *currentInstPtr; - Tcl_HashTable targets; - - LocateTargetAddresses(envPtr, &targets); + unsigned char inst; + int start = pc, new; + int *PATHS = padPtr->npaths; - for (currentInstPtr = envPtr->codeStart ; - currentInstPtr < envPtr->codeNext-1 ; - currentInstPtr += AddrLength(currentInstPtr)) { - int clear = 0; - - if (*currentInstPtr != INST_DONE) { - continue; + while (1) { + if (unshared && !UNSHARED(pc)) { + return pc; } + inst = INST_AT_PC(pc); + switch (inst) { + case INST_NOP: + new = pc + 1; + break; + + case INST_JUMP1: + new = pc + GET_INT1_AT_PC(pc+1); + break; - while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) { - clear += AddrLength(currentInstPtr + 1 + clear); + case INST_JUMP4: + new = pc + GET_INT4_AT_PC(pc+1); + break; + + default: + return pc; } - if (currentInstPtr + 1 + clear == envPtr->codeNext) { - envPtr->codeNext -= clear; - } else { - while (clear --> 0) { - *(currentInstPtr + 1 + clear) = INST_NOP; - } + if (new == start) { + /* infinite loop! how do we kill it in <= 5 bytes? */ + INST_AT_PC(new) = INST_CONTINUE; + return pc; } + pc = new; } - - Tcl_DeleteHashTable(&targets); } /* * ---------------------------------------------------------------------- * - * ConvertZeroEffectToNOP -- + * markPath -- * - * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also - * replace PUSH empty/STR_CONCAT and TRY_CVT_NUMERIC (when followed by an - * operation that guarantees the check for arithmeticity) and eliminate - * LNOT when we can invert the following JUMP condition. + * Count the number of paths reaching an instruction, after threading the + * jumps. * * ---------------------------------------------------------------------- */ +#define PUSH(pc) \ + iPUSH((pc), padPtr, mark) + +#define POP(pc) \ + ((pc) = iPOP(padPtr)) + static void -ConvertZeroEffectToNOP( - CompileEnv *envPtr) +iPUSH( + int pc, + optPad *padPtr, + int mark) +{ + INIT_SIZE; INIT_PATHS; INIT_STACK; + int tmp; + int *cachePtr = &padPtr->cache; + int cached = *cachePtr; + + if (pc >= codeSize) return; + + tmp = ((!mark && (--PATHS[pc] == 0)) + || (mark && (++PATHS[pc] == 1))); + + if (tmp) { + if (cached != -1) { + Tcl_CreateHashEntry(stackPtr, INT2PTR(cached), &tmp); + } + *cachePtr = pc; + } +} + +static int +iPOP( + optPad *padPtr) { - unsigned char *currentInstPtr; - int size; - Tcl_HashTable targets; - - LocateTargetAddresses(envPtr, &targets); - for (currentInstPtr = envPtr->codeStart ; - currentInstPtr < envPtr->codeNext ; currentInstPtr += size) { - int blank = 0, i, nextInst; - - size = AddrLength(currentInstPtr); - while ((currentInstPtr + size < envPtr->codeNext) - && *(currentInstPtr+size) == INST_NOP) { - if (IsTargetAddress(&targets, currentInstPtr + size)) { + INIT_STACK; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + int pc; + int cached = padPtr->cache; + + if (cached != -1) { + padPtr->cache = -1; + return cached; + } + + hPtr = Tcl_FirstHashEntry(stackPtr, &hSearch); + if (!hPtr) { + return -1; + } + + pc = PTR2INT(Tcl_GetHashKey(stackPtr, hPtr)); + Tcl_DeleteHashEntry(hPtr); + return pc; +} + +void +markPath( + CompileEnv *envPtr, + int pc, + optPad *padPtr, + int mark) +{ + INIT_PATHS; + unsigned char inst; + int nextpc, target; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + /* + * Note that each pc will be followed at most once, so that only branch + * targets have a PATHS count > 1. + */ + + if (mark) { + if (PATHS[pc] > 0) { + PATHS[pc]++; + return; + } + } else { + if (PATHS[pc] > 1) { + PATHS[pc]--; + return; + } else if (PATHS[pc] <= 0) { + PATHS[pc] = 0; + return; + } + } + + PUSH(pc); + while (POP(pc) != -1) { + inst = INST_AT_PC(pc); + nextpc = NEXT_PC(pc); + mark = (PATHS[pc] > 0); + switch(inst) { + case INST_DONE: + case INST_TAILCALL: + case INST_CONTINUE: + case INST_BREAK: + break; + + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + PUSH(nextpc); + case INST_JUMP1: + PUSH(pc + GET_INT1_AT_PC(pc+1)); + break; + + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + PUSH(nextpc); + case INST_JUMP4: + target = pc + GET_INT4_AT_PC(pc+1); + if (mark) { + target = FOLLOW(target, 0); + SET_INT4_AT_PC(target-pc, pc+1); + } + PUSH(target); + break; + + case INST_JUMP_TABLE: + hPtr = Tcl_FirstHashEntry( + &JUMPTABLEINFO(envPtr, envPtr->codeStart+pc+1)->hashTable, + &hSearch); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { + target = pc + PTR2INT(Tcl_GetHashValue(hPtr)); + if (mark) { + target = FOLLOW(target, 0); + Tcl_SetHashValue(hPtr, INT2PTR(target - pc)); + } + PUSH(target); + } + PUSH(nextpc); + break; + + default: + PUSH(nextpc); break; - } - size += InstLength(INST_NOP); } - if (IsTargetAddress(&targets, currentInstPtr + size)) { + } +#undef PUSH +#undef POP +} + +/* + * Move exception handling code to after INST_DONE. ASSUMES that there are no + * FORCED 1-jumps from exception handling code to normal code. + */ + +void +MoveUnreachable( + CompileEnv *envPtr, + optPad *padPtr) +{ + INIT_PATHS; + int *NEW = padPtr->scratch; + int pc, nextpc, target, inst; + int fixend, curr, i, imax; + ExceptionRange *rangePtr; + JumptableInfo *infoPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + int codeSize = padPtr->codeSize; + + /* + * Move unreachable code out to after done, after checking there is enough + * room to do it - be generous. + */ + + if ((envPtr->codeEnd - envPtr->codeStart) < + 2 * (envPtr->codeNext - envPtr->codeStart)) { + TclExpandCodeArray(envPtr); + } + + for (pc = 0; pc < codeSize; pc = nextpc) { + nextpc = NEXT_PC(pc); + + if (PATHS[pc] > 0) { + NEW[pc] = pc; continue; } - nextInst = *(currentInstPtr + size); - switch (*currentInstPtr) { - case INST_PUSH1: - if (nextInst == INST_POP) { - blank = size + InstLength(nextInst); - } else if (nextInst == INST_STR_CONCAT1 - && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { - Tcl_Obj *litPtr = TclFetchLiteral(envPtr, - TclGetUInt1AtPtr(currentInstPtr + 1)); - int numBytes; - - (void) Tcl_GetStringFromObj(litPtr, &numBytes); - if (numBytes == 0) { - blank = size + InstLength(nextInst); + + curr = (envPtr->codeNext - envPtr->codeStart); + + inst = INST_AT_PC(pc); + NEW[pc] = curr; + INST_AT_PC(curr) = INST_AT_PC(pc); + + /* jump back iff next inst is reachable */ + fixend = (nextpc >= codeSize)? 0 : PATHS[nextpc]; + + switch (inst) { + /* + * There are no 1-jumps to consider. + */ + + case INST_JUMP4: + fixend = 0; + case INST_JUMP_FALSE4: + case INST_JUMP_TRUE4: + target = pc + GET_INT4_AT_PC(pc+1); + SET_INT4_AT_PC(target, curr+1); + break; + + case INST_JUMP_TABLE: + i = GET_UINT4_AT_PC(pc+1); + SET_INT4_AT_PC(i, curr+1); + infoPtr = (JumptableInfo *) TclFetchAuxData(envPtr, i); + hPtr = Tcl_FirstHashEntry(&infoPtr->hashTable, &hSearch); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { + target = pc + PTR2INT(Tcl_GetHashValue(hPtr)); + Tcl_SetHashValue(hPtr, INT2PTR(target)); } - } - break; - case INST_PUSH4: - if (nextInst == INST_POP) { - blank = size + 1; - } else if (nextInst == INST_STR_CONCAT1 - && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { - Tcl_Obj *litPtr = TclFetchLiteral(envPtr, - TclGetUInt4AtPtr(currentInstPtr + 1)); - int numBytes; - - (void) Tcl_GetStringFromObj(litPtr, &numBytes); - if (numBytes == 0) { - blank = size + InstLength(nextInst); + break; + + case INST_DONE: + case INST_TAILCALL: + case INST_CONTINUE: + case INST_BREAK: + fixend = 0; + break; + + default: + for (i=1; i < nextpc-pc; i++) { + INST_AT_PC(curr+i) = INST_AT_PC(pc+i); + NEW[pc+i] = curr+i; } - } - break; + break; + } + envPtr->codeNext += (nextpc-pc); + + if (fixend) { + /* add a jump back to ok code */ + curr = (envPtr->codeNext - envPtr->codeStart); + envPtr->codeNext += 5; + INST_AT_PC(curr) = INST_JUMP4; + SET_INT4_AT_PC(nextpc, curr+1); + } + } - case INST_LNOT: - switch (nextInst) { - case INST_JUMP_TRUE1: - blank = size; - *(currentInstPtr + size) = INST_JUMP_FALSE1; + /* + * The code has been moved, jump targets are all absolute. Pass over the + * moved code, updating jump targets to the correct (relative) value. + */ + + for (pc = codeSize; + pc < envPtr->codeNext-envPtr->codeStart; + pc = nextpc) { + nextpc = NEXT_PC(pc); + inst = INST_AT_PC(pc); + NEW[pc] = pc; + PATHS[pc] = 0; + + switch (inst) { + case INST_JUMP4: + case INST_JUMP_FALSE4: + case INST_JUMP_TRUE4: + target = NEW[GET_INT4_AT_PC(pc+1)]; + SET_INT4_AT_PC(target-pc, pc+1); break; - case INST_JUMP_FALSE1: - blank = size; - *(currentInstPtr + size) = INST_JUMP_TRUE1; + + case INST_JUMP_TABLE: + infoPtr = (JumptableInfo *) TclFetchAuxData(envPtr, GET_UINT4_AT_PC(pc+1)); + hPtr = Tcl_FirstHashEntry(&infoPtr->hashTable, &hSearch); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { + target = NEW[PTR2INT(Tcl_GetHashValue(hPtr))]; + Tcl_SetHashValue(hPtr, INT2PTR(target-pc)); + } break; + } + } + + /* Reset things to normal */ + + padPtr->codeSize = envPtr->codeNext - envPtr->codeStart; + + /* Update all ranges and targets */ + + imax = envPtr->exceptArrayNext; + for (i = 0 ; i < imax; i++) { + rangePtr = &envPtr->exceptArrayPtr[i]; + target = FOLLOW(NEW[rangePtr->mainOffset], 0); + rangePtr->mainOffset = target; + if (IS_CATCH_RANGE(rangePtr)) { + MARK(target); + } else if (rangePtr->continueOffset >= 0) { + rangePtr->continueOffset = FOLLOW(NEW[rangePtr->continueOffset], 0); + } + target = rangePtr->codeOffset + rangePtr->numCodeBytes; + rangePtr->codeOffset = NEW[rangePtr->codeOffset]; + rangePtr->numCodeBytes = NEW[target]-rangePtr->codeOffset; + } +} + +/* + * ---------------------------------------------------------------------- + * + * Optimize -- + * + * Replaces instructions and threads jumps in order to speed up the + * execution. It also marks unreachable code, replacing it with NOPS that + * can later be removed. + * + * ---------------------------------------------------------------------- + */ + +void +Optimize( + CompileEnv *envPtr, + optPad *padPtr) +{ + INIT_PATHS; + int codeSize = padPtr->codeSize; + int pc, nextpc, tmp; + unsigned char inst; + int negate; + + restart: + + padPtr->modified = 0; + for (pc = 0; pc < codeSize; pc = nextpc) { + nextpc = NEXT_PC(pc); + inst = INST_AT_PC(pc); + if ((inst == INST_NOP) || !PATHS[pc]) continue; + + switch(inst) { + case INST_PUSH4: + optimizePush(envPtr, padPtr, pc); + break; + case INST_JUMP_TRUE4: - blank = size; - *(currentInstPtr + size) = INST_JUMP_FALSE4; + case INST_JUMP_FALSE4: { + int t1, tgt, new; + + /* + * detect stupid jump-around-jump, untangle + * + * <-- PC: CONDJMP->NEW !CONDJMP->TGT + * | T1: JMP->TGT <=> NOP + * --> NEW: FOO FOO + */ + + new = FOLLOW(pc + GET_INT4_AT_PC(pc+1), 0); + t1 = FOLLOW(NEXT_PC(pc), 1); + if (UNSHARED(t1) && (INST_AT_PC(t1) == INST_JUMP4) && + (new == FOLLOW(NEXT_PC(t1), 0))) { + /* ENTANGLED! undo ... */ + INST_AT_PC(t1) = INST_NOP; + tgt = t1 + GET_INT4_AT_PC(t1+1); + tgt = FOLLOW(tgt, 0); + INST_AT_PC(pc) ^= 2; + SET_INT4_AT_PC(tgt-pc, pc+1); + MODIFIED(); + } break; - case INST_JUMP_FALSE4: - blank = size; - *(currentInstPtr + size) = INST_JUMP_TRUE4; + } + + case INST_BREAK: + case INST_CONTINUE: { + int range = GET_INT4_AT_PC(pc+1); + ExceptionRange *rangePtr = envPtr->exceptArrayPtr + range; + + if ((range == -1) || !rangePtr || IS_CATCH_RANGE(rangePtr)) break; + if ((rangePtr->codeOffset == -1) || !PATHS[rangePtr->codeOffset]) break; + + if (inst == INST_BREAK) { + tmp = FOLLOW(rangePtr->mainOffset, 0); + } else { + if (rangePtr->continueOffset < 0) { + Tcl_Panic("Optimizer found continueOffset==%i, should not happen!", rangePtr->continueOffset); + } + tmp = FOLLOW(rangePtr->continueOffset, 0); + } + INST_AT_PC(pc) = INST_JUMP4; + SET_INT4_AT_PC(tmp - pc, pc+1); + MODIFIED(); break; } - break; - case INST_TRY_CVT_TO_NUMERIC: - switch (nextInst) { - case INST_JUMP_TRUE1: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE1: - case INST_JUMP_FALSE4: + case INST_LNOT: + negate = 1; + tmp = nextpc; + redoInstLNot: + tmp = FOLLOW(tmp, 1); + if (!UNSHARED(tmp)) break; + switch(INST_AT_PC(tmp)) { + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + if (negate) { + /* Trick: this transforms to the negation! */ + INST_AT_PC(tmp) ^= 2; + } + INST_AT_PC(pc) = INST_NOP; + MODIFIED(); + break; + + case INST_LNOT: + negate = !negate; + + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + tmp++; + goto redoInstLNot; + } + break; + + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + tmp = FOLLOW(nextpc, 0); + switch (INST_AT_PC(tmp)) { + case INST_JUMP_TRUE1: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE1: + case INST_JUMP_FALSE4: + case INST_INCR_SCALAR1: + case INST_INCR_ARRAY1: + case INST_INCR_ARRAY_STK: + case INST_INCR_SCALAR_STK: + case INST_INCR_STK: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_LE: + case INST_GT: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + INST_AT_PC(pc) = INST_NOP; + MODIFIED(); + break; + + default: + break; + } + break; + case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: - case INST_LOR: - case INST_LAND: case INST_EQ: case INST_NEQ: case INST_LT: @@ -306,135 +1035,102 @@ ConvertZeroEffectToNOP( case INST_SUB: case INST_DIV: case INST_MULT: - case INST_LNOT: case INST_BITNOT: case INST_UMINUS: - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - blank = size; + tmp = FOLLOW(nextpc, 1); + if (!UNSHARED(tmp)) break; + switch (INST_AT_PC(tmp)) { + case INST_TRY_CVT_TO_NUMERIC: + case INST_UPLUS: + INST_AT_PC(tmp) = INST_NOP; + MODIFIED(); + break; + } break; - } - break; } + } - if (blank > 0) { - for (i=0 ; i<blank ; i++) { - *(currentInstPtr + i) = INST_NOP; - } - size = blank; - } + if (padPtr->modified) { + goto restart; } - Tcl_DeleteHashTable(&targets); } -/* - * ---------------------------------------------------------------------- - * - * AdvanceJumps -- - * - * Advance jumps past NOPs and chained JUMPs. After this runs, the only - * JUMPs that jump to a NOP or a JUMP will be length-1 ones that run out - * of room in their opcode to be targeted to where they really belong. - * - * ---------------------------------------------------------------------- - */ - -static void -AdvanceJumps( - CompileEnv *envPtr) +void +optimizePush( + CompileEnv *envPtr, + optPad *padPtr, + int pc) { - unsigned char *currentInstPtr; - Tcl_HashTable jumps; - - for (currentInstPtr = envPtr->codeStart ; - currentInstPtr < envPtr->codeNext-1 ; - currentInstPtr += AddrLength(currentInstPtr)) { - int offset, delta, isNew; - - switch (*currentInstPtr) { - case INST_JUMP1: - case INST_JUMP_TRUE1: - case INST_JUMP_FALSE1: - offset = TclGetInt1AtPtr(currentInstPtr + 1); - Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); - for (delta=0 ; offset+delta != 0 ;) { - if (offset + delta < -128 || offset + delta > 127) { - break; - } - Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); - if (!isNew) { - offset = TclGetInt1AtPtr(currentInstPtr + 1); - break; - } - offset += delta; - switch (*(currentInstPtr + offset)) { - case INST_NOP: - delta = InstLength(INST_NOP); - continue; - case INST_JUMP1: - delta = TclGetInt1AtPtr(currentInstPtr + offset + 1); - continue; - case INST_JUMP4: - delta = TclGetInt4AtPtr(currentInstPtr + offset + 1); - continue; - } - break; - } - Tcl_DeleteHashTable(&jumps); - TclStoreInt1AtPtr(offset, currentInstPtr + 1); - continue; + int inst, i, target, tmp; + Tcl_Obj *objPtr; + int negate = 0; + + if (INST_AT_PC(pc) != INST_PUSH4) return; + + tmp = FOLLOW(NEXT_PC(pc), 0); + inst = INST_AT_PC(tmp); + objPtr = envPtr->literalArrayPtr[GET_UINT4_AT_PC(pc+1)].objPtr; - case INST_JUMP4: + redoSwitch: + switch (inst) { + case INST_POP: + tmp = FOLLOW(tmp + 1, 0); + INST_AT_PC(pc) = INST_JUMP4; + SET_INT4_AT_PC(tmp - pc, pc+1); + MODIFIED(); + return; + + case INST_LNOT: + negate = !negate; + tmp = FOLLOW(tmp + 1, 0); + inst = INST_AT_PC(tmp); + goto redoSwitch; + + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + if (Tcl_GetIntFromObj(NULL, objPtr, &i) == TCL_ERROR) { + return; + } + tmp = FOLLOW(tmp + 1, 0); + inst = INST_AT_PC(tmp); + goto redoSwitch; + case INST_JUMP_TRUE4: case INST_JUMP_FALSE4: - Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); - Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew); - for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) { - Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); - if (!isNew) { - offset = TclGetInt4AtPtr(currentInstPtr + 1); - break; - } - switch (*(currentInstPtr + offset)) { - case INST_NOP: - offset += InstLength(INST_NOP); - continue; - case INST_JUMP1: - offset += TclGetInt1AtPtr(currentInstPtr + offset + 1); - continue; - case INST_JUMP4: - offset += TclGetInt4AtPtr(currentInstPtr + offset + 1); - continue; + if (Tcl_GetBooleanFromObj(NULL, objPtr, &i) == TCL_ERROR) { + return; + } + /* let i indicate if we take the jump or not */ + if ((i&&!negate) || (!i && negate)) { + i = ((inst == INST_JUMP_TRUE1) || (inst == INST_JUMP_TRUE4)); + } else { + i = ((inst == INST_JUMP_FALSE1) || (inst == INST_JUMP_FALSE4)); + } + if (i) { + switch (inst) { + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + target = tmp + GET_INT1_AT_PC(tmp+1); + break; + + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + target = tmp + GET_INT4_AT_PC(tmp+1); + break; } - break; + } else { + target = NEXT_PC(tmp); } - Tcl_DeleteHashTable(&jumps); - TclStoreInt4AtPtr(offset, currentInstPtr + 1); - continue; - } + target = FOLLOW(target, 0); + INST_AT_PC(pc) = INST_JUMP4; + SET_INT4_AT_PC(target-pc, pc+1); + MODIFIED(); + return; } } /* - * ---------------------------------------------------------------------- - * - * TclOptimizeBytecode -- - * - * A very simple peephole optimizer for bytecode. - * - * ---------------------------------------------------------------------- - */ - -void -TclOptimizeBytecode( - void *envPtr) -{ - ConvertZeroEffectToNOP(envPtr); - AdvanceJumps(envPtr); - TrimUnreachable(envPtr); -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5b7a1cd..af2254b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1309,14 +1309,14 @@ const TclStubs tclStubs = { Tcl_LimitReady, /* 522 */ Tcl_LimitCheck, /* 523 */ Tcl_LimitExceeded, /* 524 */ - Tcl_LimitSetCommands, /* 525 */ + 0, /* 525 */ Tcl_LimitSetTime, /* 526 */ Tcl_LimitSetGranularity, /* 527 */ Tcl_LimitTypeEnabled, /* 528 */ Tcl_LimitTypeExceeded, /* 529 */ Tcl_LimitTypeSet, /* 530 */ Tcl_LimitTypeReset, /* 531 */ - Tcl_LimitGetCommands, /* 532 */ + 0, /* 532 */ Tcl_LimitGetTime, /* 533 */ Tcl_LimitGetGranularity, /* 534 */ Tcl_SaveInterpState, /* 535 */ diff --git a/tests/assemble.test b/tests/assemble.test deleted file mode 100644 index b0487e6..0000000 --- a/tests/assemble.test +++ /dev/null @@ -1,3292 +0,0 @@ -# assemble.test -- -# -# Test suite for the 'tcl::unsupported::assemble' command -# -# 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. -#----------------------------------------------------------------------------- - -# Commands covered: assemble - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 - namespace import -force ::tcltest::* -} -namespace eval tcl::unsupported {namespace export assemble} -namespace import tcl::unsupported::assemble - -# Procedure to make code that fills the literal and local variable tables, to -# force instructions to spill to four bytes. - -proc fillTables {} { - set s {} - set sep {} - for {set i 0} {$i < 256} {incr i} { - append s $sep [list set v$i literal$i] - set sep \n - } - return $s -} - -testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { - proc getbytes {} { - set lines [split [memory info] \n] - return [lindex $lines 3 3] - } - proc leaktest {script {iterations 3}} { - set end [getbytes] - for {set i 0} {$i < $iterations} {incr i} { - uplevel 1 $script - set tmp $end - set end [getbytes] - } - return [expr {$end - $tmp}] - } -} - -# assemble-1 - TclNRAssembleObjCmd - -test assemble-1.1 {wrong # args, direct eval} { - -body { - eval [list assemble] - } - -returnCodes error - -result {wrong # args*} - -match glob -} -test assemble-1.2 {wrong # args, direct eval} { - -body { - eval [list assemble too many] - } - -returnCodes error - -result {wrong # args*} - -match glob -} -test assemble-1.3 {error reporting, direct eval} { - -body { - list [catch { - eval [list assemble { - # bad opcode - rubbish - }] - } result] $result $errorInfo - } - -match glob - -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":* - while executing -"rubbish" - ("assemble" body, line 3)*}} - -cleanup {unset result} -} -test assemble-1.4 {simple direct eval} { - -body { - eval [list assemble {push {this is a test}}] - } - -result {this is a test} -} - -# assemble-2 - CompileAssembleObj - -test assemble-2.1 {bytecode reuse, direct eval} { - -body { - set x {push "this is a test"} - list [eval [list assemble $x]] \ - [eval [list assemble $x]] - } - -result {{this is a test} {this is a test}} -} -test assemble-2.2 {bytecode discard, direct eval} { - -body { - set x {load value} - proc p1 {x} { - set value value1 - assemble $x - } - proc p2 {x} { - set a b - set value value2 - assemble $x - } - list [p1 $x] [p2 $x] - } - -result {value1 value2} - -cleanup { - unset x - rename p1 {} - rename p2 {} - } -} -test assemble-2.3 {null script, direct eval} { - -body { - set x {} - assemble $x - } - -result {} - -cleanup {unset x} -} - -# assemble-3 - TclCompileAssembleCmd - -test assemble-3.1 {wrong # args, compiled path} { - -body { - proc x {} { - assemble - } - x - } - -returnCodes error - -match glob - -result {wrong # args:*} -} -test assemble-3.2 {wrong # args, compiled path} { - -body { - proc x {} { - assemble too many - } - x - } - -returnCodes error - -match glob - -result {wrong # args:*} - -cleanup { - rename x {} - } -} - -# assemble-4 - TclAssembleCode mainline - -test assemble-4.1 {syntax error} { - -body { - proc x {} { - assemble { - {}extra - } - } - list [catch x result] $result $::errorInfo - } - -cleanup { - rename x {} - unset result - } - -match glob - -result {1 {extra characters after close-brace} {extra characters after close-brace - while executing -"{}e" - ("assemble" body, line 2)*}} -} -test assemble-4.2 {null command} { - -body { - proc x {} { - assemble { - push hello; pop;;push goodbye - } - } - x - } - -result goodbye - -cleanup { - rename x {} - } -} - -# assemble-5 - GetNextOperand off-nominal cases - -test assemble-5.1 {unsupported expansion} { - -body { - proc x {y} { - assemble { - {*}$y - } - } - list [catch {x {push hello}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup { - rename x {} - unset result - } -} -test assemble-5.2 {unsupported substitution} { - -body { - proc x {y} { - assemble { - $y - } - } - list [catch {x {nop}} result] $result $::errorCode - } - -cleanup { - rename x {} - unset result - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} -} -test assemble-5.3 {unsupported substitution} { - -body { - proc x {} { - assemble { - [x] - } - } - list [catch {x} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} -} -test assemble-5.4 {backslash substitution} { - -body { - proc x {} { - assemble { - p\x75sh\ - hello\ world - } - } - x - } - -cleanup { - rename x {} - } - -result {hello world} -} - -# assemble-6 - ASSEM_PUSH - -test assemble-6.1 {push, wrong # args} { - -body { - assemble push - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-6.2 {push, wrong # args} { - -body { - assemble {push too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-6.3 {push} { - -body { - eval [list assemble {push hello}] - } - -result hello -} -test assemble-6.4 {push4} { - -body { - proc x {} " - [fillTables] - assemble {push hello} - " - x - } - -cleanup { - rename x {} - } - -result hello -} - -# assemble-7 - ASSEM_1BYTE - -test assemble-7.1 {add, wrong # args} { - -body { - assemble {add excess} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-7.2 {add} { - -body { - assemble { - push 2 - push 2 - add - } - } - -result {4} -} -test assemble-7.3 {appendArrayStk} { - -body { - set a(b) {hello, } - assemble { - push a - push b - push world - appendArrayStk - } - set a(b) - } - -result {hello, world} - -cleanup {unset a} -} -test assemble-7.4 {appendStk} { - -body { - set a {hello, } - assemble { - push a - push world - appendStk - } - set a - } - -result {hello, world} - -cleanup {unset a} -} -test assemble-7.5 {bitwise ops} { - -body { - list \ - [assemble {push 0b1100; push 0b1010; bitand}] \ - [assemble {push 0b1100; bitnot}] \ - [assemble {push 0b1100; push 0b1010; bitor}] \ - [assemble {push 0b1100; push 0b1010; bitxor}] - } - -result {8 -13 14 6} -} -test assemble-7.6 {div} { - -body { - assemble {push 999999; push 7; div} - } - -result 142857 -} -test assemble-7.7 {dup} { - -body { - assemble { - push 1; dup; dup; add; dup; add; dup; add; add - } - } - -result 9 -} -test assemble-7.8 {eq} { - -body { - list \ - [assemble {push able; push baker; eq}] \ - [assemble {push able; push able; eq}] - } - -result {0 1} -} -test assemble-7.9 {evalStk} { - -body { - assemble { - push {concat test 7.3} - evalStk - } - } - -result {test 7.3} -} -test assemble-7.9a {evalStk, syntax} { - -body { - assemble { - push {{}bad} - evalStk - } - } - -returnCodes error - -result {extra characters after close-brace} -} -test assemble-7.9b {evalStk, backtrace} { - -body { - proc y {z} { - error testing - } - proc x {} { - assemble { - push { - # test error in evalStk - y asd - } - evalStk - } - } - list [catch x result] $result $errorInfo - } - -result {1 testing {testing - while executing -"error testing" - (procedure "y" line 2) - invoked from within -"y asd"*}} - -match glob - -cleanup { - rename y {} - rename x {} - } -} -test assemble-7.10 {existArrayStk} { - -body { - proc x {name key} { - set a(b) c - assemble { - load name; load key; existArrayStk - } - } - list [x a a] [x a b] [x b a] [x b b] - } - -result {0 1 0 0} - -cleanup {rename x {}} -} -test assemble-7.11 {existStk} { - -body { - proc x {name} { - set a b - assemble { - load name; existStk - } - } - list [x a] [x b] - } - -result {1 0} - -cleanup {rename x {}} -} -test assemble-7.12 {expon} { - -body { - assemble {push 3; push 4; expon} - } - -result 81 -} -test assemble-7.13 {exprStk} { - -body { - assemble { - push {acos(-1)} - exprStk - } - } - -result 3.141592653589793 -} -test assemble-7.13a {exprStk, syntax} { - -body { - assemble { - push {2+} - exprStk - } - } - -returnCodes error - -result {missing operand at _@_ -in expression "2+_@_"} -} -test assemble-7.13b {exprStk, backtrace} { - -body { - proc y {z} { - error testing - } - proc x {} { - assemble { - push {[y asd]} - exprStk - } - } - list [catch x result] $result $errorInfo - } - -result {1 testing {testing - while executing -"error testing" - (procedure "y" line 2) - invoked from within -"y asd"*}} - -match glob - -cleanup { - rename y {} - rename x {} - } -} -test assemble-7.14 {ge gt le lt} { - -body { - proc x {a b} { - list [assemble {load a; load b; ge}] \ - [assemble {load a; load b; gt}] \ - [assemble {load a; load b; le}] \ - [assemble {load a; load b; lt}] - } - list [x 0 0] [x 0 1] [x 1 0] - } - -result {{1 0 1 0} {0 0 1 1} {1 1 0 0}} - -cleanup {rename x {}} -} -test assemble-7.15 {incrArrayStk} { - -body { - proc x {} { - set a(b) 5 - assemble { - push a; push b; push 7; incrArrayStk - } - } - x - } - -result 12 - -cleanup {rename x {}} -} -test assemble-7.16 {incrStk} { - -body { - proc x {} { - set a 5 - assemble { - push a; push 7; incrStk - } - } - x - } - -result 12 - -cleanup {rename x {}} -} -test assemble-7.17 {land/lor} { - -body { - proc x {a b} { - list \ - [assemble {load a; load b; land}] \ - [assemble {load a; load b; lor}] - } - list [x 0 0] [x 0 23] [x 35 0] [x 47 59] - } - -result {{0 0} {0 1} {0 1} {1 1}} - -cleanup {rename x {}} -} -test assemble-7.18 {lappendArrayStk} { - -body { - proc x {} { - set able(baker) charlie - assemble { - push able - push baker - push dog - lappendArrayStk - } - } - x - } - -result {charlie dog} - -cleanup {rename x {}} -} -test assemble-7.19 {lappendStk} { - -body { - proc x {} { - set able baker - assemble { - push able - push charlie - lappendStk - } - } - x - } - -result {baker charlie} - -cleanup {rename x {}} -} -test assemble-7.20 {listIndex} { - -body { - assemble { - push {a b c d} - push 2 - listIndex - } - } - -result c -} -test assemble-7.21 {listLength} { - -body { - assemble { - push {a b c d} - listLength - } - } - -result 4 -} -test assemble-7.22 {loadArrayStk} { - -body { - proc x {} { - set able(baker) charlie - assemble { - push able - push baker - loadArrayStk - } - } - x - } - -result charlie - -cleanup {rename x {}} -} -test assemble-7.23 {loadStk} { - -body { - proc x {} { - set able baker - assemble { - push able - loadStk - } - } - x - } - -result baker - -cleanup {rename x {}} -} -test assemble-7.24 {lsetList} { - -body { - proc x {} { - set l {{a b} {c d} {e f} {g h}} - assemble { - push {2 1}; push i; load l; lsetList - } - } - x - } - -result {{a b} {c d} {e i} {g h}} -} -test assemble-7.25 {lshift} { - -body { - assemble {push 16; push 4; lshift} - } - -result 256 -} -test assemble-7.26 {mod} { - -body { - assemble {push 123456; push 1000; mod} - } - -result 456 -} -test assemble-7.27 {mult} { - -body { - assemble {push 12345679; push 9; mult} - } - -result 111111111 -} -test assemble-7.28 {neq} { - -body { - list \ - [assemble {push able; push baker; neq}] \ - [assemble {push able; push able; neq}] - } - -result {1 0} -} -test assemble-7.29 {not} { - -body { - list \ - [assemble {push 17; not}] \ - [assemble {push 0; not}] - } - -result {0 1} -} -test assemble-7.30 {pop} { - -body { - assemble {push this; pop; push that} - } - -result that -} -test assemble-7.31 {rshift} { - -body { - assemble {push 257; push 4; rshift} - } - -result 16 -} -test assemble-7.32 {storeArrayStk} { - -body { - proc x {} { - assemble { - push able; push baker; push charlie; storeArrayStk - } - array get able - } - x - } - -result {baker charlie} - -cleanup {rename x {}} -} -test assemble-7.33 {storeStk} { - -body { - proc x {} { - assemble { - push able; push baker; storeStk - } - set able - } - x - } - -result {baker} - -cleanup {rename x {}} -} -test assemble-7,34 {strcmp} { - -body { - proc x {a b} { - assemble { - load a; load b; strcmp - } - } - list [x able baker] [x baker able] [x baker baker] - } - -result {-1 1 0} - -cleanup {rename x {}} -} -test assemble-7.35 {streq/strneq} { - -body { - proc x {a b} { - list \ - [assemble {load a; load b; streq}] \ - [assemble {load a; load b; strneq}] - } - list [x able able] [x able baker] - } - -result {{1 0} {0 1}} - -cleanup {rename x {}} -} -test assemble-7.36 {strindex} { - -body { - assemble {push testing; push 4; strindex} - } - -result i -} -test assemble-7.37 {strlen} { - -body { - assemble {push testing; strlen} - } - -result 7 -} -test assemble-7.38 {sub} { - -body { - assemble {push 42; push 17; sub} - } - -result 25 -} -test assemble-7.39 {tryCvtToNumeric} { - -body { - assemble { - push 42; tryCvtToNumeric - } - } - -result 42 -} -# assemble-7.40 absent -test assemble-7.41 {uminus} { - -body { - assemble { - push 42; uminus - } - } - -result -42 -} -test assemble-7.42 {uplus} { - -body { - assemble { - push 42; uplus - } - } - -result 42 -} -test assemble-7.43 {uplus} { - -body { - assemble { - push NaN; uplus - } - } - -returnCodes error - -result {can't use non-numeric floating-point value as operand of "+"} -} -test assemble-7.43.1 {tryCvtToNumeric} { - -body { - assemble { - push NaN; tryCvtToNumeric - } - } - -returnCodes error - -result {domain error: argument not in valid range} -} -test assemble-7.44 {listIn} { - -body { - assemble { - push b; push {a b c}; listIn - } - } - -result 1 -} -test assemble-7.45 {listNotIn} { - -body { - assemble { - push d; push {a b c}; listNotIn - } - } - -result 1 -} -test assemble-7.46 {nop} { - -body { - assemble { push x; nop; nop; nop} - } - -result x -} - -# assemble-8 ASSEM_LVT and FindLocalVar - -test assemble-8.1 {load, wrong # args} { - -body { - assemble load - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-8.2 {load, wrong # args} { - -body { - assemble {load too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-8.3 {nonlocal var} { - -body { - list [catch {assemble {load ::env}} result] $result $errorCode - } - -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} - -cleanup {unset result} -} -test assemble-8.4 {bad context} { - -body { - set x 1 - list [catch {assemble {load x}} result] $result $errorCode - } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} - -cleanup {unset result} -} -test assemble-8.5 {bad context} { - -body { - namespace eval assem { - set x 1 - list [catch {assemble {load x}} result] $result $errorCode - } - } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} - -cleanup {namespace delete assem} -} -test assemble-8.6 {load1} { - -body { - proc x {a} { - assemble { - load a - } - } - x able - } - -result able - -cleanup {rename x {}} -} -test assemble-8.7 {load4} { - -body { - proc x {a} " - [fillTables] - set b \$a - assemble {load b} - " - x able - } - -result able - -cleanup {rename x {}} -} -test assemble-8.8 {loadArray1} { - -body { - proc x {} { - set able(baker) charlie - assemble { - push baker - loadArray able - } - } - x - } - -result charlie - -cleanup {rename x {}} -} -test assemble-8.9 {loadArray4} { - -body " - proc x {} { - [fillTables] - set able(baker) charlie - assemble { - push baker - loadArray able - } - } - x - " - -result charlie - -cleanup {rename x {}} -} -test assemble-8.10 {append1} { - -body { - proc x {} { - set y {hello, } - assemble { - push world; append y - } - } - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.11 {append4} { - -body { - proc x {} " - [fillTables] - set y {hello, } - assemble { - push world; append y - } - " - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.12 {appendArray1} { - -body { - proc x {} { - set y(z) {hello, } - assemble { - push z; push world; appendArray y - } - } - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.13 {appendArray4} { - -body { - proc x {} " - [fillTables] - set y(z) {hello, } - assemble { - push z; push world; appendArray y - } - " - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.14 {lappend1} { - -body { - proc x {} { - set y {hello,} - assemble { - push world; lappend y - } - } - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.15 {lappend4} { - -body { - proc x {} " - [fillTables] - set y {hello,} - assemble { - push world; lappend y - } - " - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.16 {lappendArray1} { - -body { - proc x {} { - set y(z) {hello,} - assemble { - push z; push world; lappendArray y - } - } - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.17 {lappendArray4} { - -body { - proc x {} " - [fillTables] - set y(z) {hello,} - assemble { - push z; push world; lappendArray y - } - " - x - } - -result {hello, world} - -cleanup {rename x {}} -} -test assemble-8.18 {store1} { - -body { - proc x {} { - assemble { - push test; store y - } - set y - } - x - } - -result {test} - -cleanup {rename x {}} -} -test assemble-8.19 {store4} { - -body { - proc x {} " - [fillTables] - assemble { - push test; store y - } - set y - " - x - } - -result test - -cleanup {rename x {}} -} -test assemble-8.20 {storeArray1} { - -body { - proc x {} { - assemble { - push z; push test; storeArray y - } - set y(z) - } - x - } - -result test - -cleanup {rename x {}} -} -test assemble-8.21 {storeArray4} { - -body { - proc x {} " - [fillTables] - assemble { - push z; push test; storeArray y - } - " - x - } - -result test - -cleanup {rename x {}} -} - -# assemble-9 - ASSEM_CONCAT1, GetIntegerOperand, CheckOneByte - -test assemble-9.1 {wrong # args} { - -body {assemble concat} - -result {wrong # args*} - -match glob - -returnCodes error -} -test assemble-9.2 {wrong # args} { - -body {assemble {concat too many}} - -result {wrong # args*} - -match glob - -returnCodes error -} -test assemble-9.3 {not a number} { - -body {assemble {concat rubbish}} - -result {expected integer but got "rubbish"} - -returnCodes error -} -test assemble-9.4 {too small} { - -body {assemble {concat -1}} - -result {operand does not fit in one byte} - -returnCodes error -} -test assemble-9.5 {too small} { - -body {assemble {concat 256}} - -result {operand does not fit in one byte} - -returnCodes error -} -test assemble-9.6 {concat} { - -body { - assemble {push h; push e; push l; push l; push o; concat 5} - } - -result hello -} -test assemble-9.7 {concat} { - -body { - list [catch {assemble {concat 0}} result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {unset result} -} - -# assemble-10 -- eval and expr - -test assemble-10.1 {eval - wrong # args} { - -body { - assemble {eval} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-10.2 {eval - wrong # args} { - -body { - assemble {eval too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-10.3 {eval} { - -body { - proc x {} { - assemble { - push 3 - store n - pop - eval {expr {3*$n + 1}} - push 1 - add - } - } - x - } - -result 11 - -cleanup {rename x {}} -} -test assemble-10.4 {expr} { - -body { - proc x {} { - assemble { - push 3 - store n - pop - expr {3*$n + 1} - push 1 - add - } - } - x - } - -result 11 - -cleanup {rename x {}} -} -test assemble-10.5 {eval and expr - nonsimple} { - -body { - proc x {} { - assemble { - eval "s\x65t n 3" - pop - expr "\x33*\$n + 1" - push 1 - add - } - } - x - } - -result 11 - -cleanup { - rename x {} - } -} -test assemble-10.6 {eval - noncompilable} { - -body { - list [catch {assemble {eval $x}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} -} -test assemble-10.7 {expr - noncompilable} { - -body { - list [catch {assemble {expr $x}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} -} - -# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, -# nsupvar, variable, upvar) - -test assemble-11.1 {exist - wrong # args} { - -body { - assemble {exist} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-11.2 {exist - wrong # args} { - -body { - assemble {exist too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-11.3 {nonlocal var} { - -body { - list [catch {assemble {exist ::env}} result] $result $errorCode - } - -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} - -cleanup {unset result} -} -test assemble-11.4 {exist} { - -body { - proc x {} { - set y z - list [assemble {exist y}] \ - [assemble {exist z}] - } - x - } - -result {1 0} - -cleanup {rename x {}} -} -test assemble-11.5 {existArray} { - -body { - proc x {} { - set a(b) c - list [assemble {push b; existArray a}] \ - [assemble {push c; existArray a}] \ - [assemble {push a; existArray b}] - } - x - } - -result {1 0 0} - -cleanup {rename x {}} -} -test assemble-11.6 {dictAppend} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; push 22; dictAppend dict} - } - x - } - -result {a 1 b 222 c 3} - -cleanup {rename x {}} -} -test assemble-11.7 {dictLappend} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; push 2; dictLappend dict} - } - x - } - -result {a 1 b {2 2} c 3} - -cleanup {rename x {}} -} -test assemble-11.8 {upvar} { - -body { - proc x {v} { - assemble {push 1; load v; upvar w; pop; load w} - } - proc y {} { - set z 123 - x z - } - y - } - -result 123 - -cleanup {rename x {}; rename y {}} -} -test assemble-11.9 {nsupvar} { - -body { - namespace eval q { variable v 123 } - proc x {} { - assemble {push q; push v; nsupvar y; pop; load y} - } - x - } - -result 123 - -cleanup {namespace delete q; rename x {}} -} -test assemble-11.10 {variable} { - -body { - namespace eval q { namespace eval r {variable v 123}} - proc x {} { - assemble {push q::r::v; variable y; load y} - } - x - } - -result 123 - -cleanup {namespace delete q; rename x {}} -} - -# assemble-12 - ASSEM_LVT1 (incr and incrArray) - -test assemble-12.1 {incr - wrong # args} { - -body { - assemble {incr} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-12.2 {incr - wrong # args} { - -body { - assemble {incr too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-12.3 {incr nonlocal var} { - -body { - list [catch {assemble {incr ::env}} result] $result $errorCode - } - -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} - -cleanup {unset result} -} -test assemble-12.4 {incr} { - -body { - proc x {} { - set y 5 - assemble {push 3; incr y} - } - x - } - -result 8 - -cleanup {rename x {}} -} -test assemble-12.5 {incrArray} { - -body { - proc x {} { - set a(b) 5 - assemble {push b; push 3; incrArray a} - } - x - } - -result 8 - -cleanup {rename x {}} -} -test assemble-12.6 {incr, stupid stack restriction} { - -body { - proc x {} " - [fillTables] - set y 5 - assemble {push 3; incr y} - " - list [catch {x} result] $result $errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {unset result; rename x {}} -} - -# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm - -test assemble-13.1 {incrImm - wrong # args} { - -body { - assemble {incrImm x} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-13.2 {incrImm - wrong # args} { - -body { - assemble {incrImm too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-13.3 {incrImm nonlocal var} { - -body { - list [catch {assemble {incrImm ::env 2}} result] $result $errorCode - } - -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} - -cleanup {unset result} -} -test assemble-13.4 {incrImm not a number} { - -body { - proc x {} { - assemble {incrImm x rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-13.5 {incrImm too big} { - -body { - proc x {} { - assemble {incrImm x 0x80} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {rename x {}; unset result} -} -test assemble-13.6 {incrImm too small} { - -body { - proc x {} { - assemble {incrImm x -0x81} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {rename x {}; unset result} -} -test assemble-13.7 {incrImm} { - -body { - proc x {} { - set y 1 - list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}] - } - x - } - -result {-127 0} - -cleanup {rename x {}} -} -test assemble-13.8 {incrArrayImm} { - -body { - proc x {} { - set a(b) 5 - assemble {push b; incrArrayImm a 3} - } - x - } - -result 8 - -cleanup {rename x {}} -} -test assemble-13.9 {incrImm, stupid stack restriction} { - -body { - proc x {} " - [fillTables] - set y 5 - assemble {incrImm y 3} - " - list [catch {x} result] $result $errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {unset result; rename x {}} -} - -# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm) - -test assemble-14.1 {incrStkImm - wrong # args} { - -body { - assemble {incrStkImm} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-14.2 {incrStkImm - wrong # args} { - -body { - assemble {incrStkImm too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-14.3 {incrStkImm not a number} { - -body { - proc x {} { - assemble {incrStkImm rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-14.4 {incrStkImm too big} { - -body { - proc x {} { - assemble {incrStkImm 0x80} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {rename x {}; unset result} -} -test assemble-14.5 {incrStkImm too small} { - -body { - proc x {} { - assemble {incrStkImm -0x81} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {rename x {}; unset result} -} -test assemble-14.6 {incrStkImm} { - -body { - proc x {} { - set y 1 - list [assemble {push y; incrStkImm -0x80}] \ - [assemble {push y; incrStkImm 0x7f}] - } - x - } - -result {-127 0} - -cleanup {rename x {}} -} -test assemble-14.7 {incrArrayStkImm} { - -body { - proc x {} { - set a(b) 5 - assemble {push a; push b; incrArrayStkImm 3} - } - x - } - -result 8 - -cleanup {rename x {}} -} - -# assemble-15 - listIndexImm - -test assemble-15.1 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.2 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.3 {listIndexImm - bad substitution} { - -body { - list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-15.4 {listIndexImm - invalid index} { - -body { - assemble {listIndexImm rubbish} - } - -returnCodes error - -match glob - -result {bad index "rubbish"*} -} -test assemble-15.5 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm 2} - } - -result c -} -test assemble-15.6 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end-1} - } - -result b -} -test assemble-15.7 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end} - } - -result c -} - -# assemble-16 - invokeStk - -test assemble-16.1 {invokeStk - wrong # args} { - -body { - assemble {invokeStk} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-16.2 {invokeStk - wrong # args} { - -body { - assemble {invokeStk too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-16.3 {invokeStk - not a number} { - -body { - proc x {} { - assemble {invokeStk rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-16.4 {invokeStk - no operands} { - -body { - proc x {} { - assemble {invokeStk 0} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-16.5 {invokeStk1} { - -body { - tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3} - } - -result {1 2} -} -test assemble-16.6 {invokeStk4} { - -body { - proc x {n} { - set code {push concat} - set shouldbe {} - for {set i 1} {$i < $n} {incr i} { - append code \n {push a} $i - lappend shouldbe a$i - } - append code \n {invokeStk} { } $n - set is [assemble $code] - expr {$is eq $shouldbe} - } - list [x 254] [x 255] [x 256] [x 257] - } - -result {1 1 1 1} - -cleanup {rename x {}} -} - -# assemble-17 -- jumps and labels - -test assemble-17.1 {label, wrong # args} { - -body { - assemble {label} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-17.2 {label, wrong # args} { - -body { - assemble {label too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-17.3 {label, bad subst} { - -body { - list [catch {assemble {label $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-17.4 {duplicate label} { - -body { - list [catch {assemble {label foo; label foo}} result] \ - $result $::errorCode - } - -result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}} -} -test assemble-17.5 {jump, wrong # args} { - -body { - assemble {jump} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-17.6 {jump, wrong # args} { - -body { - assemble {jump too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-17.7 {jump, bad subst} { - -body { - list [catch {assemble {jump $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-17.8 {jump - ahead and back} { - -body { - assemble { - jump three - - label one - push a - jump four - - label two - push b - jump six - - label three - push c - jump five - - label four - push d - jump two - - label five - push e - jump one - - label six - push f - concat 6 - } - } - -result ceadbf -} -test assemble-17.9 {jump - resolve a label multiple times} { - -body { - proc x {} { - set case 0 - set result {} - assemble { - jump common - - label zero - pop - incrImm case 1 - pop - push a - append result - pop - jump common - - label one - pop - incrImm case 1 - pop - push b - append result - pop - jump common - - label common - load case - dup - push 0 - eq - jumpTrue zero - dup - push 1 - eq - jumpTrue one - dup - push 2 - eq - jumpTrue two - dup - push 3 - eq - jumpTrue three - - label two - pop - incrImm case 1 - pop - push c - append result - pop - jump common - - label three - pop - incrImm case 1 - pop - push d - append result - } - } - x - } - -result abcd - -cleanup {rename x {}} -} -test assemble-17.10 {jump4 needed} { - -body { - assemble "push x; jump one; label two; [string repeat {dup; pop;} 128] - jump three; label one; jump two; label three" - } - -result x -} -test assemble-17.11 {jumpTrue} { - -body { - proc x {y} { - assemble { - load y - jumpTrue then - push no - jump else - label then - push yes - label else - } - } - list [x 0] [x 1] - } - -result {no yes} - -cleanup {rename x {}} -} -test assemble-17.12 {jumpFalse} { - -body { - proc x {y} { - assemble { - load y - jumpFalse then - push no - jump else - label then - push yes - label else - } - } - list [x 0] [x 1] - } - -result {yes no} - -cleanup {rename x {}} -} -test assemble-17.13 {jump to undefined label} { - -body { - list [catch {assemble {jump nowhere}} result] $result $::errorCode - } - -result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}} -} -test assemble-17.14 {jump to undefined label, line number correct?} { - -body { - catch {assemble {#1 - #2 - #3 - jump nowhere - #5 - #6 - }} - set ::errorInfo - } - -match glob - -result {*"assemble" body, line 4*} -} -test assemble-17.15 {multiple passes of code resizing} { - -setup { - set body { - push - - } - for {set i 0} {$i < 14} {incr i} { - append body "label a" $i \ - "; push a; concat 2; nop; nop; jump b" \ - $i \n - } - append body {label a14; push a; concat 2; push 1; jumpTrue b14} \n - append body {label a15; push a; concat 2; push 0; jumpFalse b15} \n - for {set i 0} {$i < 15} {incr i} { - append body "label b" $i \ - "; push b; concat 2; nop; nop; jump a" \ - [expr {$i+1}] \n - } - append body {label c; push -; concat 2; nop; nop; nop; jump d} \n - append body {label b15; push b; concat 2; nop; nop; jump c} \n - append body {label d} - proc x {} [list assemble $body] - } - -body { - x - } - -cleanup { - catch {unset body} - catch {rename x {}} - } - -result -abababababababababababababababab- -} - -# assemble-18 - lindexMulti - -test assemble-18.1 {lindexMulti - wrong # args} { - -body { - assemble {lindexMulti} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-18.2 {lindexMulti - wrong # args} { - -body { - assemble {lindexMulti too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-18.3 {lindexMulti - bad subst} { - -body { - assemble {lindexMulti $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-18.4 {lindexMulti - not a number} { - -body { - proc x {} { - assemble {lindexMulti rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-18.5 {lindexMulti - bad operand count} { - -body { - proc x {} { - assemble {lindexMulti 0} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-18.6 {lindexMulti} { - -body { - assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1} - } - -result {{a b c} {d e f} {g h j}} -} -test assemble-18.7 {lindexMulti} { - -body { - assemble {push {{a b c} {d e f} {g h j}}; push 1; lindexMulti 2} - } - -result {d e f} -} -test assemble-18.8 {lindexMulti} { - -body { - assemble {push {{a b c} {d e f} {g h j}}; push 2; push 1; lindexMulti 3} - } - -result h -} - -# assemble-19 - list - -test assemble-19.1 {list - wrong # args} { - -body { - assemble {list} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-19.2 {list - wrong # args} { - -body { - assemble {list too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-19.3 {list - bad subst} { - -body { - assemble {list $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-19.4 {list - not a number} { - -body { - proc x {} { - assemble {list rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-19.5 {list - negative operand count} { - -body { - proc x {} { - assemble {list -1} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-19.6 {list - no args} { - -body { - assemble {list 0} - } - -result {} -} -test assemble-19.7 {list - 1 arg} { - -body { - assemble {push hello; list 1} - } - -result hello -} -test assemble-19.8 {list - 2 args} { - -body { - assemble {push hello; push world; list 2} - } - -result {hello world} -} - -# assemble-20 - lsetFlat - -test assemble-20.1 {lsetFlat - wrong # args} { - -body { - assemble {lsetFlat} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-20.2 {lsetFlat - wrong # args} { - -body { - assemble {lsetFlat too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-20.3 {lsetFlat - bad subst} { - -body { - assemble {lsetFlat $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-20.4 {lsetFlat - not a number} { - -body { - proc x {} { - assemble {lsetFlat rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-20.5 {lsetFlat - negative operand count} { - -body { - proc x {} { - assemble {lsetFlat 1} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}} - -cleanup {rename x {}; unset result} -} -test assemble-20.6 {lsetFlat} { - -body { - assemble {push b; push a; lsetFlat 2} - } - -result b -} -test assemble-20.7 {lsetFlat} { - -body { - assemble {push 1; push d; push {a b c}; lsetFlat 3} - } - -result {a d c} -} - -# assemble-21 - over - -test assemble-21.1 {over - wrong # args} { - -body { - assemble {over} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-21.2 {over - wrong # args} { - -body { - assemble {over too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-21.3 {over - bad subst} { - -body { - assemble {over $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-21.4 {over - not a number} { - -body { - proc x {} { - assemble {over rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-21.5 {over - negative operand count} { - -body { - proc x {} { - assemble {over -1} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-21.6 {over} { - -body { - proc x {} { - assemble { - push 1 - push 2 - push 3 - over 0 - store x - pop - pop - pop - pop - load x - } - } - x - } - -result 3 - -cleanup {rename x {}} -} -test assemble-21.7 {over} { - -body { - proc x {} { - assemble { - push 1 - push 2 - push 3 - over 2 - store x - pop - pop - pop - pop - load x - } - } - x - } - -result 1 - -cleanup {rename x {}} -} - -# assemble-22 - reverse - -test assemble-22.1 {reverse - wrong # args} { - -body { - assemble {reverse} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-22.2 {reverse - wrong # args} { - -body { - assemble {reverse too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} - -test assemble-22.3 {reverse - bad subst} { - -body { - assemble {reverse $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} - -test assemble-22.4 {reverse - not a number} { - -body { - proc x {} { - assemble {reverse rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-22.5 {reverse - negative operand count} { - -body { - proc x {} { - assemble {reverse -1} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-22.6 {reverse - zero operand count} { - -body { - proc x {} { - assemble {push 1; reverse 0} - } - x - } - -result 1 - -cleanup {rename x {}} -} -test assemble-22.7 {reverse} { - -body { - proc x {} { - assemble { - push 1 - push 2 - push 3 - reverse 1 - store x - pop - pop - pop - load x - } - } - x - } - -result 3 - -cleanup {rename x {}} -} -test assemble-22.8 {reverse} { - -body { - proc x {} { - assemble { - push 1 - push 2 - push 3 - reverse 3 - store x - pop - pop - pop - load x - } - } - x - } - -result 1 - -cleanup {rename x {}} -} - -# assemble-23 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk) - -test assemble-23.1 {strmatch - wrong # args} { - -body { - assemble {strmatch} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-23.2 {strmatch - wrong # args} { - -body { - assemble {strmatch too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-23.3 {strmatch - bad subst} { - -body { - assemble {strmatch $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-23.4 {strmatch - not a boolean} { - -body { - proc x {} { - assemble {strmatch rubbish} - } - x - } - -returnCodes error - -result {expected boolean value but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-23.5 {strmatch} { - -body { - proc x {a b} { - list [assemble {load a; load b; strmatch 0}] \ - [assemble {load a; load b; strmatch 1}] - } - list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL] - } - -result {{0 0} {1 1} {0 1}} - -cleanup {rename x {}} -} -test assemble-23.6 {unsetStk} { - -body { - proc x {} { - set a {} - assemble {push a; unsetStk false} - info exists a - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-23.7 {unsetStk} { - -body { - proc x {} { - assemble {push a; unsetStk false} - info exists a - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-23.8 {unsetStk} { - -body { - proc x {} { - assemble {push a; unsetStk true} - info exists a - } - x - } - -returnCodes error - -result {can't unset "a": no such variable} - -cleanup {rename x {}} -} -test assemble-23.9 {unsetArrayStk} { - -body { - proc x {} { - set a(b) {} - assemble {push a; push b; unsetArrayStk false} - info exists a(b) - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-23.10 {unsetArrayStk} { - -body { - proc x {} { - assemble {push a; push b; unsetArrayStk false} - info exists a(b) - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-23.11 {unsetArrayStk} { - -body { - proc x {} { - assemble {push a; push b; unsetArrayStk true} - info exists a(b) - } - x - } - -returnCodes error - -result {can't unset "a(b)": no such variable} - -cleanup {rename x {}} -} - -# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray) - -test assemble-24.1 {unset - wrong # args} { - -body { - assemble {unset one} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-24.2 {unset - wrong # args} { - -body { - assemble {unset too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-24.3 {unset - bad subst -arg 1} { - -body { - assemble {unset $foo bar} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-24.4 {unset - not a boolean} { - -body { - proc x {} { - assemble {unset rubbish trash} - } - x - } - -returnCodes error - -result {expected boolean value but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-24.5 {unset - bad subst - arg 2} { - -body { - assemble {unset true $bar} - } - -returnCodes error - -result {assembly code may not contain substitutions} -} -test assemble-24.6 {unset - nonlocal var} { - -body { - assemble {unset true ::foo::bar} - } - -returnCodes error - -result {variable "::foo::bar" is not local} -} -test assemble-24.7 {unset} { - -body { - proc x {} { - set a {} - assemble {unset false a} - info exists a - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-24.8 {unset} { - -body { - proc x {} { - assemble {unset false a} - info exists a - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-24.9 {unset} { - -body { - proc x {} { - assemble {unset true a} - info exists a - } - x - } - -returnCodes error - -result {can't unset "a": no such variable} - -cleanup {rename x {}} -} -test assemble-24.10 {unsetArray} { - -body { - proc x {} { - set a(b) {} - assemble {push b; unsetArray false a} - info exists a(b) - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-24.11 {unsetArray} { - -body { - proc x {} { - assemble {push b; unsetArray false a} - info exists a(b) - } - x - } - -result 0 - -cleanup {rename x {}} -} -test assemble-24.12 {unsetArray} { - -body { - proc x {} { - assemble {push b; unsetArray true a} - info exists a(b) - } - x - } - -returnCodes error - -result {can't unset "a(b)": no such variable} - -cleanup {rename x {}} -} - -# assemble-25 - dict get - -test assemble-25.1 {dict get - wrong # args} { - -body { - assemble {dictGet} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-25.2 {dict get - wrong # args} { - -body { - assemble {dictGet too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-25.3 {dictGet - bad subst} { - -body { - assemble {dictGet $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-25.4 {dict get - not a number} { - -body { - proc x {} { - assemble {dictGet rubbish} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-25.5 {dictGet - negative operand count} { - -body { - proc x {} { - assemble {dictGet 0} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-25.6 {dictGet - 1 index} { - -body { - assemble {push {a 1 b 2}; push a; dictGet 1} - } - -result 1 -} - -# assemble-26 - dict set - -test assemble-26.1 {dict set - wrong # args} { - -body { - assemble {dictSet 1} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-26.2 {dict get - wrong # args} { - -body { - assemble {dictSet too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-26.3 {dictSet - bad subst} { - -body { - assemble {dictSet 1 $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-26.4 {dictSet - not a number} { - -body { - proc x {} { - assemble {dictSet rubbish foo} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-26.5 {dictSet - zero operand count} { - -body { - proc x {} { - assemble {dictSet 0 foo} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-26.6 {dictSet - bad local} { - -body { - proc x {} { - assemble {dictSet 1 ::foo::bar} - } - list [catch x result] $result $::errorCode - } - -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} - -cleanup {rename x {}; unset result} -} -test assemble-26.7 {dictSet} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; push 4; dictSet 1 dict} - } - x - } - -result {a 1 b 4 c 3} - -cleanup {rename x {}} -} - -# assemble-27 - dictUnset - -test assemble-27.1 {dictUnset - wrong # args} { - -body { - assemble {dictUnset 1} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-27.2 {dictUnset - wrong # args} { - -body { - assemble {dictUnset too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-27.3 {dictUnset - bad subst} { - -body { - assemble {dictUnset 1 $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-27.4 {dictUnset - not a number} { - -body { - proc x {} { - assemble {dictUnset rubbish foo} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-27.5 {dictUnset - zero operand count} { - -body { - proc x {} { - assemble {dictUnset 0 foo} - } - list [catch x result] $result $::errorCode - } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {rename x {}; unset result} -} -test assemble-27.6 {dictUnset - bad local} { - -body { - proc x {} { - assemble {dictUnset 1 ::foo::bar} - } - list [catch x result] $result $::errorCode - } - -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} - -cleanup {rename x {}; unset result} -} -test assemble-27.7 {dictUnset} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; dictUnset 1 dict} - } - x - } - -result {a 1 c 3} - -cleanup {rename x {}} -} - -# assemble-28 - dictIncrImm - -test assemble-28.1 {dictIncrImm - wrong # args} { - -body { - assemble {dictIncrImm 1} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-28.2 {dictIncrImm - wrong # args} { - -body { - assemble {dictIncrImm too many args} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-28.3 {dictIncrImm - bad subst} { - -body { - assemble {dictIncrImm 1 $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-28.4 {dictIncrImm - not a number} { - -body { - proc x {} { - assemble {dictIncrImm rubbish foo} - } - x - } - -returnCodes error - -result {expected integer but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-28.5 {dictIncrImm - bad local} { - -body { - proc x {} { - assemble {dictIncrImm 1 ::foo::bar} - } - list [catch x result] $result $::errorCode - } - -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} - -cleanup {rename x {}; unset result} -} -test assemble-28.6 {dictIncrImm} { - -body { - proc x {} { - set dict {a 1 b 2 c 3} - assemble {push b; dictIncrImm 42 dict} - } - x - } - -result {a 1 b 44 c 3} - -cleanup {rename x {}} -} - -# assemble-29 - ASSEM_REGEXP - -test assemble-29.1 {regexp - wrong # args} { - -body { - assemble {regexp} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-29.2 {regexp - wrong # args} { - -body { - assemble {regexp too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-29.3 {regexp - bad subst} { - -body { - assemble {regexp $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-29.4 {regexp - not a boolean} { - -body { - proc x {} { - assemble {regexp rubbish} - } - x - } - -returnCodes error - -result {expected boolean value but got "rubbish"} - -cleanup {rename x {}} -} -test assemble-29.5 {regexp} { - -body { - assemble {push br.*br; push abracadabra; regexp false} - } - -result 1 -} -test assemble-29.6 {regexp} { - -body { - assemble {push br.*br; push aBRacadabra; regexp false} - } - -result 0 -} -test assemble-29.7 {regexp} { - -body { - assemble {push br.*br; push aBRacadabra; regexp true} - } - -result 1 -} - -# assemble-30 - Catches - -test assemble-30.1 {simplest possible catch} { - -body { - proc x {} { - assemble { - beginCatch @bad - push error - push testing - invokeStk 2 - pop - push 0 - jump @ok - label @bad - push 1; # should be pushReturnCode - label @ok - endCatch - } - } - x - } - -result 1 - -cleanup {rename x {}} -} -test assemble-30.2 {catch in external catch conntext} { - -body { - proc x {} { - list [catch { - assemble { - beginCatch @bad - push error - push testing - invokeStk 2 - pop - push 0 - jump @ok - label @bad - pushReturnCode - label @ok - endCatch - } - } result] $result - } - x - } - -result {0 1} - -cleanup {rename x {}} -} -test assemble-30.3 {embedded catches} { - -body { - proc x {} { - list [catch { - assemble { - beginCatch @bad - push error - eval { list [catch {error whatever} result] $result } - invokeStk 2 - push 0 - reverse 2 - jump @done - label @bad - pushReturnCode - pushResult - label @done - endCatch - list 2 - } - } result2] $result2 - } - x - } - -result {0 {1 {1 whatever}}} - -cleanup {rename x {}} -} -test assemble-30.4 {throw in wrong context} { - -body { - proc x {} { - list [catch { - assemble { - beginCatch @bad - push error - eval { list [catch {error whatever} result] $result } - invokeStk 2 - push 0 - reverse 2 - jump @done - - label @bad - load x - pushResult - - label @done - endCatch - list 2 - } - } result] $result $::errorCode [split $::errorInfo \n] - } - x - } - -match glob - -result {1 {"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {TCL ASSEM BADTHROW} {{"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} { in assembly code between lines 10 and 15}*}} - -cleanup {rename x {}} -} -test assemble-30.5 {unclosed catch} { - -body { - proc x {} { - assemble { - beginCatch @error - push 0 - jump @done - label @error - push 1 - label @done - push "" - pop - } - } - list [catch {x} result] $result $::errorCode $::errorInfo - } - -match glob - -result {1 {catch still active on exit from assembly code} {TCL ASSEM UNCLOSEDCATCH} {catch still active on exit from assembly code - ("assemble" body, line 2)*}} - -cleanup {rename x {}} -} -test assemble-30.6 {inconsistent catch contexts} { - -body { - proc x {y} { - assemble { - load y - jumpTrue @inblock - beginCatch @error - label @inblock - push 0 - jump @done - label @error - push 1 - label @done - } - } - list [catch {x 2} result] $::errorCode $::errorInfo - } - -match glob - -result {1 {TCL ASSEM BADCATCH} {execution reaches an instruction in inconsistent exception contexts - ("assemble" body, line 5)*}} - -cleanup {rename x {}} -} - -# assemble-31 - Jump tables - -test assemble-31.1 {jumpTable, wrong # args} { - -body { - assemble {jumpTable} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-31.2 {jumpTable, wrong # args} { - -body { - assemble {jumpTable too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-31.3 {jumpTable - bad subst} { - -body { - assemble {jumpTable $foo} - } - -returnCodes error - -match glob - -result {assembly code may not contain substitutions} -} -test assemble-31.4 {jumptable - not a list} { - -body { - assemble {jumpTable \{rubbish} - } - -returnCodes error - -result {unmatched open brace in list} -} -test assemble-31.5 {jumpTable, badly structured} { - -body { - list [catch {assemble { - # line 2 - jumpTable {one two three};# line 3 - }} result] \ - $result $::errorCode $::errorInfo - } - -match glob - -result {1 {jump table must have an even number of list elements} {TCL ASSEM BADJUMPTABLE} {jump table must have an even number of list elements*("assemble" body, line 3)*}} -} -test assemble-31.6 {jumpTable, missing symbol} { - -body { - list [catch {assemble { - # line 2 - jumpTable {1 a};# line 3 - }} result] \ - $result $::errorCode $::errorInfo - } - -match glob - -result {1 {undefined label "a"} {TCL ASSEM NOLABEL a} {undefined label "a"*("assemble" body, line 3)*}} -} -test assemble-31.7 {jumptable, actual example} { - -setup { - proc x {} { - set result {} - for {set i 0} {$i < 5} {incr i} { - lappend result [assemble { - load i - jumpTable {1 @one 2 @two 3 @three} - push {none of the above} - jump @done - label @one - push one - jump @done - label @two - push two - jump @done - label @three - push three - label @done - }] - } - set tcl_traceCompile 2 - set result - } - } - -body x - -result {{none of the above} one two three {none of the above}} - -cleanup {set tcl_traceCompile 0; rename x {}} -} - -test assemble-40.1 {unbalanced stack} { - -body { - list \ - [catch { - assemble { - push 3 - dup - mult - push 4 - dup - mult - pop - expon - } - } result] $result $::errorInfo - } - -result {1 {stack underflow} {stack underflow - in assembly code between lines 1 and end of assembly code*}} - -match glob - -returnCodes ok -} -test assemble-40.2 {unbalanced stack} {*}{ - -body { - list \ - [catch { - assemble { - label a - push {} - label b - pop - label c - pop - label d - push {} - } - } result] $result $::errorInfo - } - -result {1 {stack underflow} {stack underflow - in assembly code between lines 7 and 9*}} - -match glob - -returnCodes ok -} - -test assemble-41.1 {Inconsistent stack usage} {*}{ - -body { - proc x {y} { - assemble { - load y - jumpFalse else - push 0 - jump then - label else - push 1 - push 2 - label then - pop - } - } - catch {x 1} - set errorInfo - } - -match glob - -result {inconsistent stack depths on two execution paths - ("assemble" body, line 10)*} -} -test assemble-41.2 {Inconsistent stack, jumptable and default} { - -body { - proc x {y} { - assemble { - load y - jumpTable {0 else} - push 0 - label else - pop - } - } - catch {x 1} - set errorInfo - } - -match glob - -result {inconsistent stack depths on two execution paths - ("assemble" body, line 6)*} -} -test assemble-41.3 {Inconsistent stack, two legs of jumptable} { - -body { - proc x {y} { - assemble { - load y - jumpTable {0 no 1 yes} - label no - push 0 - label yes - pop - } - } - catch {x 1} - set errorInfo - } - -match glob - -result {inconsistent stack depths on two execution paths - ("assemble" body, line 7)*} -} - -test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { - -body { - proc ulam {n} { - assemble { - load n; # max - dup; # max n - jump start; # max n - - label loop; # max n - over 1; # max n max - over 1; # max in max n - ge; # man n max>=n - jumpTrue skip; # max n - - reverse 2; # n max - pop; # n - dup; # n n - - label skip; # max n - dup; # max n n - push 2; # max n n 2 - mod; # max n n%2 - jumpTrue odd; # max n - - push 2; # max n 2 - div; # max n/2 -> max n - jump start; # max n - - label odd; # max n - push 3; # max n 3 - mult; # max 3*n - push 1; # max 3*n 1 - add; # max 3*n+1 - - label start; # max n - dup; # max n n - push 1; # max n n 1 - neq; # max n n>1 - jumpTrue loop; # max n - - pop; # max - } - } - set result {} - for {set i 1} {$i < 30} {incr i} { - lappend result [ulam $i] - } - set result - } - -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} -} - -test assemble-51.1 {memory leak testing} memory { - leaktest { - apply {{} {assemble {push hello}}} - } -} 0 -test assemble-51.2 {memory leak testing} memory { - leaktest { - apply {{{x 0}} {assemble {incrImm x 1}}} - } -} 0 -test assemble-51.3 {memory leak testing} memory { - leaktest { - apply {{n} { - assemble { - load n; # max - dup; # max n - jump start; # max n - - label loop; # max n - over 1; # max n max - over 1; # max in max n - ge; # man n max>=n - jumpTrue skip; # max n - - reverse 2; # n max - pop; # n - dup; # n n - - label skip; # max n - dup; # max n n - push 2; # max n n 2 - mod; # max n n%2 - jumpTrue odd; # max n - - push 2; # max n 2 - div; # max n/2 -> max n - jump start; # max n - - label odd; # max n - push 3; # max n 3 - mult; # max 3*n - push 1; # max 3*n 1 - add; # max 3*n+1 - - label start; # max n - dup; # max n n - push 1; # max n n 1 - neq; # max n n>1 - jumpTrue loop; # max n - - pop; # max - } - }} 1 - } -} 0 -test assemble-51.4 {memory leak testing} memory { - leaktest { - catch { - apply {{} { - assemble {reverse polish notation} - }} - } - } -} 0 - -rename fillTables {} -rename assemble {} - -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# fill-column: 78 -# End: diff --git a/tests/assemble1.bench b/tests/assemble1.bench deleted file mode 100644 index 18fd3a9..0000000 --- a/tests/assemble1.bench +++ /dev/null @@ -1,85 +0,0 @@ -proc ulam1 {n} { - set max $n - while {$n != 1} { - if {$n > $max} { - set max $n - } - if {$n % 2} { - set n [expr {3 * $n + 1}] - } else { - set n [expr {$n / 2}] - } - } - return $max -} - -set tcl_traceCompile 2; ulam1 1; set tcl_traceCompile 0 - -proc ulam2 {n} { - tcl::unsupported::assemble { - load n; # max - dup; # max n - jump start; # max n - - label loop; # max n - over 1; # max n max - over 1; # max in max n - ge; # man n max>=n - jumpTrue skip; # max n - - reverse 2; # n max - pop; # n - dup; # n n - - label skip; # max n - dup; # max n n - push 2; # max n n 2 - mod; # max n n%2 - jumpTrue odd; # max n - - push 2; # max n 2 - div; # max n/2 -> max n - jump start; # max n - - label odd; # max n - push 3; # max n 3 - mult; # max 3*n - push 1; # max 3*n 1 - add; # max 3*n+1 - - label start; # max n - dup; # max n n - push 1; # max n n 1 - neq; # max n n>1 - jumpTrue loop; # max n - - pop; # max - } -} -set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0 - -proc test1 {n} { - for {set i 1} {$i <= $n} {incr i} { - ulam1 $i - } -} -proc test2 {n} { - for {set i 1} {$i <= $n} {incr i} { - ulam2 $i - } -} - -for {set j 0} {$j < 10} {incr j} { - test1 1 - set before [clock microseconds] - test1 30000 - set after [clock microseconds] - puts "compiled: [expr {1e-6 * ($after - $before)}]" - - test2 1 - set before [clock microseconds] - test2 30000 - set after [clock microseconds] - puts "assembled: [expr {1e-6 * ($after - $before)}]" -} -
\ No newline at end of file diff --git a/tests/compile.test b/tests/compile.test index d4a31d4..e3781f3 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -750,7 +750,7 @@ test compile-18.19 {disassembler - basics} -setup { } -match glob -result * # There never was a compile-18.20. # The keys of the dictionary produced by [getbytecode] are defined. -set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth} +set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth} test compile-18.21 {disassembler - basics} -returnCodes error -body { tcl::unsupported::getbytecode } -match glob -result {wrong # args: should be "*"} diff --git a/tests/info.test b/tests/info.test index 3057dd2..e67202b 100644 --- a/tests/info.test +++ b/tests/info.test @@ -107,25 +107,25 @@ test info-2.6 {info body option, returning list bodies} { [foo; string bytelength [info body foo]] } {9 9} -proc testinfocmdcount {} { - set x [info cmdcount] - set y 12345 - set z [info cm] - expr {$z-$x} -} -test info-3.1 {info cmdcount compiled} { - testinfocmdcount -} 4 -test info-3.2 {info cmdcount evaled} -body { - set x [info cmdcount] - set y 12345 - set z [info cm] - expr {$z-$x} -} -cleanup {unset x y z} -result 4 -test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4 -test info-3.4 {info cmdcount option} -body { - info cmdcount 1 -} -returnCodes error -result {wrong # args: should be "info cmdcount"} +test info-3.1 {info cmdcount compiled} {} {} +test info-3.2 {info cmdcount evaled} {} {} +test info-3.3 {info cmdcount evaled} {} {} +test info-3.4 {info cmdcount option} {} {} +# 1 Add 15 lines not to disrupt the clumsy tests that depend on the line +# 2 numbers in this file +# 3 +# 4 +# 5 +# 6 +# 7 +# 8 +# 9 +# 10 +# 11 +# 12 +# 13 +# 14 +# 15 test info-4.1 {info commands option} -body { proc t1 {} {} @@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### diff --git a/tests/interp.test b/tests/interp.test index 4bc9fe2..7b78539 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -3083,36 +3083,12 @@ test interp-33.1 {refCounting for target words of alias [Bug 730244]} { $i eval alias } this -test interp-34.1 {basic test of limits - calling commands} -body { - set i [interp create] - $i eval { - proc foobar {} { - for {set x 0} {$x<1000000} {incr x} { - # Calls to this are not bytecoded away - pid - } - } - } - $i limit command -value 1000 - $i eval foobar -} -returnCodes error -result {command count limit exceeded} -cleanup { - interp delete $i -} -test interp-34.2 {basic test of limits - bytecoded commands} -body { - set i [interp create] - $i eval { - proc foobar {} { - for {set x 0} {$x<1000000} {incr x} { - # Calls to this *are* bytecoded away - expr {1+2+3} - } - } - } - $i limit command -value 1000 - $i eval foobar -} -returnCodes error -result {command count limit exceeded} -cleanup { - interp delete $i -} +test interp-34.1 {basic test of limits - calling commands} { + # testing removed command limits +} {} +test interp-34.2 {basic test of limits - bytecoded commands} { + # testing removed command limits +} {} test interp-34.3 {basic test of limits - pure bytecode loop} -body { set i [interp create] $i eval { @@ -3144,131 +3120,21 @@ test interp-34.3.1 {basic test of limits - pure inside-command loop} -body { } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i } -test interp-34.4 {limits with callbacks: extending limits} -setup { - set i [interp create] - set a 0 - set b 0 - set c a - proc cb1 {} { - global c - incr ::$c - } - proc cb2 {newlimit args} { - global c i - set c b - $i limit command -value $newlimit - } -} -body { - interp alias $i foo {} cb1 - set curlim [$i eval info cmdcount] - $i limit command -command "cb2 [expr $curlim+100]" \ - -value [expr {$curlim+10}] - $i eval {for {set i 0} {$i<10} {incr i} {foo}} - list $a $b $c -} -result {6 4 b} -cleanup { - interp delete $i - rename cb1 {} - rename cb2 {} -} +test interp-34.4 {limits with callbacks: extending limits} { + # testing removed command limits +} {} # The next three tests exercise all the three ways that limit handlers # can be deleted. Fully verifying this requires additional source # code instrumentation. -test interp-34.5 {limits with callbacks: removing limits} -setup { - set i [interp create] - set a 0 - set b 0 - set c a - proc cb1 {} { - global c - incr ::$c - } - proc cb2 {newlimit args} { - global c i - set c b - $i limit command -value $newlimit - } -} -body { - interp alias $i foo {} cb1 - set curlim [$i eval info cmdcount] - $i limit command -command "cb2 {}" -value [expr {$curlim+10}] - $i eval {for {set i 0} {$i<10} {incr i} {foo}} - list $a $b $c -} -result {6 4 b} -cleanup { - interp delete $i - rename cb1 {} - rename cb2 {} -} -test interp-34.6 {limits with callbacks: removing limits and handlers} -setup { - set i [interp create] - set a 0 - set b 0 - set c a - proc cb1 {} { - global c - incr ::$c - } - proc cb2 {args} { - global c i - set c b - $i limit command -value {} -command {} - } -} -body { - interp alias $i foo {} cb1 - set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim+10}] - $i eval {for {set i 0} {$i<10} {incr i} {foo}} - list $a $b $c -} -result {6 4 b} -cleanup { - interp delete $i - rename cb1 {} - rename cb2 {} -} -test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { - set i [interp create] - $i eval { - set i [interp create] - proc cb1 {} { - global c - incr ::$c - } - proc cb2 {args} { - global c i curlim - set c b - $i limit command -value [expr {$curlim+1000}] - trapToParent - } - } - proc cb3 {} { - global i subi - interp alias [list $i $subi] foo {} cb4 - interp delete $i - } - proc cb4 {} { - global n - incr n - } -} -body { - set subi [$i eval set i] - interp alias $i trapToParent {} cb3 - set n 0 - $i eval { - set a 0 - set b 0 - set c a - interp alias $i foo {} cb1 - set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim+10}] - } - $i eval { - $i eval { - for {set i 0} {$i<10} {incr i} {foo} - } - } - list $n [interp exists $i] -} -result {4 0} -cleanup { - rename cb3 {} - rename cb4 {} -} +test interp-34.5 {limits with callbacks: removing limits} { + # testing removed command limits +} {} +test interp-34.6 {limits with callbacks: removing limits and handlers} { + # testing removed command limits +} {} +test interp-34.7 {limits with callbacks: deleting the handler interp} { + # testing removed command limits +} {} # Bug 1085023 test interp-34.8 {time limits trigger in vwaits} -body { set i [interp create] @@ -3387,59 +3253,30 @@ test interp-35.2 {interp limit syntax} -body { test interp-35.3 {interp limit syntax} -body { interp limit {} foo } -returnCodes error -result {bad limit type "foo": must be commands or time} -test interp-35.4 {interp limit syntax} -body { - set i [interp create] - set dict [interp limit $i commands] - set result {} - foreach key [lsort [dict keys $dict]] { - lappend result $key [dict get $dict $key] - } - set result -} -cleanup { - interp delete $i -} -result {-command {} -granularity 1 -value {}} -test interp-35.5 {interp limit syntax} -body { - set i [interp create] - interp limit $i commands -granularity -} -cleanup { - interp delete $i -} -result 1 -test interp-35.6 {interp limit syntax} -body { - set i [interp create] - interp limit $i commands -granularity 2 -} -cleanup { - interp delete $i -} -result {} -test interp-35.7 {interp limit syntax} -body { - set i [interp create] - interp limit $i commands -foobar -} -cleanup { - interp delete $i -} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, or -value} -test interp-35.8 {interp limit syntax} -body { - set i [interp create] - interp limit $i commands -granularity foobar -} -cleanup { - interp delete $i -} -returnCodes error -result {expected integer but got "foobar"} -test interp-35.9 {interp limit syntax} -body { - set i [interp create] - interp limit $i commands -granularity 0 -} -cleanup { - interp delete $i -} -returnCodes error -result {granularity must be at least 1} -test interp-35.10 {interp limit syntax} -body { - set i [interp create] - interp limit $i commands -value foobar -} -cleanup { - interp delete $i -} -returnCodes error -result {expected integer but got "foobar"} -test interp-35.11 {interp limit syntax} -body { - set i [interp create] - interp limit $i commands -value -1 -} -cleanup { - interp delete $i -} -returnCodes error -result {command limit value must be at least 0} +test interp-35.4 {interp limit syntax} { + # testing removed command limits +} {} +test interp-35.5 {interp limit syntax} { + # testing removed command limits +} {} +test interp-35.6 {interp limit syntax} { + # testing removed command limits +} {} +test interp-35.7 {interp limit syntax} { + # testing removed command limits +} {} +test interp-35.8 {interp limit syntax} { + # testing removed command limits +} {} +test interp-35.9 {interp limit syntax} { + # testing removed command limits +} {} +test interp-35.10 {interp limit syntax} { + # testing removed command limits +} {} +test interp-35.11 {interp limit syntax} { + # testing removed command limits +} {} test interp-35.12 {interp limit syntax} -body { set i [interp create] set dict [interp limit $i time] @@ -3513,9 +3350,9 @@ test interp-35.22 {interp time limits normalize milliseconds} -body { interp delete $i } -result {2 500} # Bug 3398794 -test interp-35.23 {interp command limits can't touch current interp} -body { - interp limit {} commands -value 10 -} -returnCodes error -result {limits on current interpreter inaccessible} +test interp-35.23 {interp command limits can't touch current interp} { + # testing removed command limits +} {} test interp-35.24 {interp time limits can't touch current interp} -body { interp limit {} time -seconds 2 } -returnCodes error -result {limits on current interpreter inaccessible} diff --git a/unix/Makefile.in b/unix/Makefile.in index da43c5d..b61f994 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -291,7 +291,7 @@ XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ - tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ + tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \ @@ -390,7 +390,6 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/regfree.c \ $(GENERIC_DIR)/regerror.c \ $(GENERIC_DIR)/tclAlloc.c \ - $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ @@ -462,7 +461,6 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c \ - $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclZlib.c OO_SRCS = \ @@ -1054,9 +1052,6 @@ tclAppInit.o: $(UNIX_DIR)/tclAppInit.c tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c -tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) - $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c - tclAsync.o: $(GENERIC_DIR)/tclAsync.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c |