diff options
Diffstat (limited to 'generic/tclExecute.c')
| -rw-r--r-- | generic/tclExecute.c | 4232 |
1 files changed, 28 insertions, 4204 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4ebeeb8..be85fb9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -16,7 +16,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompileInt.h" #include "tclOOInt.h" #include "tommath.h" #include <math.h> @@ -52,31 +52,17 @@ TCL_DECLARE_MUTEX(execMutex) static int cachedInExit = 0; -#ifdef TCL_COMPILE_DEBUG -/* - * Variable that controls whether execution tracing is enabled and, if so, - * what level of tracing is desired: - * 0: no execution tracing - * 1: trace invocations of Tcl procs only - * 2: trace invocations of all (not compiled away) commands - * 3: display each instruction executed - * This variable is linked to the Tcl variable "tcl_traceExec". - */ - -int tclTraceExec = 0; -#endif - /* * Mapping from expression instruction opcodes to strings; used for error * messages. Note that these entries must match the order and number of the - * expression opcodes (e.g., INST_LOR) in tclCompile.h. + * expression opcodes (e.g., INST_BITOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is * disjoint for backward-compatability reasons. */ static const char *const operatorStrings[] = { - "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!", "BUILTIN FUNCTION", "FUNCTION", "", "", "", "", "", "", "", "", "eq", "ne" @@ -87,79 +73,10 @@ static const char *const operatorStrings[] = { * messages. */ -#ifdef TCL_COMPILE_DEBUG -static const char *const resultStrings[] = { - "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" -}; -#endif - /* * These are used by evalstats to monitor object usage in Tcl. */ -#ifdef TCL_COMPILE_STATS -long tclObjsAlloced = 0; -long tclObjsFreed = 0; -long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; -#endif /* TCL_COMPILE_STATS */ - -/* - * Support pre-8.5 bytecodes unless specifically requested otherwise. - */ - -#ifndef TCL_SUPPORT_84_BYTECODE -#define TCL_SUPPORT_84_BYTECODE 1 -#endif - -#if TCL_SUPPORT_84_BYTECODE -/* - * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 - * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. - */ - -typedef struct { - const char *name; /* Name of function. */ - int numArgs; /* Number of arguments for function. */ -} BuiltinFunc; - -/* - * Table describing the built-in math functions. Entries in this table are - * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's - * operand byte. - */ - -static BuiltinFunc const tclBuiltinFuncTable[] = { - {"acos", 1}, - {"asin", 1}, - {"atan", 1}, - {"atan2", 2}, - {"ceil", 1}, - {"cos", 1}, - {"cosh", 1}, - {"exp", 1}, - {"floor", 1}, - {"fmod", 2}, - {"hypot", 2}, - {"log", 1}, - {"log10", 1}, - {"pow", 2}, - {"sin", 1}, - {"sinh", 1}, - {"sqrt", 1}, - {"tan", 1}, - {"tanh", 1}, - {"abs", 1}, - {"double", 1}, - {"int", 1}, - {"rand", 0}, - {"round", 1}, - {"srand", 1}, - {"wide", 1}, - {NULL, 0}, -}; - -#define LAST_BUILTIN_FUNC 25 -#endif /* * NR_TEBC @@ -167,7 +84,7 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { * Minimal data required to fully reconstruct the execution state. */ -typedef struct TEBCdata { +typedef struct { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ Tcl_Obj **tosPtr; @@ -254,18 +171,9 @@ VarHashCreateVar( /* Verify the stack depth, only when no expansion is in progress */ -#if TCL_COMPILE_DEBUG -#define CHECK_STACK() \ - ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ - /*checkStack*/ auxObjList == NULL) -#else -#define CHECK_STACK() -#endif - #define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ do { \ TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \ - CHECK_STACK(); \ if (nCleanup == 0) { \ if (resultHandling != 0) { \ if ((resultHandling) > 0) { \ @@ -295,7 +203,6 @@ VarHashCreateVar( } while (0) #define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ - CHECK_STACK(); \ do { \ pc += (pcAdjustment); \ cleanup = (nCleanup); \ @@ -343,68 +250,6 @@ VarHashCreateVar( * only used in TRACE* calls to get a string from an object. */ -#ifdef TCL_COMPILE_DEBUG -# define TRACE(a) \ - while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - break; \ - } -# define TRACE_APPEND(a) \ - while (traceInstructions) { \ - printf a; \ - break; \ - } -# define TRACE_WITH_OBJ(a, objPtr) \ - while (traceInstructions) { \ - fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ - (int) CURR_DEPTH, \ - (unsigned) (pc - codePtr->codeStart), \ - GetOpcodeName(pc)); \ - printf a; \ - TclPrintObject(stdout, objPtr, 30); \ - fprintf(stdout, "\n"); \ - break; \ - } -# define O2S(objPtr) \ - (objPtr ? TclGetString(objPtr) : "") -#else /* !TCL_COMPILE_DEBUG */ -# define TRACE(a) -# define TRACE_APPEND(a) -# define TRACE_WITH_OBJ(a, objPtr) -# define O2S(objPtr) -#endif /* TCL_COMPILE_DEBUG */ - -/* - * DTrace instruction probe macros. - */ - -#define TCL_DTRACE_INST_NEXT() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED()) { \ - if (curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \ - tosPtr); \ - } \ - curInstName = tclInstructionTable[*pc].name; \ - if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \ - tosPtr); \ - } \ - } else if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \ - (int) CURR_DEPTH, tosPtr); \ - } \ - } while (0) -#define TCL_DTRACE_INST_LAST() \ - do { \ - if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ - } \ - } while (0) /* * Macro used in this file to save a function call for common uses of @@ -669,19 +514,6 @@ static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); * Declarations for local procedures to this file: */ -#ifdef TCL_COMPILE_STATS -static int EvalStatsCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -#endif /* TCL_COMPILE_STATS */ -#ifdef TCL_COMPILE_DEBUG -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); -#endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); @@ -701,7 +533,6 @@ static const char * GetSrcInfoForPc(const unsigned char *pc, static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); -static void ReleaseDictIterator(Tcl_Obj *objPtr); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; @@ -720,55 +551,6 @@ static const Tcl_ObjType exprCodeType = { NULL /* setFromAnyProc */ }; -/* - * Custom object type only used in this file; values of its type should never - * be seen by user scripts. - */ - -static const Tcl_ObjType dictIteratorType = { - "dictIterator", - ReleaseDictIterator, - NULL, NULL, NULL -}; - -/* - *---------------------------------------------------------------------- - * - * ReleaseDictIterator -- - * - * This takes apart a dictionary iterator that is stored in the given Tcl - * object. - * - * Results: - * None. - * - * Side effects: - * Deallocates memory, marks the object as being untyped. - * - *---------------------------------------------------------------------- - */ - -static void -ReleaseDictIterator( - Tcl_Obj *objPtr) -{ - Tcl_DictSearch *searchPtr; - Tcl_Obj *dictPtr; - - /* - * First kill the search, and then release the reference to the dictionary - * that we were holding. - */ - - searchPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjDone(searchPtr); - ckfree(searchPtr); - - dictPtr = objPtr->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(dictPtr); - - objPtr->typePtr = NULL; -} static void UpdateStringOfBcSource(Tcl_Obj *objPtr); @@ -796,7 +578,19 @@ UpdateStringOfBcSource( objPtr->length = len; } +static inline int +TclCodeIsStale( + ByteCode *codePtr, + Interp *iPtr) +{ + Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; + int check = (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch) + || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)); + return check; +} /* @@ -826,15 +620,6 @@ InitByteCodeExecution( * "tcl_traceExec" is linked to control * instruction tracing. */ { -#ifdef TCL_COMPILE_DEBUG - if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, - TCL_LINK_INT) != TCL_OK) { - Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); - } -#endif -#ifdef TCL_COMPILE_STATS - Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL); -#endif /* TCL_COMPILE_STATS */ } /* @@ -1112,14 +897,8 @@ CompileExprObj( * is valid in the current context. */ if (objPtr->typePtr == &exprCodeType) { - Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch) - || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { + if (TclCodeIsStale(codePtr, iPtr)) { FreeExprCodeInternalRep(objPtr); } } @@ -1155,12 +934,6 @@ CompileExprObj( codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ } return codePtr; } @@ -1255,7 +1028,6 @@ TclCompileObj( { register Interp *iPtr = (Interp *) interp; register ByteCode *codePtr; /* Tcl Internal type of bytecode. */ - Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; /* * If the object is not already of tclByteCodeType, compile it (and reset @@ -1282,17 +1054,13 @@ TclCompileObj( */ codePtr = objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + if (TclCodeIsStale(codePtr, iPtr)) { if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto recompileObj; } if ((Interp *) *codePtr->interpHandle != iPtr) { Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); } - codePtr->compileEpoch = iPtr->compileEpoch; } /* @@ -1511,10 +1279,6 @@ TclNRExecuteByteCode( TD->checkInterp = 0; TD->capacity = codePtr->maxStackDepth; -#ifdef TCL_COMPILE_STATS - iPtr->stats.numExecutions++; -#endif - /* * Push the callback for bytecode execution */ @@ -1555,11 +1319,6 @@ TEBCresume( int instructionCount = 0; /* Counter that is used to work out when to * call Tcl_AsyncReady() */ - const char *curInstName; -#ifdef TCL_COMPILE_DEBUG - int traceInstructions; /* Whether we are doing instruction-level - * tracing or not. */ -#endif Var *compiledLocals = iPtr->varFramePtr->compiledLocals; Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; @@ -1607,23 +1366,9 @@ TEBCresume( int objc = 0; int opnd, length, pcAdjustment; Var *varPtr, *arrayPtr; -#ifdef TCL_COMPILE_DEBUG - char cmdNameBuf[21]; -#endif -#ifdef TCL_COMPILE_DEBUG - traceInstructions = (tclTraceExec == 3); -#endif TEBC_DATA_DIG(); -#ifdef TCL_COMPILE_DEBUG - if (!data[1] && (tclTraceExec >= 2)) { - PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); - fflush(stdout); - } -#endif - if (data[1] /* resume from invocation */) { if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; @@ -1635,19 +1380,15 @@ TEBCresume( checkInterp = 1; if (result == TCL_OK) { -#ifndef TCL_COMPILE_DEBUG if (*pc == INST_POP) { NEXT_INST_V(1, cleanup, 0); } -#endif + /* * Push the call's object result and continue execution with the * next instruction. */ - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - objResultPtr = Tcl_GetObjResult(interp); /* @@ -1747,23 +1488,6 @@ TEBCresume( } cleanup0: -#ifdef TCL_COMPILE_DEBUG - /* - * Skip the stack depth check if an expansion is in progress. - */ - - CHECK_STACK(); - if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); - TclPrintInstruction(codePtr, pc); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - -#ifdef TCL_COMPILE_STATS - iPtr->stats.instructionCount[*pc]++; -#endif - /* * Check for asynchronous handlers [Bug 746722]; we do the check every * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). @@ -1794,26 +1518,8 @@ TEBCresume( checkInterp = 1; } - TCL_DTRACE_INST_NEXT(); - - /* - * These two instructions account for 26% of all instructions (according - * to measurements on tclbench by Ben Vitale - * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf] - * Resolving them before the switch reduces the cost of branch - * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!) - * reduces total obj size. - */ - - if (*pc == INST_LOAD_SCALAR1) { - goto instLoadScalar1; - } else if (*pc == INST_PUSH1) { - goto instPush1Peephole; - } - switch (*pc) { - case INST_SYNTAX: - case INST_RETURN_IMM: { + case INST_SYNTAX: { int code = TclGetInt4AtPtr(pc+1); int level = TclGetUInt4AtPtr(pc+5); @@ -1821,11 +1527,8 @@ TEBCresume( * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr. */ - TRACE(("%u %u => ", code, level)); result = TclProcessReturn(interp, code, level, OBJ_AT_TOS); if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", - O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); } Tcl_SetObjResult(interp, OBJ_UNDER_TOS); @@ -1836,95 +1539,6 @@ TEBCresume( goto processExceptionReturn; } - case INST_RETURN_STK: - TRACE(("=> ")); - objResultPtr = POP_OBJECT(); - result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", - O2S(objResultPtr))); - NEXT_INST_F(1, 0, 0); - } - Tcl_SetObjResult(interp, objResultPtr); - cleanup = 1; - goto processExceptionReturn; - - case INST_YIELD: { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); - if (!corPtr) { - TRACE_APPEND(("ERROR: yield outside coroutine\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); - } -#endif - - pc++; - cleanup = 1; - TEBC_YIELD(); - - Tcl_SetObjResult(interp, OBJ_AT_TOS); - Tcl_NRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - INT2PTR(0), NULL, NULL); - - return TCL_OK; - } - - case INST_TAILCALL: { - Tcl_Obj *listPtr, *nsObjPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - - if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc or lambda", -1)); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); - goto gotError; - } - -#ifdef TCL_COMPILE_DEBUG - { - register int i; - - TRACE(("%d [", opnd)); - for (i=opnd-1 ; i>=0 ; i--) { - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); - if (i > 0) { - TRACE_APPEND((" ")); - } - } - TRACE_APPEND(("] => RETURN...")); - } -#endif - - /* - * Push the evaluation of the called command into the NR callback - * stack. - */ - - listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); - TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - iPtr->varFramePtr->tailcallPtr = listPtr; - - result = TCL_RETURN; - cleanup = opnd; - goto processExceptionReturn; - } - case INST_DONE: if (tosPtr > initTosPtr) { /* @@ -1935,116 +1549,13 @@ TEBCresume( */ 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; } (void) POP_OBJECT(); goto abnormalReturn; - case INST_PUSH1: - instPush1Peephole: - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); - pc += 2; -#if !TCL_COMPILE_DEBUG - /* - * Runtime peephole optimisation: check if we are pushing again. - */ - - if (*pc == INST_PUSH1) { - TCL_DTRACE_INST_NEXT(); - goto instPush1Peephole; - } -#endif - NEXT_INST_F(0, 0, 0); - case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; - TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); - NEXT_INST_F(5, 0, 1); - - case INST_POP: - TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); - objPtr = POP_OBJECT(); - TclDecrRefCount(objPtr); - - /* - * Runtime peephole optimisation: an INST_POP is scheduled at the end - * of most commands. If the next instruction is an INST_START_CMD, - * fall through to it. - */ - - pc++; -#if !TCL_COMPILE_DEBUG - if (*pc == INST_START_CMD) { - TCL_DTRACE_INST_NEXT(); - goto instStartCmdPeephole; - } -#endif - NEXT_INST_F(0, 0, 0); - - case INST_START_CMD: -#if !TCL_COMPILE_DEBUG - instStartCmdPeephole: -#endif - /* - * 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. - */ - - iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - if (!checkInterp) { - goto instStartCmdOK; - } else if (((codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch)) - || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - checkInterp = 0; - instStartCmdOK: - NEXT_INST_F(9, 0, 0); - } else { - const char *bytes; - - 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] - */ - - if (TclInterpReady(interp) == TCL_ERROR) { - goto gotError; - } - - codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); - goto instEvalStk; - } - - case INST_NOP: - pc += 1; - goto cleanup0; - - case INST_DUP: - objResultPtr = OBJ_AT_TOS; - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - - case INST_OVER: - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(5, 0, 1); case INST_REVERSE: { @@ -2121,7 +1632,6 @@ TEBCresume( */ if (appendLen == 0) { - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, (opnd-1), 0); } @@ -2142,15 +1652,6 @@ TEBCresume( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG - if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { - TclFreeIntRep(objResultPtr); - objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); - objResultPtr->length = length + appendLen; - p = TclGetString(objResultPtr) + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif { p = ckalloc(length + appendLen + 1); TclNewObj(objResultPtr); @@ -2178,14 +1679,6 @@ TEBCresume( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif { TclNewObj(objResultPtr); bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, @@ -2207,7 +1700,6 @@ TEBCresume( } } - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); } @@ -2242,8 +1734,6 @@ TEBCresume( objPtr = OBJ_AT_TOS; if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); goto gotError; } @@ -2286,28 +1776,6 @@ TEBCresume( NEXT_INST_F(5, 0, 0); } - case INST_EXPR_STK: { - ByteCode *newCodePtr; - - newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); - checkInterp = 1; - cleanup = 1; - pc++; - TEBC_YIELD(); - return TclNRExecuteByteCode(interp, newCodePtr); - } - - /* - * INVOCATION BLOCK - */ - - instEvalStk: - case INST_EVAL_STK: - cleanup = 1; - pc += 1; - TEBC_YIELD(); - return TclNREvalObjEx(interp, OBJ_AT_TOS, 0); - case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; @@ -2327,35 +1795,12 @@ TEBCresume( case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; - goto doInvocation; - - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; doInvocation: + objv = &OBJ_AT_DEPTH(objc-1); cleanup = objc; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call ", objc)); - } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ /* * Finally, let TclEvalObjv handle the command. @@ -2373,147 +1818,11 @@ TEBCresume( return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, NULL); -#if TCL_SUPPORT_84_BYTECODE - case INST_CALL_BUILTIN_FUNC1: - /* - * Call one of the built-in pre-8.5 Tcl math functions. This - * translates to INST_INVOKE_STK1 with the first argument of - * ::tcl::mathfunc::$objv[0]. We need to insert the named math - * function into the stack. - */ - - opnd = TclGetUInt1AtPtr(pc+1); - if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { - TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); - Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd); - } - - TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); - Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); - - /* - * Only 0, 1 or 2 args. - */ - - { - int numArgs = tclBuiltinFuncTable[opnd].numArgs; - Tcl_Obj *tmpPtr1, *tmpPtr2; - - if (numArgs == 0) { - PUSH_OBJECT(objPtr); - } else if (numArgs == 1) { - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - Tcl_DecrRefCount(tmpPtr1); - } else { - tmpPtr2 = POP_OBJECT(); - tmpPtr1 = POP_OBJECT(); - PUSH_OBJECT(objPtr); - PUSH_OBJECT(tmpPtr1); - PUSH_OBJECT(tmpPtr2); - Tcl_DecrRefCount(tmpPtr1); - Tcl_DecrRefCount(tmpPtr2); - } - objc = numArgs + 1; - } - pcAdjustment = 2; - goto doInvocation; - - case INST_CALL_FUNC1: - /* - * Call a non-builtin Tcl math function previously registered by a - * call to Tcl_CreateMathFunc pre-8.5. This is essentially - * INST_INVOKE_STK1 converting the first arg to - * ::tcl::mathfunc::$objv[0]. - */ - - objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function - * name is the 0-th argument. */ - - objPtr = OBJ_AT_DEPTH(objc-1); - TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); - Tcl_AppendObjToObj(tmpPtr, objPtr); - Tcl_DecrRefCount(objPtr); - - /* - * Variation of PUSH_OBJECT. - */ - - OBJ_AT_DEPTH(objc-1) = tmpPtr; - Tcl_IncrRefCount(tmpPtr); - - pcAdjustment = 2; - goto doInvocation; -#else /* * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the - * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support - * remains for existing bytecode precompiled files. + * changes to add a ::tcl::mathfunc namespace in 8.5. */ - case INST_CALL_BUILTIN_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); - case INST_CALL_FUNC1: - Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); -#endif - - case INST_INVOKE_REPLACE: - objc = TclGetUInt4AtPtr(pc+1); - opnd = TclGetUInt1AtPtr(pc+5); - objPtr = POP_OBJECT(); - objv = &OBJ_AT_DEPTH(objc-1); - cleanup = objc; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; - - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); - } else { - fprintf(stdout, - "%d: (%u) invoking (using implementation %s) ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - O2S(objPtr)); - } - for (i = 0; i < objc; i++) { - if (i < opnd) { - fprintf(stdout, "<"); - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, ">"); - } else { - TclPrintObject(stdout, objv[i], 15); - } - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - { - Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); - register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj **copyObjv = &listRepPtr->elements; - int i; - - listRepPtr->elemCount = objc - opnd + 1; - copyObjv[0] = objPtr; - memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd)); - for (i=1 ; i<objc-opnd+1 ; i++) { - Tcl_IncrRefCount(copyObjv[i]); - } - objPtr = copyPtr; - } - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = opnd; - iPtr->ensembleRewrite.numInsertedObjs = 1; - pc += 6; - TEBC_YIELD(); - Tcl_NRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); - TclMarkTailcall(interp); - return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE); - /* * ----------------------------------------------------------------- * Start of INST_LOAD instructions. @@ -2523,43 +1832,18 @@ TEBCresume( * common execution code. */ - case INST_LOAD_SCALAR1: - instLoadScalar1: - opnd = TclGetUInt1AtPtr(pc+1); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - /* - * No errors, no traces: just get the value. - */ - - objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(2, 0, 1); - } - pcAdjustment = 2; - cleanup = 0; - arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - goto doCallPtrGetVar; - case INST_LOAD_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { /* * No errors, no traces: just get the value. */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 0, 1); } pcAdjustment = 5; @@ -2573,10 +1857,6 @@ TEBCresume( pcAdjustment = 5; goto doLoadArray; - case INST_LOAD_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - doLoadArray: part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; @@ -2584,7 +1864,6 @@ TEBCresume( while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (varPtr && TclIsVarDirectReadable(varPtr)) { @@ -2593,14 +1872,12 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); } } varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } cleanup = 1; @@ -2610,15 +1887,12 @@ TEBCresume( cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ objPtr = OBJ_UNDER_TOS; /* array name */ - TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), O2S(part2Ptr))); goto doLoadStk; - case INST_LOAD_STK: case INST_LOAD_SCALAR_STK: cleanup = 1; part2Ptr = NULL; objPtr = OBJ_AT_TOS; /* variable name */ - TRACE(("\"%.30s\" => ", O2S(objPtr))); doLoadStk: part1Ptr = objPtr; @@ -2626,7 +1900,6 @@ TEBCresume( TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -2636,7 +1909,6 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(1, cleanup, 1); } pcAdjustment = 1; @@ -2652,10 +1924,8 @@ TEBCresume( part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); checkInterp = 1; if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); /* @@ -2668,976 +1938,27 @@ TEBCresume( * common execution code. */ - { - int storeFlags; - - case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreArrayDirect; - - case INST_STORE_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doStoreArrayDirect: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), - O2S(valuePtr))); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - if (TclIsVarArray(arrayPtr) && !WriteTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectWritable(varPtr)) { - tosPtr--; - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = valuePtr; - goto doStoreVarDirect; - } - } - cleanup = 2; - storeFlags = TCL_LEAVE_ERR_MSG; - part1Ptr = NULL; - goto doStoreArrayDirectFailed; - case INST_STORE_SCALAR4: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; - goto doStoreScalarDirect; - case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doStoreScalarDirect: valuePtr = OBJ_AT_TOS; varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (!TclIsVarDirectWritable(varPtr)) { - storeFlags = TCL_LEAVE_ERR_MSG; - part1Ptr = NULL; - goto doStoreScalar; - } - - /* - * No traces, no errors, plain 'set': we can safely inline. The value - * *will* be set to what's requested, so that the stack top remains - * pointing to the same Tcl_Obj. - */ - - doStoreVarDirect: - valuePtr = varPtr->value.objPtr; if (valuePtr != NULL) { TclDecrRefCount(valuePtr); } + objResultPtr = OBJ_AT_TOS; varPtr->value.objPtr = objResultPtr; -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - tosPtr--; - NEXT_INST_F((pcAdjustment+1), 0, 0); - } -#else - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); -#endif Tcl_IncrRefCount(objResultPtr); - NEXT_INST_F(pcAdjustment, 0, 0); - - case INST_LAPPEND_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = NULL; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreStk; - - case INST_LAPPEND_ARRAY_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = OBJ_UNDER_TOS; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreStk; - - case INST_APPEND_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = NULL; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreStk; - - case INST_APPEND_ARRAY_STK: - valuePtr = OBJ_AT_TOS; /* value to append */ - part2Ptr = OBJ_UNDER_TOS; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreStk; - - case INST_STORE_ARRAY_STK: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; - storeFlags = TCL_LEAVE_ERR_MSG; - goto doStoreStk; - - case INST_STORE_STK: - case INST_STORE_SCALAR_STK: - valuePtr = OBJ_AT_TOS; - part2Ptr = NULL; - storeFlags = TCL_LEAVE_ERR_MSG; - - doStoreStk: - objPtr = OBJ_AT_DEPTH(1 + (part2Ptr != NULL)); /* variable name */ - part1Ptr = objPtr; -#ifdef TCL_COMPILE_DEBUG - if (part2Ptr == NULL) { - TRACE(("\"%.30s\" <- \"%.30s\" =>", O2S(part1Ptr),O2S(valuePtr))); - } else { - TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ", - O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); - } -#endif - varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, - "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - cleanup = ((part2Ptr == NULL)? 2 : 3); - pcAdjustment = 1; - opnd = -1; - goto doCallPtrSetVar; - - case INST_LAPPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreArray; - - case INST_LAPPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreArray; - - case INST_APPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreArray; - - case INST_APPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreArray; - - doStoreArray: - valuePtr = OBJ_AT_TOS; - part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), - O2S(valuePtr))); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - cleanup = 2; - part1Ptr = NULL; - - doStoreArrayDirectFailed: - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); - if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - goto doCallPtrSetVar; - - case INST_LAPPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreScalar; - - case INST_LAPPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE - | TCL_LIST_ELEMENT); - goto doStoreScalar; - - case INST_APPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreScalar; - - case INST_APPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); - goto doStoreScalar; - - doStoreScalar: - valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - cleanup = 1; - arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - - doCallPtrSetVar: - objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); - checkInterp = 1; - if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - } - - /* - * End of INST_STORE and related instructions. - * ----------------------------------------------------------------- - * Start of INST_INCR instructions. - * - * WARNING: more 'goto' here than your doctor recommended! The different - * instructions set the value of some variables and then jump to somme - * common execution code. - */ - -/*TODO: Consider more untangling here; merge with LOAD and STORE ? */ - - { - Tcl_Obj *incrPtr; -#ifndef NO_WIDE_TYPE - Tcl_WideInt w; -#endif - long increment; - - case INST_INCR_SCALAR1: - case INST_INCR_ARRAY1: - case INST_INCR_ARRAY_STK: - case INST_INCR_SCALAR_STK: - case INST_INCR_STK: - opnd = TclGetUInt1AtPtr(pc+1); - incrPtr = POP_OBJECT(); - switch (*pc) { - case INST_INCR_SCALAR1: - pcAdjustment = 2; - goto doIncrScalar; - case INST_INCR_ARRAY1: - pcAdjustment = 2; - goto doIncrArray; - default: - pcAdjustment = 1; - goto doIncrStk; - } - - case INST_INCR_ARRAY_STK_IMM: - case INST_INCR_SCALAR_STK_IMM: - case INST_INCR_STK_IMM: - increment = TclGetInt1AtPtr(pc+1); - incrPtr = Tcl_NewIntObj(increment); - Tcl_IncrRefCount(incrPtr); - pcAdjustment = 2; - - doIncrStk: - if ((*pc == INST_INCR_ARRAY_STK_IMM) - || (*pc == INST_INCR_ARRAY_STK)) { - part2Ptr = OBJ_AT_TOS; - objPtr = OBJ_UNDER_TOS; - TRACE(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(part2Ptr), increment)); - } else { - part2Ptr = NULL; - objPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment)); - } - part1Ptr = objPtr; - opnd = -1; - varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); - if (!varPtr) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - Tcl_DecrRefCount(incrPtr); - goto gotError; - } - cleanup = ((part2Ptr == NULL)? 1 : 2); - goto doIncrVar; - - case INST_INCR_ARRAY1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); - incrPtr = Tcl_NewIntObj(increment); - Tcl_IncrRefCount(incrPtr); - pcAdjustment = 3; - - doIncrArray: - part1Ptr = NULL; - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - cleanup = 1; - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment)); - varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); - if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - Tcl_DecrRefCount(incrPtr); - goto gotError; - } - goto doIncrVar; - - case INST_INCR_SCALAR1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); - pcAdjustment = 3; - cleanup = 0; - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - if (TclIsVarDirectModifyable(varPtr)) { - ClientData ptr; - int type; - - objPtr = varPtr->value.objPtr; - if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG) { - long augend = *((const long *)ptr); - long sum = augend + increment; - - /* - * Overflow when (augend and sum have different sign) and - * (augend and increment have the same sign). This is - * encapsulated in the Overflowing macro. - */ - - if (!Overflowing(augend, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - TclNewLongObj(objResultPtr, sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - TclSetLongObj(objPtr, sum); - } - goto doneIncr; - } -#ifndef NO_WIDE_TYPE - w = (Tcl_WideInt)augend; - - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(w+increment); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We know the sum value is outside the long range; - * use macro form that doesn't range test again. - */ - - TclSetWideIntObj(objPtr, w+increment); - } - goto doneIncr; -#endif - } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef NO_WIDE_TYPE - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt sum; - - w = *((const Tcl_WideInt *) ptr); - sum = w + increment; - - /* - * Check for overflow. - */ - - if (!Overflowing(w, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We *do not* know the sum value is outside the - * long range (wide + long can yield long); use - * the function call that checks range. - */ - - Tcl_SetWideIntObj(objPtr, sum); - } - goto doneIncr; - } - } -#endif - } - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared */ - objResultPtr = Tcl_DuplicateObj(objPtr); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - } - TclNewLongObj(incrPtr, increment); - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - Tcl_DecrRefCount(incrPtr); - goto doneIncr; - } - - /* - * All other cases, flow through to generic handling. - */ - - TclNewLongObj(incrPtr, increment); - Tcl_IncrRefCount(incrPtr); - - doIncrScalar: - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - arrayPtr = NULL; - part1Ptr = part2Ptr = NULL; - cleanup = 0; - TRACE(("%u %ld => ", opnd, increment)); - - doIncrVar: - if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { - objPtr = varPtr->value.objPtr; - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared */ - objResultPtr = Tcl_DuplicateObj(objPtr); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - } - if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { - Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - Tcl_DecrRefCount(incrPtr); - } else { - objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); - checkInterp = 1; - Tcl_DecrRefCount(incrPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } - doneIncr: - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); -#ifndef TCL_COMPILE_DEBUG - if (*(pc+pcAdjustment) == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); - } -#endif - NEXT_INST_V(pcAdjustment, cleanup, 1); - } - - /* - * End of INST_INCR instructions. - * ----------------------------------------------------------------- - * Start of INST_EXIST instructions. - */ - - case INST_EXIST_SCALAR: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (ReadTraced(varPtr)) { - TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL, - TCL_TRACE_READS, 0, opnd); - checkInterp = 1; - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, NULL); - varPtr = NULL; - } - } - - /* - * Tricky! Arrays always exist. - */ - - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 0, 1); - - case INST_EXIST_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (!varPtr || !ReadTraced(varPtr)) { - goto doneExistArray; - } - } - varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", - 0, 1, arrayPtr, opnd); - if (varPtr) { - if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { - TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr, - TCL_TRACE_READS, 0, opnd); - checkInterp = 1; - } - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, arrayPtr); - varPtr = NULL; - } - } - doneExistArray: - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 1, 1); - - case INST_EXIST_ARRAY_STK: - cleanup = 2; - part2Ptr = OBJ_AT_TOS; /* element name */ - part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); - goto doExistStk; - - case INST_EXIST_STK: - cleanup = 1; - part2Ptr = NULL; - part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - - doExistStk: - varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access", - /*createPart1*/0, /*createPart2*/1, &arrayPtr); - if (varPtr) { - if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { - TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr, - TCL_TRACE_READS, 0, -1); - checkInterp = 1; - } - if (TclIsVarUndefined(varPtr)) { - TclCleanupVar(varPtr, arrayPtr); - varPtr = NULL; - } - } - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); - - /* - * End of INST_EXIST instructions. - * ----------------------------------------------------------------- - * Start of INST_UNSET instructions. - */ - - { - int flags; - - case INST_UNSET_SCALAR: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd)); - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - /* - * No errors, no traces, no searches: just make the variable cease - * to exist. - */ - - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetScalar; - } - varPtr->value.objPtr = NULL; - NEXT_INST_F(6, 0, 0); - } - - slowUnsetScalar: - if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, - opnd) != TCL_OK && flags) { - goto errorInUnset; - } - checkInterp = 1; - NEXT_INST_F(6, 0, 0); - - case INST_UNSET_ARRAY: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - TRACE(("%s %u \"%.30s\"\n", - (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { - varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); - if (varPtr && TclIsVarDirectUnsettable(varPtr)) { - /* - * No nasty traces and element exists, so we can proceed to - * unset it. Might still not exist though... - */ - - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } else if (flags & TCL_LEAVE_ERR_MSG) { - goto slowUnsetArray; - } - varPtr->value.objPtr = NULL; - NEXT_INST_F(6, 1, 0); - } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { - /* - * Don't need to do anything here. - */ - - NEXT_INST_F(6, 1, 0); - } - } - slowUnsetArray: - varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", - 0, 0, arrayPtr, opnd); - if (!varPtr) { - if (flags & TCL_LEAVE_ERR_MSG) { - goto errorInUnset; - } - } else if (TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, part2Ptr, - flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } - checkInterp = 1; - NEXT_INST_F(6, 1, 0); - - case INST_UNSET_ARRAY_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - cleanup = 2; - part2Ptr = OBJ_AT_TOS; /* element name */ - part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"), - O2S(part1Ptr), O2S(part2Ptr))); - goto doUnsetStk; - - case INST_UNSET_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - cleanup = 1; - part2Ptr = NULL; - part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); - - doUnsetStk: - if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK - && (flags & TCL_LEAVE_ERR_MSG)) { - goto errorInUnset; - } - checkInterp = 1; - NEXT_INST_V(2, cleanup, 0); - - errorInUnset: - checkInterp = 1; - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - - /* - * This is really an unset operation these days. Do not issue. - */ - - case INST_DICT_DONE: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u\n", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { - if (!TclIsVarUndefined(varPtr)) { - TclDecrRefCount(varPtr->value.objPtr); - } - varPtr->value.objPtr = NULL; - } else { - TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - checkInterp = 1; - } NEXT_INST_F(5, 0, 0); - } - - /* - * End of INST_UNSET instructions. - * ----------------------------------------------------------------- - * Start of INST_ARRAY instructions. - */ - - case INST_ARRAY_EXISTS_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 0; - part1Ptr = NULL; - arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - goto doArrayExists; - case INST_ARRAY_EXISTS_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 1; - part1Ptr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, - /*createPart1*/0, /*createPart2*/0, &arrayPtr); - doArrayExists: - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, - NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| - TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); - if (result == TCL_ERROR) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - objResultPtr = TCONST(1); - } else { - objResultPtr = TCONST(0); - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(pcAdjustment, cleanup, 1); - - case INST_ARRAY_MAKE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 0; - part1Ptr = NULL; - arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - goto doArrayMake; - case INST_ARRAY_MAKE_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 1; - part1Ptr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", O2S(part1Ptr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, - "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - doArrayMake: - if (varPtr && !TclIsVarArray(varPtr)) { - if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { - /* - * Either an array element, or a scalar: lose! - */ - - TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", - "variable isn't array", opnd); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - TRACE_APPEND(("ERROR: bad array ref: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, - TclGetVarNsPtr(varPtr)); -#ifdef TCL_COMPILE_DEBUG - TRACE_APPEND(("done\n")); - } else { - TRACE_APPEND(("nothing to do\n")); -#endif - } - NEXT_INST_V(pcAdjustment, cleanup, 0); /* - * End of INST_ARRAY instructions. - * ----------------------------------------------------------------- - * Start of variable linking instructions. - */ - - { - Var *otherPtr; - CallFrame *framePtr, *savedFramePtr; - Tcl_Namespace *nsPtr; - Namespace *savedNsPtr; - - case INST_UPVAR: - TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); - - if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { - goto gotError; - } - - /* - * Locate the other variable. - */ - - savedFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = framePtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1, - /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr = savedFramePtr; - if (!otherPtr) { - goto gotError; - } - goto doLinkVars; - - case INST_NSUPVAR: - TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); - if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { - goto gotError; - } - - /* - * Locate the other variable. - */ - - savedNsPtr = iPtr->varFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr->nsPtr = savedNsPtr; - if (!otherPtr) { - goto gotError; - } - goto doLinkVars; - - case INST_VARIABLE: - TRACE(("variable ")); - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - if (!otherPtr) { - goto gotError; - } - - /* - * Do the [variable] magic. - */ - - TclSetVarNamespaceVar(otherPtr); - - doLinkVars: - - /* - * If we are here, the local variable has already been created: do the - * little work of TclPtrMakeUpvar that remains to be done right here - * if there are no errors; otherwise, let it handle the case. - */ - - opnd = TclGetInt4AtPtr(pc+1);; - varPtr = LOCAL(opnd); - if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) - && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { - if (!TclIsVarUndefined(varPtr)) { - /* - * Then it is a defined link. - */ - - Var *linkPtr = varPtr->value.linkPtr; - - if (linkPtr == otherPtr) { - NEXT_INST_F(5, 1, 0); - } - if (TclIsVarInHash(linkPtr)) { - VarHashRefCount(linkPtr)--; - if (TclIsVarUndefined(linkPtr)) { - TclCleanupVar(linkPtr, NULL); - } - } - } - TclSetVarLink(varPtr); - varPtr->value.linkPtr = otherPtr; - if (TclIsVarInHash(otherPtr)) { - VarHashRefCount(otherPtr)++; - } - } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, - opnd) != TCL_OK) { - goto gotError; - } - - /* - * Do not pop the namespace or frame index, it may be needed for other - * variables - and [variable] did not push it at all. - */ - - NEXT_INST_F(5, 1, 0); - } - - /* - * End of variable linking instructions. - * ----------------------------------------------------------------- + * End of INST_STORE and related instructions. */ - case INST_JUMP1: - opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); - NEXT_INST_F(opnd, 0, 0); - case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); { @@ -3655,549 +1976,32 @@ TEBCresume( jmpOffset[1] = TclGetInt4AtPtr(pc+1); goto doCondJump; - case INST_JUMP_FALSE1: - jmpOffset[0] = TclGetInt1AtPtr(pc+1); - jmpOffset[1] = 2; - goto doCondJump; - - case INST_JUMP_TRUE1: - jmpOffset[0] = 2; - jmpOffset[1] = TclGetInt1AtPtr(pc+1); - doCondJump: valuePtr = OBJ_AT_TOS; /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { - TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ - ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) - ? 0 : 1]), Tcl_GetObjResult(interp)); goto gotError; } -#ifdef TCL_COMPILE_DEBUG - if (b) { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], - O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); - } else { - TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); - } - } else { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); - } else { - TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], - O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); - } - } -#endif NEXT_INST_F(jmpOffset[b], 1, 0); } - case INST_JUMP_TABLE: { - Tcl_HashEntry *hPtr; - JumptableInfo *jtPtr; - - /* - * Jump to location looked up in a hashtable; fall through to next - * instr if lookup fails. - */ - - opnd = TclGetInt4AtPtr(pc+1); - jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS))); - hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); - if (hPtr != NULL) { - int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - - TRACE_APPEND(("found in table, new pc %u\n", - (unsigned)(pc - codePtr->codeStart + jumpOffset))); - NEXT_INST_F(jumpOffset, 1, 0); - } else { - TRACE_APPEND(("not found in table\n")); - NEXT_INST_F(5, 1, 0); - } - } - - /* - * 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"))); - IllegalExprOperandType(interp, pc, valuePtr); - checkInterp = 1; - goto gotError; - } - - if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), - (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - checkInterp = 1; - 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. */ - case INST_NS_CURRENT: { - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - - if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { - TclNewLiteralStringObj(objResultPtr, "::"); - } else { - TclNewStringObj(objResultPtr, currNsPtr->fullName, - strlen(currNsPtr->fullName)); - } - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - } - case INST_COROUTINE_NAME: { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - TclNewObj(objResultPtr); - if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) { - Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, - objResultPtr); - } - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - } - case INST_INFO_LEVEL_NUM: - TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - case INST_INFO_LEVEL_ARGS: { - int level; - register CallFrame *framePtr = iPtr->varFramePtr; - register CallFrame *rootFramePtr = iPtr->rootFramePtr; - - valuePtr = OBJ_AT_TOS; - if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - goto gotError; - } - TRACE(("%d => ", level)); - if (level <= 0) { - level += framePtr->level; - } - for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; - framePtr = framePtr->callerVarPtr) { - /* Empty loop body */ - } - if (framePtr == rootFramePtr) { - Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr), - "\"", NULL); - TRACE_APPEND(("ERROR: bad level\n")); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(valuePtr), NULL); - goto gotError; - } - objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } - case INST_RESOLVE_COMMAND: { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); - - TclNewObj(objResultPtr); - if (cmd != NULL) { - Tcl_GetCommandFullName(interp, cmd, objResultPtr); - } - TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - } - case INST_TCLOO_SELF: { - CallFrame *framePtr = iPtr->varFramePtr; - CallContext *contextPtr; - - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE(("=> ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "self may only be called from inside a method", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); - goto gotError; - } - contextPtr = framePtr->clientData; - - /* - * Call out to get the name; it's expensive to compute but cached. - */ - - objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); - TRACE_WITH_OBJ(("=> "), objResultPtr); - NEXT_INST_F(1, 0, 1); - } - { - Object *oPtr; - - case INST_TCLOO_IS_OBJECT: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - objResultPtr = TCONST(oPtr != NULL ? 1 : 0); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - case INST_TCLOO_CLASS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; - } - objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - case INST_TCLOO_NS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; - } - - /* - * TclOO objects *never* have the global namespace as their NS. - */ - - TclNewStringObj(objResultPtr, oPtr->namespacePtr->fullName, - strlen(oPtr->namespacePtr->fullName)); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); - } - /* * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ { - int index, numIndices, fromIdx, toIdx; - int nocase, match, length2, cflags, s1len, s2len; + int match, s1len, s2len; const char *s1, *s2; - case INST_LIST: - /* - * Pop the opnd (objc) top stack elements into a new list obj and then - * decrement their ref counts. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 1); - - case INST_LIST_LENGTH: - valuePtr = OBJ_AT_TOS; - if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); - goto gotError; - } - TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); - NEXT_INST_F(1, 1, 1); - - case INST_LIST_INDEX: /* lindex with objc == 3 */ - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - * Extract the desired list element. - */ - - if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && (value2Ptr->typePtr != &tclListType) - && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, - &index) == TCL_OK)) { - TclDecrRefCount(value2Ptr); - tosPtr--; - pcAdjustment = 1; - goto lindexFastPath; - } - - objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); - if (!objResultPtr) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Stash the list element on the stack. - */ - - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ - - case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode - * stream */ - - /* - * Pop the list and get the index. - */ - - valuePtr = OBJ_AT_TOS; - opnd = TclGetInt4AtPtr(pc+1); - - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), - Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Select the list item based on the index. Negative operand means - * end-based indexing. - */ - - if (opnd < -1) { - index = opnd+1 + objc; - } else { - index = opnd; - } - pcAdjustment = 5; - - lindexFastPath: - if (index >= 0 && index < objc) { - objResultPtr = objv[index]; - } else { - TclNewObj(objResultPtr); - } - - TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), - objResultPtr); - NEXT_INST_F(pcAdjustment, 1, 1); - - case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ - /* - * Determine the count of index args. - */ - - opnd = TclGetUInt4AtPtr(pc+1); - numIndices = opnd-1; - - /* - * Do the 'lindex' operation. - */ - - objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), - numIndices, &OBJ_AT_DEPTH(numIndices - 1)); - if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Set result. - */ - - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); - NEXT_INST_V(5, opnd, -1); - - case INST_LSET_FLAT: - /* - * Lset with 3, 5, or more args. Get the number of index args. - */ - - opnd = TclGetUInt4AtPtr(pc + 1); - numIndices = opnd - 2; - - /* - * Get the old value of variable, and remove the stack ref. This is - * safe because the variable still references the object; the ref - * count will never go zero here - we can use the smaller macro - * Tcl_DecrRefCount. - */ - - valuePtr = POP_OBJECT(); - Tcl_DecrRefCount(valuePtr); /* This one should be done here */ - - /* - * Compute the new variable value. - */ - - objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, - &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); - if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Set result. - */ - - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); - NEXT_INST_V(5, numIndices+1, -1); - - case INST_LSET_LIST: /* 'lset' with 4 args */ - /* - * Get the old value of variable, and remove the stack ref. This is - * safe because the variable still references the object; the ref - * count will never go zero here - we can use the smaller macro - * Tcl_DecrRefCount. - */ - - objPtr = POP_OBJECT(); - Tcl_DecrRefCount(objPtr); /* This one should be done here. */ - - /* - * Get the new element value, and the index list. - */ - - valuePtr = OBJ_AT_TOS; - value2Ptr = OBJ_UNDER_TOS; - - /* - * Compute the new variable value. - */ - - objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); - if (!objResultPtr) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Set result. - */ - - TRACE(("=> %s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, -1); - - case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in - * bytecode stream */ - - /* - * Pop the list and get the indices. - */ - - valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); - - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); - goto gotError; - } - - /* - * Skip a lot of work if we're about to throw the result away (common - * with uses of [lassign]). - */ - -#ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_F(10, 1, 0); - } -#endif - - /* - * Adjust the indices for end-based handling. - */ - - if (fromIdx < -1) { - fromIdx += 1+objc; - if (fromIdx < -1) { - fromIdx = -1; - } - } else if (fromIdx > objc) { - fromIdx = objc; - } - if (toIdx < -1) { - toIdx += 1 + objc; - if (toIdx < -1) { - toIdx = -1; - } - } else if (toIdx > objc) { - toIdx = objc; - } - - /* - * Check if we are referring to a valid, non-empty list range, and if - * so, build the list of elements in that range. - */ - - if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= objc) { - toIdx = objc-1; - } - if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { - /* - * BEWARE! This is looking inside the implementation of the - * list type. - */ - - List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; - - if (listPtr->refCount == 1) { - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; index<objc-1 ; index++) { - TclDecrRefCount(objv[index]); - } - listPtr->elemCount = toIdx+1; - listPtr->canonicalFlag = 1; - TclInvalidateStringRep(valuePtr); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); - } - } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); - } else { - TclNewObj(objResultPtr); - } - - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); - NEXT_INST_F(9, 1, 1); - case INST_LIST_IN: case INST_LIST_NOT_IN: /* Basic list containment operators. */ value2Ptr = OBJ_AT_TOS; @@ -4205,8 +2009,6 @@ TEBCresume( s1 = TclGetStringFromObj(valuePtr, &s1len); if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); goto gotError; } match = 0; @@ -4237,8 +2039,6 @@ TEBCresume( match = !match; } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); - /* * Peep-hole optimisation: if you're about to jump, do jump from here. * We're saving the effort of pushing a boolean value only to pop it @@ -4246,30 +2046,11 @@ TEBCresume( */ pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); - /* - * End of INST_LIST and related instructions. - * ----------------------------------------------------------------- - * Start of string-related instructions. - */ - - case INST_STR_EQ: + case INST_STR_EQ: case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ stringCompare: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -4361,7 +2142,7 @@ TEBCresume( * TODO: consider peephole opt. */ - if (*pc != INST_STR_CMP) { + if (1) { /* * Take care of the opcodes that goto'ed into here. */ @@ -4394,334 +2175,8 @@ TEBCresume( } else { objResultPtr = TCONST(match > 0); } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - case INST_STR_LEN: - valuePtr = OBJ_AT_TOS; - length = Tcl_GetCharLength(valuePtr); - TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); - NEXT_INST_F(1, 1, 1); - - case INST_STR_INDEX: - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - * Get char length to calulate what 'end' means. - */ - - length = Tcl_GetCharLength(valuePtr); - if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { - goto gotError; - } - - if ((index < 0) || (index >= length)) { - TclNewObj(objResultPtr); - } else if (TclIsPureByteArray(valuePtr)) { - objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, &length)+index, 1); - } else if (valuePtr->bytes && length == valuePtr->length) { - objResultPtr = Tcl_NewStringObj((const char *) - valuePtr->bytes+index, 1); - } else { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index); - - /* - * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) - * but creating the object as a string seems to be faster in - * practical use. - */ - - length = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, length); - } - - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - - case INST_STR_RANGE: - TRACE(("\"%.20s\" %s %s =>", - O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, - &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, - &toIdx) != TCL_OK) { - goto gotError; - } - - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= length) { - toIdx = length; - } - if (toIdx >= fromIdx) { - objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); - } else { - TclNewObj(objResultPtr); - } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(1, 3, 1); - - case INST_STR_RANGE_IMM: - valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); - length = Tcl_GetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); - - /* - * Adjust indices for end-based indexing. - */ - - if (fromIdx < -1) { - fromIdx += 1 + length; - if (fromIdx < 0) { - fromIdx = 0; - } - } else if (fromIdx >= length) { - fromIdx = length; - } - if (toIdx < -1) { - toIdx += 1 + length; - } else if (toIdx >= length) { - toIdx = length - 1; - } - - /* - * Check if we can do a sane substring. - */ - - if (fromIdx <= toIdx) { - objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); - } else { - TclNewObj(objResultPtr); - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(9, 1, 1); - - { - Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - int length3; - Tcl_Obj *value3Ptr; - - case INST_STR_MAP: - valuePtr = OBJ_AT_TOS; /* "Main" string. */ - value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ - value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ - if (value3Ptr == value2Ptr) { - objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); - } else if (valuePtr == value2Ptr) { - objResultPtr = value3Ptr; - NEXT_INST_V(1, 3, 1); - } - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - if (length == 0) { - objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); - } - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); - if (length2 > length || length2 == 0) { - objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); - } else if (length2 == length) { - if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { - objResultPtr = valuePtr; - } else { - objResultPtr = value3Ptr; - } - NEXT_INST_V(1, 3, 1); - } - ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); - - objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); - p = ustring1; - end = ustring1 + length; - for (; ustring1 < end; ustring1++) { - if ((*ustring1 == *ustring2) && (length2==1 || - memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) - == 0)) { - if (p != ustring1) { - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); - p = ustring1 + length2; - } else { - p += length2; - } - ustring1 = p - 1; - - Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); - } - } - if (p != ustring1) { - /* - * Put the rest of the unmapped chars onto result. - */ - - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); - } - TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", - O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); - NEXT_INST_V(1, 3, 1); - - case INST_STR_FIND: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - end = ustring1 + length - length2 + 1; - for (p=ustring1 ; p<end ; p++) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } - - TRACE(("%.20s %.20s => %d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - - TclNewIntObj(objResultPtr, match); - NEXT_INST_F(1, 2, 1); - - case INST_STR_FIND_LAST: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } - - TRACE(("%.20s %.20s => %d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - - TclNewIntObj(objResultPtr, match); - NEXT_INST_F(1, 2, 1); - } - - case INST_STR_MATCH: - nocase = TclGetInt1AtPtr(pc+1); - valuePtr = OBJ_AT_TOS; /* String */ - value2Ptr = OBJ_UNDER_TOS; /* Pattern */ - - /* - * Check that at least one of the objects is Unicode before promoting - * both. - */ - - if ((valuePtr->typePtr == &tclStringType) - || (value2Ptr->typePtr == &tclStringType)) { - Tcl_UniChar *ustring1, *ustring2; - - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, length, ustring2, length2, - nocase); - } else if (TclIsPureByteArray(valuePtr) && !nocase) { - unsigned char *bytes1, *bytes2; - - bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length); - bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); - match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0); - } else { - match = Tcl_StringCaseMatch(TclGetString(valuePtr), - TclGetString(value2Ptr), nocase); - } - - /* - * Reuse value2Ptr object already on stack if possible. Adjustment is - * 2 due to the nocase byte - */ - - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - */ - - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); - - case INST_REGEXP: - cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ - valuePtr = OBJ_AT_TOS; /* String */ - value2Ptr = OBJ_UNDER_TOS; /* Pattern */ - - /* - * Compile and match the regular expression. - */ - - { - Tcl_RegExp regExpr = - Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); - - if (regExpr == NULL) { - goto regexpFailure; - } - - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - - if (match < 0) { - regexpFailure: -#ifdef TCL_COMPILE_DEBUG - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); -#endif - goto gotError; - } - } - - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - * Adjustment is 2 due to the nocase byte. - */ - - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); } /* @@ -4820,18 +2275,6 @@ TEBCresume( foundResult: pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif objResultPtr = TCONST(iResult); NEXT_INST_F(0, 2, 1); } @@ -4847,9 +2290,6 @@ TEBCresume( if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1==TCL_NUMBER_DOUBLE) || (type1==TCL_NUMBER_NAN)) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), - O2S(value2Ptr), (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); checkInterp = 1; goto gotError; @@ -4857,9 +2297,6 @@ TEBCresume( if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) || (type2==TCL_NUMBER_DOUBLE) || (type2==TCL_NUMBER_NAN)) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), - O2S(value2Ptr), (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, value2Ptr); checkInterp = 1; goto gotError; @@ -4876,26 +2313,20 @@ TEBCresume( switch (*pc) { case INST_MOD: if (l2 == 0) { - TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), - O2S(value2Ptr))); goto divideByZero; } else if ((l2 == 1) || (l2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else if (l1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { lResult = l1 / l2; @@ -4926,9 +2357,7 @@ TEBCresume( #endif goto gotError; } else if (l1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { /* @@ -4943,13 +2372,11 @@ TEBCresume( * 4e9 and the latter 32 or 64... */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (l1 > 0L) { objResultPtr = TCONST(0); } else { TclNewIntObj(objResultPtr, -1); } - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } @@ -4973,9 +2400,7 @@ TEBCresume( #endif goto gotError; } else if (l1 == 0) { - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else if (l2 > (long) INT_MAX) { /* @@ -5012,7 +2437,6 @@ TEBCresume( * Too large; need to use the broken-out function. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); break; case INST_BITAND: @@ -5024,14 +2448,11 @@ TEBCresume( case INST_BITXOR: lResult = l1 ^ l2; longResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } } @@ -5042,21 +2463,15 @@ TEBCresume( * is highly undesirable due to the overall impact on size. */ - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), valuePtr, value2Ptr); if (objResultPtr == DIVIDED_BY_ZERO) { - TRACE_APPEND(("DIVIDE BY ZERO\n")); goto divideByZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); goto gotError; } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } @@ -5070,9 +2485,6 @@ TEBCresume( if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, valuePtr); checkInterp = 1; goto gotError; @@ -5090,9 +2502,6 @@ TEBCresume( if ((GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) || IsErroringNaNType(type2)) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), O2S(valuePtr), - (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); IllegalExprOperandType(interp, pc, value2Ptr); checkInterp = 1; goto gotError; @@ -5156,20 +2565,15 @@ TEBCresume( } #endif wideResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewWideIntObj(wResult); - TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } Tcl_SetWideIntObj(valuePtr, wResult); - TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); case INST_DIV: if (l2 == 0) { - TRACE(("%s %s => DIVIDE BY ZERO\n", - O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; } else if ((l1 == LONG_MIN) && (l2 == -1)) { /* @@ -5210,24 +2614,17 @@ TEBCresume( } overflow: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = ExecuteExtendedBinaryMathOp(interp, *pc, &TCONST(0), valuePtr, value2Ptr); if (objResultPtr == DIVIDED_BY_ZERO) { - TRACE_APPEND(("DIVIDE BY ZERO\n")); goto divideByZero; } else if (objResultPtr == EXPONENT_OF_ZERO) { - TRACE_APPEND(("EXPONENT OF ZERO\n")); goto exponOfZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); goto gotError; } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } @@ -5239,8 +2636,6 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); checkInterp = 1; goto gotError; @@ -5258,8 +2653,6 @@ TEBCresume( * ... ~$NonInteger => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); checkInterp = 1; goto gotError; @@ -5284,8 +2677,6 @@ TEBCresume( valuePtr = OBJ_AT_TOS; if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); IllegalExprOperandType(interp, pc, valuePtr); checkInterp = 1; goto gotError; @@ -5329,15 +2720,12 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); IllegalExprOperandType(interp, pc, valuePtr); checkInterp = 1; goto gotError; } /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } if (IsErroringNaNType(type1)) { @@ -5346,8 +2734,6 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), - (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); IllegalExprOperandType(interp, pc, valuePtr); checkInterp = 1; } else { @@ -5355,8 +2741,6 @@ TEBCresume( * Numeric conversion of NaN -> error. */ - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); TclExprFloatError(interp, *((const double *) ptr1)); checkInterp = 1; } @@ -5373,7 +2757,6 @@ TEBCresume( */ if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { @@ -5388,11 +2771,9 @@ TEBCresume( valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5401,829 +2782,6 @@ TEBCresume( * ----------------------------------------------------------------- */ - case INST_BREAK: - /* - Tcl_ResetResult(interp); - checkInterp = 1; - */ - result = TCL_BREAK; - cleanup = 0; - goto processExceptionReturn; - - case INST_CONTINUE: - /* - Tcl_ResetResult(interp); - checkInterp = 1; - */ - result = TCL_CONTINUE; - cleanup = 0; - 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: - /* - * 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: - /* - * "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); - 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_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), 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 { - if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ - checkInterp = 1; - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); - TclDecrRefCount(listPtr); - goto gotError; - } - checkInterp = 1; - } - valIndex++; - } - TclDecrRefCount(listPtr); - listTmpIndex++; - } - } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, 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); - } - } - - 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. - */ - - catchStack[++catchDepth] = INT2PTR(CURR_DEPTH); - TRACE(("%u => catchDepth=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), (int) (catchDepth), - (int) CURR_DEPTH)); - NEXT_INST_F(5, 0, 0); - - case INST_END_CATCH: - catchDepth--; - Tcl_ResetResult(interp); - checkInterp = 1; - result = TCL_OK; - TRACE(("=> catchDepth=%d\n", (int) (catchDepth))); - 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: - objResultPtr = Tcl_GetReturnOptions(interp, result); - checkInterp = 1; - 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; - } - NEXT_INST_F(2*code -1, 1, 0); - } - - /* - * ----------------------------------------------------------------- - * Start of dictionary-related instructions. - */ - - { - int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; - Tcl_Obj *emptyPtr, **keyPtrPtr; - Tcl_DictSearch *searchPtr; - DictUpdateInfo *duiPtr; - - case INST_DICT_VERIFY: - dictPtr = OBJ_AT_TOS; - TRACE(("=> ")); - if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { - TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n", - O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 1, 0); - - case INST_DICT_GET: - case INST_DICT_EXISTS: { - register Tcl_Interp *interp2 = interp; - - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd); - if (*pc == INST_DICT_EXISTS) { - interp2 = NULL; - } - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - if (*pc == INST_DICT_EXISTS) { - goto dictNotExists; - } - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; - } - } - if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, - &objResultPtr) == TCL_OK) { - if (*pc == INST_DICT_EXISTS) { - objResultPtr = TCONST(objResultPtr ? 1 : 0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - if (objResultPtr) { - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - checkInterp = 1; - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); - } else { - if (*pc == INST_DICT_EXISTS) { - dictNotExists: - objResultPtr = TCONST(0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); - } - goto gotError; - } - - case INST_DICT_SET: - case INST_DICT_UNSET: - case INST_DICT_INCR_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - - varPtr = LOCAL(opnd2); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u %u => ", opnd, opnd2)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); - checkInterp = 1; - } - if (dictPtr == NULL) { - TclNewObj(dictPtr); - allocateDict = 1; - } else { - allocateDict = Tcl_IsShared(dictPtr); - if (allocateDict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - } - - switch (*pc) { - case INST_DICT_SET: - cleanup = opnd + 1; - result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS); - break; - case INST_DICT_INCR_IMM: - cleanup = 1; - opnd = TclGetInt4AtPtr(pc+1); - result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); - if (result != TCL_OK) { - break; - } - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd)); - } else { - value2Ptr = Tcl_NewIntObj(opnd); - Tcl_IncrRefCount(value2Ptr); - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); - } - result = TclIncrObj(interp, valuePtr, value2Ptr); - if (result == TCL_OK) { - TclInvalidateStringRep(dictPtr); - } - TclDecrRefCount(value2Ptr); - } - break; - case INST_DICT_UNSET: - cleanup = opnd; - result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd-1)); - break; - default: - cleanup = 0; /* stop compiler warning */ - Tcl_Panic("Should not happen!"); - } - - if (result != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", - opnd, opnd2), Tcl_GetObjResult(interp)); - goto checkForCatch; - } - - if (TclIsVarDirectWritable(varPtr)) { - if (allocateDict) { - value2Ptr = varPtr->value.objPtr; - Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = dictPtr; - } - objResultPtr = dictPtr; - } else { - Tcl_IncrRefCount(dictPtr); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd2); - checkInterp = 1; - TclDecrRefCount(dictPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+9) == INST_POP) { - NEXT_INST_V(10, cleanup, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(9, cleanup, 1); - - case INST_DICT_APPEND: - case INST_DICT_LAPPEND: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - checkInterp = 1; - } - if (dictPtr == NULL) { - TclNewObj(dictPtr); - allocateDict = 1; - } else { - allocateDict = Tcl_IsShared(dictPtr); - if (allocateDict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - } - - if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, - &valuePtr) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - - /* - * Note that a non-existent key results in a NULL valuePtr, which is a - * case handled separately below. What we *can* say at this point is - * that the write-back will always succeed. - */ - - switch (*pc) { - case INST_DICT_APPEND: - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else { - Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS); - - /* - * Must invalidate the string representation of dictionary - * here because we have directly updated the internal - * representation; if we don't, callers could see the wrong - * string rep despite the internal version of the dictionary - * having the correct value. [Bug 3079830] - */ - - TclInvalidateStringRep(dictPtr); - } - break; - case INST_DICT_LAPPEND: - /* - * More complex because list-append can fail. - */ - - if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, - Tcl_NewListObj(1, &OBJ_AT_TOS)); - break; - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - TclDecrRefCount(valuePtr); - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); - } else { - if (Tcl_ListObjAppendElement(interp, valuePtr, - OBJ_AT_TOS) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - - /* - * Must invalidate the string representation of dictionary - * here because we have directly updated the internal - * representation; if we don't, callers could see the wrong - * string rep despite the internal version of the dictionary - * having the correct value. [Bug 3079830] - */ - - TclInvalidateStringRep(dictPtr); - } - break; - default: - Tcl_Panic("Should not happen!"); - } - - if (TclIsVarDirectWritable(varPtr)) { - if (allocateDict) { - value2Ptr = varPtr->value.objPtr; - Tcl_IncrRefCount(dictPtr); - if (value2Ptr != NULL) { - TclDecrRefCount(value2Ptr); - } - varPtr->value.objPtr = dictPtr; - } - objResultPtr = dictPtr; - } else { - Tcl_IncrRefCount(dictPtr); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); - checkInterp = 1; - TclDecrRefCount(dictPtr); - if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - } -#ifndef TCL_COMPILE_DEBUG - if (*(pc+5) == INST_POP) { - NEXT_INST_F(6, 2, 0); - } -#endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 2, 1); - - case INST_DICT_FIRST: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = POP_OBJECT(); - searchPtr = ckalloc(sizeof(Tcl_DictSearch)); - if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, - &valuePtr, &done) != TCL_OK) { - ckfree(searchPtr); - goto gotError; - } - TclNewObj(statePtr); - statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; - varPtr = LOCAL(opnd); - if (varPtr->value.objPtr) { - if (varPtr->value.objPtr->typePtr == &dictIteratorType) { - Tcl_Panic("mis-issued dictFirst!"); - } - TclDecrRefCount(varPtr->value.objPtr); - } - varPtr->value.objPtr = statePtr; - Tcl_IncrRefCount(statePtr); - goto pushDictIteratorResult; - - case INST_DICT_NEXT: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { - Tcl_Panic("mis-issued dictNext!"); - } - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); - pushDictIteratorResult: - if (done) { - TclNewObj(emptyPtr); - PUSH_OBJECT(emptyPtr); - PUSH_OBJECT(emptyPtr); - } else { - PUSH_OBJECT(valuePtr); - PUSH_OBJECT(keyPtr); - } - -#ifndef TCL_COMPILE_DEBUG - /* - * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always - * followed by a conditional jump, so we can take advantage of this to - * do some peephole optimization (note that we're careful to not close - * out someone doing something else). - */ - - pc += 5; - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0); - default: - pc -= 5; - /* fall through to non-debug handling */ - } -#endif - - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - objResultPtr = TCONST(done); - /* TODO: consider opt like INST_FOREACH_STEP4 */ - NEXT_INST_F(5, 0, 1); - - case INST_DICT_UPDATE_START: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, - TCL_LEAVE_ERR_MSG, opnd); - checkInterp = 1; - if (dictPtr == NULL) { - goto gotError; - } - } - if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, - &keyPtrPtr) != TCL_OK) { - goto gotError; - } - if (length != duiPtr->length) { - Tcl_Panic("dictUpdateStart argument length mismatch"); - } - for (i=0 ; i<length ; i++) { - if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], - &valuePtr) != TCL_OK) { - goto gotError; - } - varPtr = LOCAL(duiPtr->varIndices[i]); - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - if (valuePtr == NULL) { - TclObjUnsetVar2(interp, - localName(iPtr->varFramePtr, duiPtr->varIndices[i]), - NULL, 0); - } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, - duiPtr->varIndices[i]) == NULL) { - checkInterp = 1; - goto gotError; - } - checkInterp = 1; - } - NEXT_INST_F(9, 0, 0); - - case INST_DICT_UPDATE_END: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - varPtr = LOCAL(opnd); - duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - TRACE(("%u => ", opnd)); - if (TclIsVarDirectReadable(varPtr)) { - dictPtr = varPtr->value.objPtr; - } else { - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); - checkInterp = 1; - } - if (dictPtr == NULL) { - NEXT_INST_F(9, 1, 0); - } - if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK - || TclListObjGetElements(interp, OBJ_AT_TOS, &length, - &keyPtrPtr) != TCL_OK) { - goto gotError; - } - allocdict = Tcl_IsShared(dictPtr); - if (allocdict) { - dictPtr = Tcl_DuplicateObj(dictPtr); - } - if (length > 0) { - TclInvalidateStringRep(dictPtr); - } - for (i=0 ; i<length ; i++) { - Var *var2Ptr = LOCAL(duiPtr->varIndices[i]); - - while (TclIsVarLink(var2Ptr)) { - var2Ptr = var2Ptr->value.linkPtr; - } - if (TclIsVarDirectReadable(var2Ptr)) { - valuePtr = var2Ptr->value.objPtr; - } else { - valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, - duiPtr->varIndices[i]); - checkInterp = 1; - } - if (valuePtr == NULL) { - Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]); - } else if (dictPtr == valuePtr) { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], - Tcl_DuplicateObj(valuePtr)); - } else { - Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr); - } - } - if (TclIsVarDirectWritable(varPtr)) { - Tcl_IncrRefCount(dictPtr); - TclDecrRefCount(varPtr->value.objPtr); - varPtr->value.objPtr = dictPtr; - } else { - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); - checkInterp = 1; - if (objResultPtr == NULL) { - if (allocdict) { - TclDecrRefCount(dictPtr); - } - goto gotError; - } - } - NEXT_INST_F(9, 1, 0); - - case INST_DICT_EXPAND: - dictPtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; - } - objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); - if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - - case INST_DICT_RECOMBINE_STK: - keysPtr = POP_OBJECT(); - varNamePtr = OBJ_UNDER_TOS; - listPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", - O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - TclDecrRefCount(keysPtr); - goto gotError; - } - varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, - TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); - if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - TclDecrRefCount(keysPtr); - goto gotError; - } - result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1, - objc, objv, keysPtr); - TclDecrRefCount(keysPtr); - if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 2, 0); - - case INST_DICT_RECOMBINE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - listPtr = OBJ_UNDER_TOS; - keysPtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), - O2S(keysPtr))); - if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, - objc, objv, keysPtr); - if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } - TRACE_APPEND(("OK\n")); - NEXT_INST_F(5, 2, 0); - } - - /* - * End of dictionary-related instructions. - * ----------------------------------------------------------------- - */ - default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ @@ -6247,37 +2805,12 @@ TEBCresume( */ processExceptionReturn: -#if TCL_COMPILE_DEBUG - switch (*pc) { - case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); - break; - case INST_EVAL_STK: - /* - * Note that the object at stacktop has to be used before doing - * the cleanup. - */ - - TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - break; - default: - TRACE(("=> ")); - } -#endif if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { - TRACE_APPEND(("no encl. loop or catch, returning %s\n", - StringForResultCode(result))); goto abnormalReturn; } if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - TRACE_APPEND(("%s ...\n", StringForResultCode(result))); goto processCatch; } while (cleanup--) { @@ -6287,35 +2820,15 @@ TEBCresume( if (result == TCL_BREAK) { result = TCL_OK; pc = (codePtr->codeStart + rangePtr->breakOffset); - 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; } 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); } -#if TCL_COMPILE_DEBUG - if (traceInstructions) { - objPtr = Tcl_GetObjResult(interp); - if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", - result, O2S(objPtr))); - } else { - TRACE_APPEND(("%s, result= \"%s\"\n", - StringForResultCode(result), O2S(objPtr))); - } - } -#endif goto checkForCatch; /* @@ -6394,12 +2907,6 @@ TEBCresume( */ if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... cancel with unwind, returning %s\n", - StringForResultCode(result)); - } -#endif goto abnormalReturn; } @@ -6410,21 +2917,9 @@ TEBCresume( */ if (TclLimitExceeded(iPtr->limit)) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... limit exceeded, returning %s\n", - StringForResultCode(result)); - } -#endif goto abnormalReturn; } if (catchDepth == -1) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(result)); - } -#endif goto abnormalReturn; } rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); @@ -6435,12 +2930,6 @@ TEBCresume( * breaking compat with previous .tbc compiled scripts. */ -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(result)); - } -#endif goto abnormalReturn; } @@ -6457,14 +2946,6 @@ TEBCresume( valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchDepth=%d, " - "unwound to %ld, new pc %u\n", - rangePtr->codeOffset, (int) catchDepth, - PTR2INT(catchStack[catchDepth]), (unsigned) rangePtr->catchOffset); - } -#endif pc = (codePtr->codeStart + rangePtr->catchOffset); NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ @@ -6479,8 +2960,6 @@ TEBCresume( */ abnormalReturn: - TCL_DTRACE_INST_LAST(); - /* * Clear all expansions and same-level NR calls. * @@ -7881,141 +4360,6 @@ TclCompareTwoNumbers( } } -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * PrintByteCodeInfo -- - * - * This procedure prints a summary about a bytecode object to stdout. It - * is called by TclNRExecuteByteCode when starting to execute the bytecode - * object if tclTraceExec has the value 2 or more. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -PrintByteCodeInfo( - register ByteCode *codePtr) /* The bytecode whose summary is printed to - * stdout. */ -{ - Proc *procPtr = codePtr->procPtr; - Interp *iPtr = (Interp *) *codePtr->interpHandle; - - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, - iPtr->compileEpoch); - - fprintf(stdout, " Source: "); - TclPrintSource(stdout, codePtr->source, 60); - - fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - codePtr->numCommands, codePtr->numSrcBytes, - codePtr->numCodeBytes, codePtr->numLitObjects, - codePtr->numAuxDataItems, codePtr->maxStackDepth, -#ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - ((float)codePtr->structureSize)/codePtr->numSrcBytes : -#endif - 0.0); - -#ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)), - codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); -#endif /* TCL_COMPILE_STATS */ - if (procPtr != NULL) { - fprintf(stdout, - " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", - procPtr, procPtr->refCount, procPtr->numArgs, - procPtr->numCompiledLocals); - } -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * ValidatePcAndStackTop -- - * - * This procedure is called by TclNRExecuteByteCode when debugging to - * verify that the program counter and stack top are valid during - * execution. - * - * Results: - * None. - * - * Side effects: - * Prints a message to stderr and panics if either the pc or stack top - * are invalid. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_COMPILE_DEBUG -static void -ValidatePcAndStackTop( - register ByteCode *codePtr, /* The bytecode whose summary is printed to - * stdout. */ - const unsigned char *pc, /* Points to first byte of a bytecode - * instruction. The program counter. */ - 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. */ - unsigned relativePc = (unsigned) (pc - codePtr->codeStart); - unsigned long codeStart = (unsigned long) codePtr->codeStart; - unsigned long codeEnd = (unsigned long) - (codePtr->codeStart + codePtr->numCodeBytes); - unsigned char opCode = *pc; - - if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { - fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", - pc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); - } - if ((unsigned) opCode > LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n", - (unsigned) opCode, relativePc); - Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); - } - if (checkStack && - ((stackTop < 0) || (stackTop > stackUpperBound))) { - int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); - - fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", - stackTop, relativePc, stackUpperBound); - if (cmd != NULL) { - Tcl_Obj *message; - - TclNewLiteralStringObj(message, "\n executing "); - Tcl_IncrRefCount(message); - Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", Tcl_GetString(message)); - Tcl_DecrRefCount(message); - } else { - fprintf(stderr, "\n"); - } - Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top"); - } -} -#endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- @@ -8047,7 +4391,7 @@ IllegalExprOperandType( ClientData ptr; int type; const unsigned char opcode = *pc; - const char *description, *operator = operatorStrings[opcode - INST_LOR]; + const char *description, *operator = operatorStrings[opcode - INST_BITOR]; if (opcode == INST_EXPON) { operator = "**"; @@ -8295,36 +4639,6 @@ GetExceptRangeForPc( /* *---------------------------------------------------------------------- * - * GetOpcodeName -- - * - * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used - * in TclNRExecuteByteCode when debugging. It returns the name of the - * bytecode instruction at a specified instruction pc. - * - * Results: - * A character string for the instruction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_COMPILE_DEBUG -static const char * -GetOpcodeName( - const unsigned char *pc) /* Points to the instruction whose name should - * be returned. */ -{ - unsigned char opCode = *pc; - - return tclInstructionTable[opCode].name; -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * * TclExprFloatError -- * * This procedure is called when an error occurs during a floating-point @@ -8371,497 +4685,7 @@ TclExprFloatError( } } -#ifdef TCL_COMPILE_STATS -/* - *---------------------------------------------------------------------- - * - * TclLog2 -- - * - * Procedure used while collecting compilation statistics to determine - * the log base 2 of an integer. - * - * Results: - * Returns the log base 2 of the operand. If the argument is less than or - * equal to zero, a zero is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclLog2( - register int value) /* The integer for which to compute the log - * base 2. */ -{ - register int n = value; - register int result = 0; - - while (n > 1) { - n = n >> 1; - result++; - } - return result; -} -/* - *---------------------------------------------------------------------- - * - * EvalStatsCmd -- - * - * Implements the "evalstats" command that prints instruction execution - * counts to stdout. - * - * Results: - * Standard Tcl results. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -EvalStatsCmd( - ClientData unused, /* Unused. */ - Tcl_Interp *interp, /* The current interpreter. */ - int objc, /* The number of arguments. */ - Tcl_Obj *const objv[]) /* The argument strings. */ -{ - Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &iPtr->literalTable; - ByteCodeStats *statsPtr = &iPtr->stats; - double totalCodeBytes, currentCodeBytes; - double totalLiteralBytes, currentLiteralBytes; - double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; - double strBytesSharedMultX, strBytesSharedOnce; - double numInstructions, currentHeaderBytes; - long numCurrentByteCodes, numByteCodeLits; - long refCountSum, literalMgmtBytes, sum; - int numSharedMultX, numSharedOnce; - int decadeHigh, minSizeDecade, maxSizeDecade, length, i; - char *litTableStats; - LiteralEntry *entryPtr; - Tcl_Obj *objPtr; - -#define Percent(a,b) ((a) * 100.0 / (b)) - - objPtr = Tcl_NewObj(); - Tcl_IncrRefCount(objPtr); - - numInstructions = 0.0; - for (i = 0; i < 256; i++) { - if (statsPtr->instructionCount[i] != 0) { - numInstructions += statsPtr->instructionCount[i]; - } - } - - totalLiteralBytes = sizeof(LiteralTable) - + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) - + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) - + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) - + statsPtr->totalLitStringBytes; - totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; - - numCurrentByteCodes = - statsPtr->numCompilations - statsPtr->numByteCodesFreed; - currentHeaderBytes = numCurrentByteCodes - * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)); - literalMgmtBytes = sizeof(LiteralTable) - + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) - + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); - currentLiteralBytes = literalMgmtBytes - + iPtr->literalTable.numEntries * sizeof(Tcl_Obj) - + statsPtr->currentLitStringBytes; - currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; - - /* - * Summary statistics, total and current source and ByteCode sizes. - */ - - Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); - Tcl_AppendPrintfToObj(objPtr, - "Compilation and execution statistics for interpreter %#lx\n", - (long int)iPtr); - - Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n", - statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n", - statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", - statsPtr->numExecutions / (float)statsPtr->numCompilations); - - Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", - numInstructions); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", - numInstructions / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", - numInstructions / statsPtr->numExecutions); - - Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n", - statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", - statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", - totalCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", - statsPtr->totalByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", - totalLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)), - (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)), - statsPtr->totalLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", - totalCodeBytes / statsPtr->numCompilations); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", - totalCodeBytes / statsPtr->totalSrcBytes); - - Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n", - numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", - statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", - currentCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", - statsPtr->currentByteCodeBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", - currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), - statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", - currentCodeBytes / statsPtr->currentSrcBytes); - Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", - (currentCodeBytes + statsPtr->currentSrcBytes), - (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); - - /* - * Tcl_IsShared statistics check - * - * This gives the refcount of each obj as Tcl_IsShared was called for it. - * Shared objects must be duplicated before they can be modified. - */ - - numSharedMultX = 0; - Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); - Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n", - tclObjsShared[1]); - for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n", - i, tclObjsShared[i]); - numSharedMultX += tclObjsShared[i]; - } - Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n", - i, tclObjsShared[0]); - numSharedMultX += tclObjsShared[0]; - Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n", - numSharedMultX); - - /* - * Literal table statistics. - */ - - numByteCodeLits = 0; - refCountSum = 0; - numSharedMultX = 0; - numSharedOnce = 0; - objBytesIfUnshared = 0.0; - strBytesIfUnshared = 0.0; - strBytesSharedMultX = 0.0; - strBytesSharedOnce = 0.0; - for (i = 0; i < globalTablePtr->numBuckets; i++) { - for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; - entryPtr = entryPtr->nextPtr) { - if (entryPtr->objPtr->typePtr == &tclByteCodeType) { - numByteCodeLits++; - } - (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); - refCountSum += entryPtr->refCount; - objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); - strBytesIfUnshared += (entryPtr->refCount * (length+1)); - if (entryPtr->refCount > 1) { - numSharedMultX++; - strBytesSharedMultX += (length+1); - } else { - numSharedOnce++; - strBytesSharedOnce += (length+1); - } - } - } - sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - - currentLiteralBytes; - - Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n", - tclObjsAlloced); - Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n", - (tclObjsAlloced - tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n", - statsPtr->numLiteralsCreated); - - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", - globalTablePtr->numEntries, - Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", - numByteCodeLits, - Percent(numByteCodeLits, globalTablePtr->numEntries)); - Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n", - numSharedMultX); - Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", - ((double) refCountSum) / globalTablePtr->numEntries); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", - (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n", - (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); - Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", - sharingBytesSaved, - Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared)); - Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n", - currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), - statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", - (objBytesIfUnshared + strBytesIfUnshared), - objBytesIfUnshared, strBytesIfUnshared); - Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", - (strBytesIfUnshared - statsPtr->currentLitStringBytes), - strBytesIfUnshared, statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", - literalMgmtBytes, - Percent(literalMgmtBytes, currentLiteralBytes)); - Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry))); - - /* - * Breakdown of current ByteCode space requirements. - */ - - Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n"); - Tcl_AppendPrintfToObj(objPtr, " Bytes Pct of Avg per\n"); - Tcl_AppendPrintfToObj(objPtr, " total ByteCode\n"); - Tcl_AppendPrintfToObj(objPtr, "Total %12.6g 100.00%% %8.1f\n", - statsPtr->currentByteCodeBytes, - statsPtr->currentByteCodeBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n", - currentHeaderBytes, - Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes), - currentHeaderBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n", - statsPtr->currentInstBytes, - Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentInstBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n", - statsPtr->currentLitBytes, - Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentLitBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n", - statsPtr->currentExceptBytes, - Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentExceptBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n", - statsPtr->currentAuxBytes, - Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentAuxBytes / numCurrentByteCodes); - Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n", - statsPtr->currentCmdMapBytes, - Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes), - statsPtr->currentCmdMapBytes / numCurrentByteCodes); - - /* - * Detailed literal statistics. - */ - - Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); - maxSizeDecade = 0; - for (i = 31; i >= 0; i--) { - if (statsPtr->literalCount[i] > 0) { - maxSizeDecade = i; - break; - } - } - sum = 0; - for (i = 0; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->literalCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); - } - - litTableStats = TclLiteralStats(globalTablePtr); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", - litTableStats); - ckfree(litTableStats); - - /* - * Source and ByteCode size distributions. - */ - - Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); - minSizeDecade = maxSizeDecade = 0; - for (i = 0; i < 31; i++) { - if (statsPtr->srcCount[i] > 0) { - minSizeDecade = i; - break; - } - } - for (i = 31; i >= 0; i--) { - if (statsPtr->srcCount[i] > 0) { - maxSizeDecade = i; - break; - } - } - sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->srcCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numCompilations)); - } - - Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n"); - minSizeDecade = maxSizeDecade = 0; - for (i = 0; i < 31; i++) { - if (statsPtr->byteCodeCount[i] > 0) { - minSizeDecade = i; - break; - } - } - for (i = 31; i >= 0; i--) { - if (statsPtr->byteCodeCount[i] > 0) { - maxSizeDecade = i; - break; - } - } - sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->byteCodeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", - decadeHigh, Percent(sum, statsPtr->numCompilations)); - } - - Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n"); - Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n"); - minSizeDecade = maxSizeDecade = 0; - for (i = 0; i < 31; i++) { - if (statsPtr->lifetimeCount[i] > 0) { - minSizeDecade = i; - break; - } - } - for (i = 31; i >= 0; i--) { - if (statsPtr->lifetimeCount[i] > 0) { - maxSizeDecade = i; - break; - } - } - sum = 0; - for (i = minSizeDecade; i <= maxSizeDecade; i++) { - decadeHigh = (1 << (i+1)) - 1; - sum += statsPtr->lifetimeCount[i]; - Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", - decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); - } - - /* - * Instruction counts. - */ - - Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); - for (i = 0; i <= LAST_INST_OPCODE; i++) { - Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", - tclInstructionTable[i].name, statsPtr->instructionCount[i]); - if (statsPtr->instructionCount[i]) { - Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", - Percent(statsPtr->instructionCount[i], numInstructions)); - } else { - Tcl_AppendPrintfToObj(objPtr, "0\n"); - } - } - -#ifdef TCL_MEM_DEBUG - Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); - TclDumpMemoryInfo((ClientData) objPtr, 1); -#endif - Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); - - if (objc == 1) { - Tcl_SetObjResult(interp, objPtr); - } else { - Tcl_Channel outChan; - char *str = Tcl_GetStringFromObj(objv[1], &length); - - if (length) { - if (strcmp(str, "stdout") == 0) { - outChan = Tcl_GetStdChannel(TCL_STDOUT); - } else if (strcmp(str, "stderr") == 0) { - outChan = Tcl_GetStdChannel(TCL_STDERR); - } else { - outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664); - } - } else { - outChan = Tcl_GetStdChannel(TCL_STDOUT); - } - if (outChan != NULL) { - Tcl_WriteObj(outChan, objPtr); - } - } - Tcl_DecrRefCount(objPtr); - return TCL_OK; -} -#endif /* TCL_COMPILE_STATS */ - -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * StringForResultCode -- - * - * Procedure that returns a human-readable string representing a Tcl - * result code such as TCL_ERROR. - * - * Results: - * If the result code is one of the standard Tcl return codes, the result - * is a string representing that code such as "TCL_ERROR". Otherwise, the - * result string is that code formatted as a sequence of decimal digit - * characters. Note that the resulting string must not be modified by the - * caller. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static const char * -StringForResultCode( - int result) /* The Tcl result code for which to generate a - * string. */ -{ - static char buf[TCL_INTEGER_SPACE]; - - if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { - return resultStrings[result]; - } - TclFormatInt(buf, result); - return buf; -} -#endif /* TCL_COMPILE_DEBUG */ /* * Local Variables: |