diff options
Diffstat (limited to 'generic/tclExecute.c')
| -rw-r--r-- | generic/tclExecute.c | 4351 |
1 files changed, 2991 insertions, 1360 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6a4b495..4ecca5b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6,19 +6,18 @@ * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. - * Copyright (c) 2002-2008 by Miguel Sofer. + * Copyright (c) 2002-2010 by Miguel Sofer. * Copyright (c) 2005-2007 by Donal K. Fellows. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclExecute.c,v 1.494 2010/09/01 20:35:33 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include "tclOOInt.h" #include "tommath.h" #include <math.h> @@ -55,6 +54,8 @@ static int execInitialized = 0; TCL_DECLARE_MUTEX(execMutex) +static int cachedInExit = 0; + #ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether execution tracing is enabled and, if so, @@ -170,53 +171,44 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { * Minimal data required to fully reconstruct the execution state. */ -typedef struct BottomData { - struct BottomData *prevBottomPtr; - TEOV_callback *rootPtr; /* State when this bytecode execution - * began: */ - ByteCode *codePtr; /* constant until it returns */ +typedef struct TEBCdata { + ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ - const unsigned char *pc; /* These fields are used on return TO this */ - ptrdiff_t *catchTop; /* this level: they record the state when a */ - int cleanup; /* new codePtr was received for NR */ - Tcl_Obj *auxObjList; /* execution. */ -} BottomData; - -#define NR_DATA_INIT() \ - do { \ - BP->prevBottomPtr = OBP; \ - BP->rootPtr = TOP_CB(iPtr); \ - BP->codePtr = codePtr; \ - } while (0) - -#define NR_DATA_BURY() \ - do { \ - BP->pc = pc; \ - BP->cleanup = cleanup; \ - OBP = BP; \ + ptrdiff_t *catchTop; /* These fields are used on return TO this */ + Tcl_Obj *auxObjList; /* this level: they record the state when a */ + CmdFrame cmdFrame; /* new codePtr was received for NR */ + /* execution. */ + void *stack[1]; /* Start of the actual combined catch and obj + * stacks; the struct will be expanded as + * necessary */ +} TEBCdata; + +#define TEBC_YIELD() \ + do { \ + esPtr->tosPtr = tosPtr; \ + TclNRAddCallback(interp, TEBCresume, \ + TD, pc, INT2PTR(cleanup), NULL); \ } while (0) -#define NR_DATA_DIG() \ - do { \ - pc = BP->pc; \ - codePtr = BP->codePtr; \ - cleanup = BP->cleanup; \ - TAUX.esPtr = iPtr->execEnvPtr->execStackPtr; \ - tosPtr = TAUX.esPtr->tosPtr; \ - TAUX.compiledLocals = iPtr->varFramePtr->compiledLocals;\ +#define TEBC_DATA_DIG() \ + do { \ + tosPtr = esPtr->tosPtr; \ } while (0) #define PUSH_TAUX_OBJ(objPtr) \ do { \ - objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \ + if (auxObjList) { \ + objPtr->length += auxObjList->length; \ + } \ + objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ auxObjList = objPtr; \ } while (0) #define POP_TAUX_OBJ() \ - do { \ - tmpPtr = auxObjList; \ - auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2; \ - Tcl_DecrRefCount(tmpPtr); \ + do { \ + tmpPtr = auxObjList; \ + auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr; \ + Tcl_DecrRefCount(tmpPtr); \ } while (0) /* @@ -257,13 +249,27 @@ VarHashCreateVar( * otherwise, push objResultPtr. If (result < 0), objResultPtr already * has the correct reference count. * - * We use the new compile-time assertions to cheack that nCleanup is constant + * We use the new compile-time assertions to check that nCleanup is constant * and within range. */ -#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ +/* Verify the stack depth, only when no expansion is in progress */ + +#ifdef TCL_COMPILE_DEBUG +#define CHECK_STACK() \ + do { \ + ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ + /*checkStack*/ !(starting || auxObjList)); \ + starting = 0; \ + } while (0) +#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) { \ @@ -282,17 +288,20 @@ VarHashCreateVar( switch (nCleanup) { \ case 1: goto cleanup1_pushObjResultPtr; \ case 2: goto cleanup2_pushObjResultPtr; \ + case 0: break; \ } \ } else { \ pc += (pcAdjustment); \ switch (nCleanup) { \ case 1: goto cleanup1; \ case 2: goto cleanup2; \ + case 0: break; \ } \ } \ } while (0) -#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ +#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ + CHECK_STACK(); \ do { \ pc += (pcAdjustment); \ cleanup = (nCleanup); \ @@ -306,22 +315,83 @@ VarHashCreateVar( } \ } while (0) +#ifndef TCL_COMPILE_DEBUG +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE1: \ + NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F(0, (cleanup), 1); \ + } \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE1: \ + NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V(0, (cleanup), 1); \ + } \ + } while (0) +#else /* TCL_COMPILE_DEBUG */ +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do{ \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F((pcAdjustment), (cleanup), 1); \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do{ \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V((pcAdjustment), (cleanup), 1); \ + } while (0) +#endif + /* * Macros used to cache often-referenced Tcl evaluation stack information * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() - * pair must surround any call inside TclExecuteByteCode (and a few other + * pair must surround any call inside TclNRExecuteByteCode (and a few other * procedures that use this scheme) that could result in a recursive call - * to TclExecuteByteCode. + * to TclNRExecuteByteCode. */ #define CACHE_STACK_INFO() \ - TAUX.checkInterp = 1 + checkInterp = 1 #define DECACHE_STACK_INFO() \ - do { \ - TAUX.esPtr->tosPtr = tosPtr; \ - iPtr->execEnvPtr->bottomPtr = BP; \ - } while (0) + esPtr->tosPtr = tosPtr /* * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT @@ -349,17 +419,19 @@ VarHashCreateVar( #define OBJ_AT_DEPTH(n) *(tosPtr-(n)) -#define CURR_DEPTH (tosPtr - initTosPtr) +#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) + +#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) /* * Macros used to trace instruction execution. The macros TRACE, - * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is + * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is * only used in TRACE* calls to get a string from an object. */ #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ - while (TAUX.traceInstructions) { \ + while (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (unsigned) (pc - codePtr->codeStart), \ @@ -368,12 +440,14 @@ VarHashCreateVar( break; \ } # define TRACE_APPEND(a) \ - while (TAUX.traceInstructions) { \ + while (traceInstructions) { \ printf a; \ break; \ } +# define TRACE_ERROR(interp) \ + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ - while (TAUX.traceInstructions) { \ + while (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ (int) CURR_DEPTH, \ (unsigned) (pc - codePtr->codeStart), \ @@ -388,6 +462,7 @@ VarHashCreateVar( #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) # define TRACE_APPEND(a) +# define TRACE_ERROR(interp) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ @@ -399,13 +474,13 @@ VarHashCreateVar( #define TCL_DTRACE_INST_NEXT() \ do { \ if (TCL_DTRACE_INST_DONE_ENABLED()) { \ - if (TAUX.curInstName) { \ - TCL_DTRACE_INST_DONE(TAUX.curInstName, (int) CURR_DEPTH, \ + if (curInstName) { \ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \ tosPtr); \ } \ - TAUX.curInstName = tclInstructionTable[*pc].name; \ + curInstName = tclInstructionTable[*pc].name; \ if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(TAUX.curInstName, (int) CURR_DEPTH, \ + TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \ tosPtr); \ } \ } else if (TCL_DTRACE_INST_START_ENABLED()) { \ @@ -415,8 +490,8 @@ VarHashCreateVar( } while (0) #define TCL_DTRACE_INST_LAST() \ do { \ - if (TCL_DTRACE_INST_DONE_ENABLED() && TAUX.curInstName) { \ - TCL_DTRACE_INST_DONE(TAUX.curInstName, (int) CURR_DEPTH, tosPtr);\ + if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ + TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\ } \ } while (0) @@ -428,7 +503,7 @@ VarHashCreateVar( * ClientData *ptrPtr, int *tPtr); */ -#ifdef NO_WIDE_TYPE +#ifdef TCL_WIDE_INT_IS_LONG #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ @@ -442,9 +517,9 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#else /* !NO_WIDE_TYPE */ +#else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ @@ -462,9 +537,9 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#endif /* NO_WIDE_TYPE */ +#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used in this file to save a function call for common uses of @@ -488,13 +563,13 @@ VarHashCreateVar( * Tcl_WideInt *wideIntPtr); */ -#ifdef NO_WIDE_TYPE +#ifdef TCL_WIDE_INT_IS_LONG #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !NO_WIDE_TYPE */ +#else /* !TCL_WIDE_INT_IS_LONG */ #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclWideIntType) \ ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ @@ -502,7 +577,7 @@ VarHashCreateVar( ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.longValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#endif /* NO_WIDE_TYPE */ +#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used to make the check for type overflow more mnemonic. This works by @@ -527,16 +602,6 @@ VarHashCreateVar( #else #define IsErroringNaNType(type) 0 #endif - -/* - * 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", - NULL, NULL, NULL, NULL -}; /* * Auxiliary tables used to compute powers of small integers. @@ -704,7 +769,7 @@ static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, const unsigned char *pc, int stackTop, - int stackLowerBound, int checkStack); + int checkStack); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); @@ -721,18 +786,23 @@ static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, - ByteCode *codePtr, int *lengthPtr); + ByteCode *codePtr, int *lengthPtr, + const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); -static inline int OFFSET(void *ptr); +static inline int wordSkip(void *ptr); +static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; +static Tcl_NRPostProc FinalizeOONext; +static Tcl_NRPostProc FinalizeOONextFilter; +static Tcl_NRPostProc TEBCresume; /* * The structure below defines a bytecode Tcl object type to hold the @@ -746,6 +816,56 @@ static const Tcl_ObjType exprCodeType = { NULL, /* updateStringProc */ 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; +} /* *---------------------------------------------------------------------- @@ -793,7 +913,7 @@ InitByteCodeExecution( * This procedure creates a new execution environment for Tcl bytecode * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is * typically created once for each Tcl interpreter (Interp structure) and - * recursively passed to TclExecuteByteCode to execute ByteCode sequences + * recursively passed to TclNRExecuteByteCode to execute ByteCode sequences * for nested commands. * * Results: @@ -802,7 +922,7 @@ InitByteCodeExecution( * * Side effects: * The bytecode interpreter is also initialized here, as this procedure - * will be called before any call to TclExecuteByteCode. + * will be called before any call to TclNRExecuteByteCode. * *---------------------------------------------------------------------- */ @@ -814,8 +934,8 @@ TclCreateExecEnv( int size) /* The initial stack size, in number of words * [sizeof(Tcl_Obj*)] */ { - ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); - ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack) + ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); + ExecStack *esPtr = ckalloc(sizeof(ExecStack) + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; @@ -826,14 +946,13 @@ TclCreateExecEnv( eePtr->interp = interp; eePtr->callbackPtr = NULL; eePtr->corPtr = NULL; - eePtr->bottomPtr = NULL; eePtr->rewind = 0; esPtr->prevPtr = NULL; esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -867,7 +986,7 @@ static void DeleteExecStack( ExecStack *esPtr) { - if (esPtr->markerPtr) { + if (esPtr->markerPtr && !cachedInExit) { Tcl_Panic("freeing an execStack which is still in use"); } @@ -877,7 +996,7 @@ DeleteExecStack( if (esPtr->nextPtr) { esPtr->nextPtr->prevPtr = esPtr->prevPtr; } - ckfree((char *) esPtr); + ckfree(esPtr); } void @@ -886,6 +1005,8 @@ TclDeleteExecEnv( { ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; + cachedInExit = TclInExit(); + /* * Delete all stacks in this exec env. */ @@ -901,13 +1022,13 @@ TclDeleteExecEnv( TclDecrRefCount(eePtr->constants[0]); TclDecrRefCount(eePtr->constants[1]); - if (eePtr->callbackPtr) { + if (eePtr->callbackPtr && !cachedInExit) { Tcl_Panic("Deleting execEnv with pending TEOV callbacks!"); } - if (eePtr->corPtr) { + if (eePtr->corPtr && !cachedInExit) { Tcl_Panic("Deleting execEnv with existing coroutine"); } - ckfree((char *) eePtr); + ckfree(eePtr); } /* @@ -950,13 +1071,13 @@ TclFinalizeExecution(void) (TCL_ALLOCALIGN/sizeof(Tcl_Obj *)) /* - * OFFSET computes how many words have to be skipped until the next aligned + * wordSkip computes how many words have to be skipped until the next aligned * word. Note that we are only interested in the low order bits of ptr, so * that any possible information loss in PTR2INT is of no consequence. */ static inline int -OFFSET( +wordSkip( void *ptr) { int mask = TCL_ALLOCALIGN-1; @@ -969,7 +1090,7 @@ OFFSET( */ #define MEMSTART(markerPtr) \ - ((markerPtr) + OFFSET(markerPtr)) + ((markerPtr) + wordSkip(markerPtr)) /* *---------------------------------------------------------------------- @@ -1012,8 +1133,9 @@ GrowEvaluationStack( return MEMSTART(markerPtr); } } else { +#ifndef PURIFY Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; - int offset = OFFSET(tmpMarkerPtr); + int offset = wordSkip(tmpMarkerPtr); if (needed + offset < 0) { /* @@ -1028,19 +1150,21 @@ GrowEvaluationStack( *esPtr->markerPtr = (Tcl_Obj *) markerPtr; return memStart; } +#endif } /* * Reset move to hold the number of words to be moved to new stack (if - * any) and growth to hold the complete stack requirements: add the marker - * and maximal possible offset. + * any) and growth to hold the complete stack requirements: add one for + * the marker, (WALLOCALIGN-1) for the maximal possible offset. */ if (move) { moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1; } - needed = growth + moveWords + WALLOCALIGN - 1; + needed = growth + moveWords + WALLOCALIGN; + /* * Check if there is enough room in the next stack (if there is one, it * should be both empty and the last one!) @@ -1049,8 +1173,8 @@ GrowEvaluationStack( if (esPtr->nextPtr) { oldPtr = esPtr; esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { + currElems = esPtr->endPtr - STACK_BASE(esPtr); + if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) { Tcl_Panic("STACK: Stack after current is in use"); } if (esPtr->nextPtr) { @@ -1062,7 +1186,7 @@ GrowEvaluationStack( DeleteExecStack(esPtr); esPtr = oldPtr; } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; + currElems = esPtr->endPtr - STACK_BASE(esPtr); } /* @@ -1070,14 +1194,19 @@ GrowEvaluationStack( * including the elements to be copied over and the new marker. */ +#ifndef PURIFY newElems = 2*currElems; while (needed > newElems) { newElems *= 2; } +#else + newElems = needed; +#endif + newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); oldPtr = esPtr; - esPtr = (ExecStack *) ckalloc(newBytes); + esPtr = ckalloc(newBytes); oldPtr->nextPtr = esPtr; esPtr->prevPtr = oldPtr; @@ -1176,7 +1305,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - Tcl_Free((char *) freePtr); + ckfree((char *) freePtr); return; } @@ -1203,18 +1332,31 @@ TclStackFree( } /* - * Return to previous stack. + * Return to previous active stack. Note that repeated expansions or + * reallocs could have generated several unused intervening stacks: free + * them too. */ - esPtr->tosPtr = &esPtr->stackWords[-1]; - if (esPtr->prevPtr) { - eePtr->execStackPtr = esPtr->prevPtr; + while (esPtr->nextPtr) { + esPtr = esPtr->nextPtr; } - if (esPtr->nextPtr) { - if (!esPtr->prevPtr) { - eePtr->execStackPtr = esPtr->nextPtr; + esPtr->tosPtr = STACK_BASE(esPtr); + while (esPtr->prevPtr) { + ExecStack *tmpPtr = esPtr->prevPtr; + if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) { + DeleteExecStack(tmpPtr); + } else { + break; } + } + if (esPtr->prevPtr) { + eePtr->execStackPtr = esPtr->prevPtr; +#ifdef PURIFY + eePtr->execStackPtr->nextPtr = NULL; DeleteExecStack(esPtr); +#endif + } else { + eePtr->execStackPtr = esPtr; } } @@ -1227,7 +1369,7 @@ TclStackAlloc( int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) Tcl_Alloc(numBytes); + return (void *) ckalloc(numBytes); } return (void *) StackAllocWords(interp, numWords); @@ -1246,7 +1388,7 @@ TclStackRealloc( int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) Tcl_Realloc((char *) ptr, numBytes); + return (void *) ckrealloc((char *) ptr, numBytes); } eePtr = iPtr->execEnvPtr; @@ -1293,14 +1435,14 @@ Tcl_ExprObj( Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression * result is stored if no errors occur. */ { - TEOV_callback *rootPtr = TOP_CB(interp); + NRE_callback *rootPtr = TOP_CB(interp); Tcl_Obj *resultPtr; TclNewObj(resultPtr); TclNRAddCallback(interp, CopyCallback, resultPtrPtr, resultPtr, NULL, NULL); Tcl_NRExprObj(interp, objPtr, resultPtr); - return TclNRRunCallbacks(interp, TCL_OK, rootPtr, 0); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } static int @@ -1351,21 +1493,14 @@ Tcl_NRExprObj( Tcl_Obj *resultPtr) { ByteCode *codePtr; + Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); - /* TODO: consider saving whole state? */ - Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); - - Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); codePtr = CompileExprObj(interp, objPtr); - /* TODO: Confirm reset not required? */ - /*Tcl_ResetResult(interp);*/ - Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr, + Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, NULL, NULL); - Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, - NULL, NULL); - return TCL_OK; + return TclNRExecuteByteCode(interp, codePtr); } static int @@ -1374,15 +1509,15 @@ ExprObjCallback( Tcl_Interp *interp, int result) { - Tcl_Obj *saveObjPtr = data[0]; + Tcl_InterpState state = data[0]; Tcl_Obj *resultPtr = data[1]; if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_IncrRefCount(resultPtr); - Tcl_SetObjResult(interp, saveObjPtr); + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); } - TclDecrRefCount(saveObjPtr); return result; } @@ -1425,7 +1560,7 @@ CompileExprObj( if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1465,7 +1600,7 @@ CompileExprObj( TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1537,14 +1672,13 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + objPtr->typePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; } /* @@ -1552,13 +1686,13 @@ FreeExprCodeInternalRep( * * TclCompileObj -- * - * This procedure compiles the script contained in a Tcl_Obj + * This procedure compiles the script contained in a Tcl_Obj. * * Results: * A pointer to the corresponding ByteCode, never NULL. * * Side effects: - * The object is shimmered to bytecode type + * The object is shimmered to bytecode type. * *---------------------------------------------------------------------- */ @@ -1598,30 +1732,29 @@ TclCompileObj( * here. */ - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - Tcl_Panic("Tcl_EvalObj: compiled script jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { + 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; } - if (codePtr->procPtr == NULL) { - /* - * Check that any compiled locals do refer to the current proc - * environment! If not, recompile. - */ + /* + * Check that any compiled locals do refer to the current proc + * environment! If not, recompile. + */ - if (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr) { - goto recompileObj; - } + if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) && + (codePtr->procPtr == NULL) && + (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){ + goto recompileObj; } /* @@ -1653,70 +1786,64 @@ TclCompileObj( * information. */ - { + if (invoker == NULL) { + return codePtr; + } else { Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + ExtCmdLoc *eclPtr; + CmdFrame *ctxCopyPtr; + int redo; - if (hePtr) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); - int redo = 0; - - if (invoker) { - CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); - *ctxPtr = *invoker; + if (!hePtr) { + return codePtr; + } - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr used instead - */ + eclPtr = Tcl_GetHashValue(hePtr); + redo = 0; + ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxCopyPtr = *invoker; - TclGetSrcInfoForPc(ctxPtr); - if (ctxPtr->type == TCL_LOCATION_SOURCE) { - /* - * The reference made by 'TclGetSrcInfoForPc' is - * dead. - */ + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead + */ - Tcl_DecrRefCount(ctxPtr->data.eval.path); - ctxPtr->data.eval.path = NULL; - } - } + TclGetSrcInfoForPc(ctxCopyPtr); + if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) { + /* + * The reference made by 'TclGetSrcInfoForPc' is dead. + */ - if (word < ctxPtr->nline) { - /* - * Note: We do not care if the line[word] is -1. This - * is a difference and requires a recompile (location - * changed from absolute to relative, literal is used - * fixed and through variable) - * - * Example: - * test info-32.0 using literal of info-24.8 - * (dict with ... vs set body ...). - */ + Tcl_DecrRefCount(ctxCopyPtr->data.eval.path); + ctxCopyPtr->data.eval.path = NULL; + } + } - redo = ((eclPtr->type == TCL_LOCATION_SOURCE) - && (eclPtr->start != ctxPtr->line[word])) - || ((eclPtr->type == TCL_LOCATION_BC) - && (ctxPtr->type == TCL_LOCATION_SOURCE)); - } + if (word < ctxCopyPtr->nline) { + /* + * Note: We do not care if the line[word] is -1. This is a + * difference and requires a recompile (location changed from + * absolute to relative, literal is used fixed and through + * variable) + * + * Example: + * test info-32.0 using literal of info-24.8 + * (dict with ... vs set body ...). + */ - TclStackFree(interp, ctxPtr); - } + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxCopyPtr->line[word])) + || ((eclPtr->type == TCL_LOCATION_BC) + && (ctxCopyPtr->type == TCL_LOCATION_SOURCE)); + } - if (redo) { - goto recompileObj; - } + TclStackFree(interp, ctxCopyPtr); + if (!redo) { + return codePtr; } } - - /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. - */ - - runCompiledObj: - return codePtr; } recompileObj: @@ -1731,14 +1858,14 @@ TclCompileObj( iPtr->invokeCmdFramePtr = invoker; iPtr->invokeWord = word; - tclByteCodeType.setFromAnyProc(interp, objPtr); + TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } - goto runCompiledObj; + return codePtr; } /* @@ -1807,7 +1934,7 @@ TclIncrObj( TclSetLongObj(valuePtr, sum); return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG { Tcl_WideInt w1 = (Tcl_WideInt) augend; Tcl_WideInt w2 = (Tcl_WideInt) addend; @@ -1840,7 +1967,7 @@ TclIncrObj( return TCL_ERROR; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; @@ -1870,7 +1997,42 @@ TclIncrObj( /* *---------------------------------------------------------------------- * - * TclExecuteByteCode -- + * ArgumentBCEnter -- + * + * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates + * a code sequence that is fairly common in the code but *not* commonly + * called. + * + * Results: + * None + * + * Side effects: + * May register information about the bytecode in the command frame. + * + *---------------------------------------------------------------------- + */ + +static void +ArgumentBCEnter( + Tcl_Interp *interp, + ByteCode *codePtr, + TEBCdata *tdPtr, + const unsigned char *pc, + int objc, + Tcl_Obj **objv) +{ + int cmd; + + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, + pc - codePtr->codeStart); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclNRExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It * returns when a "done" instruction is executed or an error occurs. @@ -1885,12 +2047,82 @@ TclIncrObj( * *---------------------------------------------------------------------- */ +#define bcFramePtr (&TD->cmdFrame) +#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1])) +#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) +#define esPtr (iPtr->execEnvPtr->execStackPtr) int -TclExecuteByteCode( +TclNRExecuteByteCode( Tcl_Interp *interp, /* Token for command interpreter. */ ByteCode *codePtr) /* The bytecode sequence to interpret. */ { + Interp *iPtr = (Interp *) interp; + TEBCdata *TD; + int size = sizeof(TEBCdata) - 1 + + (codePtr->maxStackDepth + codePtr->maxExceptDepth) + * sizeof(void *); + int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); + + codePtr->refCount++; + + /* + * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame + * + * The execution uses a unified stack: first a TEBCdata, immediately + * above it a CmdFrame, then the catch stack, then the execution stack. + * + * Make sure the catch stack is large enough to hold the maximum number of + * catch commands that could ever be executing at the same time (this will + * be no more than the exception range array's depth). Make sure the + * execution stack is large enough to execute this ByteCode. + */ + + TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); + esPtr->tosPtr = initTosPtr; + + TD->codePtr = codePtr; + TD->catchTop = initCatchTop; + TD->auxObjList = NULL; + + /* + * TIP #280: Initialize the frame. Do not push it yet: it will be pushed + * every time that we call out from this TD, popped when we return to it. + */ + + bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) + ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); + bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); + bcFramePtr->framePtr = iPtr->framePtr; + bcFramePtr->nextPtr = iPtr->cmdFramePtr; + bcFramePtr->nline = 0; + bcFramePtr->line = NULL; + bcFramePtr->litarg = NULL; + bcFramePtr->data.tebc.codePtr = codePtr; + bcFramePtr->data.tebc.pc = NULL; + bcFramePtr->cmdObj = NULL; + bcFramePtr->cmd = NULL; + bcFramePtr->len = 0; + +#ifdef TCL_COMPILE_STATS + iPtr->stats.numExecutions++; +#endif + + /* + * Push the callback for bytecode execution + */ + + TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, + /* cleanup */ INT2PTR(0), NULL); + return TCL_OK; +} + +static int +TEBCresume( + ClientData data[], + Tcl_Interp *interp, + int result) +{ /* * Compiler cast directive - not a real variable. * Interp *iPtr = (Interp *) interp; @@ -1908,77 +2140,55 @@ TclExecuteByteCode( /* * Bottom of allocated stack holds the NR data */ - /* NR_TEBC */ /* * Constants: variables that do not change during the execution, used * sporadically: no special need for speed. */ - struct auxTEBCdata { - ExecStack *esPtr; - Var *compiledLocals; - BottomData *bottomPtr; /* Bottom of stack holds NR data */ - BottomData *oldBottomPtr; - Tcl_Obj **constants; - int instructionCount; /* Counter that is used to work out when to + int instructionCount = 0; /* Counter that is used to work out when to * call Tcl_AsyncReady() */ - int checkInterp; /* Indicates when a check of interp readyness - * is necessary. Set by CACHE_STACK_INFO() */ - const char *curInstName; - int result; /* Return code returned after execution. - * Result variable - needed only when going to - * checkForCatch or other error handlers; also - * used as local in some opcodes. */ + const char *curInstName; #ifdef TCL_COMPILE_DEBUG - int traceInstructions; /* Whether we are doing instruction-level + int traceInstructions; /* Whether we are doing instruction-level * tracing or not. */ #endif - } TAUX = { - NULL, - NULL, - NULL, - NULL, - NULL, - 0, - 0, - NULL, - TCL_OK - }; - -#define LOCAL(i) (&(TAUX.compiledLocals[(i)])) -#define TCONST(i) (TAUX.constants[(i)]) -#define BP (TAUX.bottomPtr) -#define OBP (TAUX.oldBottomPtr) -#define TRESULT (TAUX.result) + + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0]; + +#define LOCAL(i) (&compiledLocals[(i)]) +#define TCONST(i) (constants[(i)]) /* * These macros are just meant to save some global variables that are not * used too frequently */ -#define bcFramePtr ((CmdFrame *) (BP + 1)) -#define initCatchTop (((ptrdiff_t *) (bcFramePtr + 1)) - 1) -#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth)) -#define auxObjList (BP->auxObjList) -#define catchTop (BP->catchTop) + TEBCdata *TD = data[0]; +#define auxObjList (TD->auxObjList) +#define catchTop (TD->catchTop) +#define codePtr (TD->codePtr) /* * Globals: variables that store state, must remain valid at all times. */ - Tcl_Obj **tosPtr = NULL; /* Cached pointer to top of evaluation + Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation * stack. */ - const unsigned char *pc = NULL; - /* The current program counter. */ - + const unsigned char *pc = data[1]; + /* The current program counter. */ + unsigned char inst; /* The currently running instruction */ + /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. */ - int cleanup = 0; + int cleanup = PTR2INT(data[2]); Tcl_Obj *objResultPtr; + int checkInterp; /* Indicates when a check of interp readyness + * is necessary. Set by CACHE_STACK_INFO() */ /* * Locals - variables that are used within opcodes or bounded sections of @@ -1988,133 +2198,92 @@ TclExecuteByteCode( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv; - int opnd, objc, length, pcAdjustment; + int objc = 0; + int opnd, length, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; #endif - TAUX.constants = &iPtr->execEnvPtr->constants[0]; - if (!codePtr) { - CoroutineData *corPtr; - - resumeCoroutine: - /* - * Reawakening a suspended coroutine: the [yield] command is - * returning: - * - monkey-patch the cmdFrame chain - * - set the running level of the coroutine - * - monkey-patch the BP chain - * - restart the code at [yield]'s return - */ - - corPtr = iPtr->execEnvPtr->corPtr; - - NRE_ASSERT(corPtr != NULL); - NRE_ASSERT(corPtr->eePtr == iPtr->execEnvPtr); - NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); - - if (iPtr->execEnvPtr->rewind) { - TRESULT = TCL_ERROR; - } - - corPtr->base.cmdFramePtr->nextPtr = corPtr->caller.cmdFramePtr; - corPtr->stackLevel = &TAUX; - *corPtr->callerBPPtr = OBP; - OBP = iPtr->execEnvPtr->bottomPtr; - goto returnToCaller; - } - - /* - * The execution uses a unified stack: first a BottomData, immediately - * above it a CmdFrame, then the catch stack, then the execution stack. - * - * Make sure the catch stack is large enough to hold the maximum number of - * catch commands that could ever be executing at the same time (this will - * be no more than the exception range array's depth). Make sure the - * execution stack is large enough to execute this ByteCode. - */ - - nonRecursiveCallStart: #ifdef TCL_COMPILE_DEBUG - TAUX.traceInstructions = (tclTraceExec == 3); + int starting = 1; + traceInstructions = (tclTraceExec == 3); #endif - codePtr->refCount++; - BP = (BottomData *) GrowEvaluationStack(iPtr->execEnvPtr, - sizeof(BottomData) + codePtr->maxExceptDepth + sizeof(CmdFrame) - + codePtr->maxStackDepth, 0); - TAUX.curInstName = NULL; - auxObjList = NULL; - NR_DATA_INIT(); /* record this level's data */ - - iPtr->execEnvPtr->bottomPtr = BP; - TAUX.esPtr = iPtr->execEnvPtr->execStackPtr; - TAUX.compiledLocals = iPtr->varFramePtr->compiledLocals; - - pc = codePtr->codeStart; - catchTop = initCatchTop; - tosPtr = initTosPtr; - - /* - * TIP #280: Initialize the frame. Do not push it yet: it will be pushed - * every time that we call out from this BP, popped when we return to it. - */ - - bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) - ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); - bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); - bcFramePtr->numLevels = iPtr->numLevels; - bcFramePtr->framePtr = iPtr->framePtr; - bcFramePtr->nextPtr = iPtr->cmdFramePtr; - bcFramePtr->nline = 0; - bcFramePtr->line = NULL; - bcFramePtr->litarg = NULL; - bcFramePtr->data.tebc.codePtr = codePtr; - bcFramePtr->data.tebc.pc = NULL; - bcFramePtr->cmd.str.cmd = NULL; - bcFramePtr->cmd.str.len = 0; - - if (iPtr->execEnvPtr->corPtr) { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (!corPtr->base.cmdFramePtr) { - /* - * First coroutine run, incomplete init: - * - base.cmdFramePtr not set - * - need to monkey-patch the BP chain - * - set the running level for the coroutine - */ - - corPtr->base.cmdFramePtr = bcFramePtr; - corPtr->callerBPPtr = &BP->prevBottomPtr; - corPtr->stackLevel = &TAUX; - } - - if (iPtr->execEnvPtr->rewind) { - TRESULT = TCL_ERROR; - goto abnormalReturn; - } - } + TEBC_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (!pc && (tclTraceExec >= 2)) { PrintByteCodeInfo(codePtr); fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); fflush(stdout); } #endif -#ifdef TCL_COMPILE_STATS - iPtr->stats.numExecutions++; -#endif + if (!pc) { + /* bytecode is starting from scratch */ + checkInterp = 0; + pc = codePtr->codeStart; + goto cleanup0; + } else { + /* resume from invocation */ + CACHE_STACK_INFO(); + if (iPtr->execEnvPtr->rewind) { + result = TCL_ERROR; + goto abnormalReturn; + } - /* - * Loop executing instructions until a "done" instruction, a TCL_RETURN, - * or some error. - */ + NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); + if (bcFramePtr->cmdObj) { + Tcl_DecrRefCount(bcFramePtr->cmdObj); + bcFramePtr->cmdObj = NULL; + bcFramePtr->cmd = NULL; + } + iPtr->cmdFramePtr = bcFramePtr->nextPtr; + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCRelease(interp, bcFramePtr); + } + if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { + iPtr->flags |= ERR_ALREADY_LOGGED; + codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; + } - goto cleanup0; + if (result != TCL_OK) { + pc--; + goto processExceptionReturn; + } + + /* + * 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)); + + /* + * Reset the interp's result to avoid possible duplications of large + * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any + * side effects caused by the resetting of errorInfo and errorCode + * [Bug 804681], which are not needed here. We chose instead to + * manipulate the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it keeps the + * refCount it had in its role of iPtr->objResultPtr. + */ + + objResultPtr = Tcl_GetObjResult(interp); + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; +#ifndef TCL_COMPILE_DEBUG + if (*pc == INST_POP) { + TclDecrRefCount(objResultPtr); + NEXT_INST_V(1, cleanup, 0); + } +#endif + NEXT_INST_V(0, cleanup, -1); + } /* * Targets for standard instruction endings; unrolled for speed in the @@ -2174,42 +2343,26 @@ TclExecuteByteCode( } cleanup0: -#ifdef TCL_COMPILE_DEBUG - /* - * Skip the stack depth check if an expansion is in progress. - */ - - ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0, - /*checkStack*/ auxObjList == NULL); - if (TAUX.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). */ - if ((TAUX.instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { + if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { - TRESULT = Tcl_AsyncInvoke(interp, TRESULT); - if (TRESULT == TCL_ERROR) { + result = Tcl_AsyncInvoke(interp, result); + if (result == TCL_ERROR) { CACHE_STACK_INFO(); goto gotError; } } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + if (TclCanceled(iPtr)) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + CACHE_STACK_INFO(); + goto gotError; + } } if (TclLimitReady(iPtr->limit)) { @@ -2221,8 +2374,6 @@ TclExecuteByteCode( CACHE_STACK_INFO(); } - TCL_DTRACE_INST_NEXT(); - /* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale @@ -2232,13 +2383,62 @@ TclExecuteByteCode( * reduces total obj size. */ - if (*pc == INST_LOAD_SCALAR1) { - goto instLoadScalar1; - } else if (*pc == INST_PUSH1) { - goto instPush1Peephole; + inst = *pc; + + peepholeStart: +#ifdef TCL_COMPILE_STATS + iPtr->stats.instructionCount[*pc]++; +#endif + +#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 */ - switch (*pc) { + TCL_DTRACE_INST_NEXT(); + + if (inst == INST_LOAD_SCALAR1) { + goto instLoadScalar1; + } else if (inst == INST_PUSH1) { + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); + TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS); + inst = *(pc += 2); + goto peepholeStart; + } else if (inst == INST_START_CMD) { + /* + * Peephole: do not run INST_START_CMD, just skip it + */ + + iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); + if (checkInterp) { + checkInterp = 0; + if (((codePtr->compileEpoch != iPtr->compileEpoch) || + (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && + !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + goto instStartCmdFailed; + } + } + inst = *(pc += 9); + goto peepholeStart; + } else if (inst == INST_NOP) { +#ifndef TCL_COMPILE_DEBUG + while (inst == INST_NOP) +#endif + { + inst = *++pc; + } + goto peepholeStart; + } + + switch (inst) { case INST_SYNTAX: case INST_RETURN_IMM: { int code = TclGetInt4AtPtr(pc+1); @@ -2249,9 +2449,9 @@ TclExecuteByteCode( */ TRACE(("%u %u => ", code, level)); - TRESULT = TclProcessReturn(interp, code, level, OBJ_AT_TOS); - if (TRESULT == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (TRESULT=\"%.30s\")", + result = TclProcessReturn(interp, code, level, OBJ_AT_TOS); + if (result == TCL_OK) { + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); } @@ -2260,23 +2460,194 @@ TclExecuteByteCode( iPtr->flags &= ~ERR_ALREADY_LOGGED; } cleanup = 2; + TRACE_APPEND(("\n")); goto processExceptionReturn; } case INST_RETURN_STK: TRACE(("=> ")); objResultPtr = POP_OBJECT(); - TRESULT = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; - if (TRESULT == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (TRESULT=\"%.30s\")", + result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); + if (result == TCL_OK) { + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", O2S(objResultPtr))); NEXT_INST_F(1, 0, 0); + } else if (result == TCL_ERROR) { + /* + * BEWARE! Must do this in this order, because an error in the + * option dictionary overrides the result (and can be verified by + * test). + */ + + Tcl_SetObjResult(interp, objResultPtr); + Tcl_SetReturnOptions(interp, OBJ_AT_TOS); + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + } else { + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + Tcl_SetObjResult(interp, objResultPtr); + } + cleanup = 1; + TRACE_APPEND(("\n")); + goto processExceptionReturn; + + { + CoroutineData *corPtr; + int yieldParameter; + + case INST_YIELD: + 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)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE_APPEND(("YIELD...\n")); + } else { + fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(OBJ_AT_TOS)); + } + fflush(stdout); + } +#endif + yieldParameter = 0; + Tcl_SetObjResult(interp, OBJ_AT_TOS); + goto doYield; + + case INST_YIELD_TO_INVOKE: + corPtr = iPtr->execEnvPtr->corPtr; + valuePtr = OBJ_AT_TOS; + if (!corPtr) { + TRACE(("[%.30s] => ERROR: yield outside coroutine\n", + O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto can only be called in a coroutine", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", + NULL); + CACHE_STACK_INFO(); + goto gotError; } - Tcl_SetObjResult(interp, objResultPtr); + if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { + TRACE(("[%.30s] => ERROR: yield in deleted\n", + O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); + } else { + /* FIXME: What is the right thing to trace? */ + fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(valuePtr)); + } + fflush(stdout); + } +#endif + + /* + * Install a tailcall record in the caller and continue with the + * yield. The yield is switched into multi-return mode (via the + * 'yieldParameter'). + */ + + Tcl_IncrRefCount(valuePtr); + iPtr->execEnvPtr = corPtr->callerEEPtr; + TclSetTailcall(interp, valuePtr); + iPtr->execEnvPtr = corPtr->eePtr; + yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ + + doYield: + /* TIP #280: Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. + */ + + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); + } + + pc++; cleanup = 1; + TEBC_YIELD(); + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + INT2PTR(yieldParameter), 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)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + /* FIXME: What is the right thing to trace? */ + { + 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); + if (iPtr->varFramePtr->tailcallPtr) { + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); + } + iPtr->varFramePtr->tailcallPtr = listPtr; + + result = TCL_RETURN; + cleanup = opnd; goto processExceptionReturn; + } case INST_DONE: if (tosPtr > initTosPtr) { @@ -2289,9 +2660,9 @@ TclExecuteByteCode( Tcl_SetObjResult(interp, OBJ_AT_TOS); #ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("=> return code=%d, result=", TRESULT), + TRACE_WITH_OBJ(("=> return code=%d, result=", result), iPtr->objResultPtr); - if (TAUX.traceInstructions) { + if (traceInstructions) { fprintf(stdout, "\n"); } #endif @@ -2300,23 +2671,6 @@ TclExecuteByteCode( (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); @@ -2326,68 +2680,7 @@ TclExecuteByteCode( 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 (!TAUX.checkInterp) { - goto instStartCmdOK; - } else if (((codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch)) - || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - TAUX.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); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); - goto instEvalStk; - } - - case INST_NOP: - pc += 1; - goto cleanup0; + NEXT_INST_F(1, 0, 0); case INST_DUP: objResultPtr = OBJ_AT_TOS; @@ -2397,7 +2690,7 @@ TclExecuteByteCode( case INST_OVER: opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("=> "), objResultPtr); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); case INST_REVERSE: { @@ -2412,10 +2705,11 @@ TclExecuteByteCode( *b = tmpPtr; a++; b--; } + TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } - case INST_CONCAT1: { + case INST_STR_CONCAT1: { int appendLen = 0; char *bytes, *p; Tcl_Obj **currPtr; @@ -2495,10 +2789,9 @@ TclExecuteByteCode( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG +#ifndef TCL_COMPILE_DEBUG if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { TclFreeIntRep(objResultPtr); - objResultPtr->typePtr = NULL; objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); objResultPtr->length = length + appendLen; p = TclGetString(objResultPtr) + length; @@ -2506,7 +2799,7 @@ TclExecuteByteCode( } else #endif { - p = (char *) ckalloc((unsigned) (length + appendLen + 1)); + p = ckalloc(length + appendLen + 1); TclNewObj(objResultPtr); objResultPtr->bytes = p; objResultPtr->length = length + appendLen; @@ -2532,7 +2825,7 @@ TclExecuteByteCode( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG +#ifndef TCL_COMPILE_DEBUG if (!Tcl_IsShared(objResultPtr)) { bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, length + appendLen); @@ -2565,6 +2858,17 @@ TclExecuteByteCode( NEXT_INST_V(2, opnd, 1); } + case INST_CONCAT_STK: + /* + * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, + * and then decrement their ref counts. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + case INST_EXPAND_START: /* * Push an element to the auxObjList. This records the current @@ -2580,10 +2884,29 @@ TclExecuteByteCode( */ TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH; + objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; + objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); + TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); NEXT_INST_F(1, 0, 0); + case INST_EXPAND_DROP: + /* + * Drops an element of the auxObjList, popping stack elements to + * restore the stack to the state before the point where the aux + * element was created. + */ + + CLANG_ASSERT(auxObjList); + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; + POP_TAUX_OBJ(); +#ifdef TCL_COMPILE_DEBUG + /* Ugly abuse! */ + starting = 1; +#endif + TRACE(("=> drop %d items\n", objc)); + NEXT_INST_V(1, objc, 0); + case INST_EXPAND_STKTOP: { int i; ptrdiff_t moved; @@ -2595,9 +2918,9 @@ TclExecuteByteCode( */ objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(objPtr))); if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } (void) POP_OBJECT(); @@ -2609,23 +2932,27 @@ TclExecuteByteCode( * stack depth, as seen by the compiler. */ - length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); - DECACHE_STACK_INFO(); - moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) BP; - - if (moved) { - /* - * Change the global data to point to the new stack: move the - * bottomPtr, recompute the position of every other - * stack-allocated parameter, update the stack pointers. - */ + auxObjList->length += objc - 1; + if ((objc > 1) && (auxObjList->length > 0)) { + length = auxObjList->length /* Total expansion room we need */ + + codePtr->maxStackDepth /* Beyond the original max */ + - CURR_DEPTH; /* Relative to where we are */ + DECACHE_STACK_INFO(); + moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) + - (Tcl_Obj **) TD; + if (moved) { + /* + * Change the global data to point to the new stack: move the + * TEBCdataPtr TD, recompute the position of every other + * stack-allocated parameter, update the stack pointers. + */ - BP = (BottomData *) (((Tcl_Obj **)BP) + moved); - TAUX.esPtr = iPtr->execEnvPtr->execStackPtr; + esPtr = iPtr->execEnvPtr->execStackPtr; + TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); - catchTop += moved; - tosPtr += moved; + catchTop += moved; + tosPtr += moved; + } } /* @@ -2637,16 +2964,12 @@ TclExecuteByteCode( PUSH_OBJECT(objv[i]); } + TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); NEXT_INST_F(5, 0, 0); } case INST_EXPR_STK: { - /* - * Moved here to support transforming the eval of an expression to - * a non-recursive TEBC call. - */ - ByteCode *newCodePtr; bcFramePtr->data.tebc.pc = (char *) pc; @@ -2656,9 +2979,8 @@ TclExecuteByteCode( CACHE_STACK_INFO(); cleanup = 1; pc++; - NR_DATA_BURY(); - codePtr = newCodePtr; - goto nonRecursiveCallStart; + TEBC_YIELD(); + return TclNRExecuteByteCode(interp, newCodePtr); } /* @@ -2667,85 +2989,17 @@ TclExecuteByteCode( instEvalStk: case INST_EVAL_STK: - /* - * Moved here to support transforming the eval of objects to a simple - * command invocation (for canonical lists) or a non-recursive TEBC - * call (compiled scripts). - */ + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; - objPtr = OBJ_AT_TOS; cleanup = 1; - pcAdjustment = 1; - - if (objPtr->typePtr == &tclListType) { - List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *copyPtr; - - /* - * Test if the list is "pure" or "canonical", since in that case - * we can know for sure that there are no syntactic nasties and - * treat the list's elements as literal words without need for - * further substitution. "Pure" lists are those that have no - * string representation at all; they're known OK because we know - * the algorithm for generating the string representation never - * produces hazards. "Canonical" lists are where we know that the - * string representation was produced from the internal - * representation of the list. - */ - - if (objPtr->bytes == NULL || listRepPtr->canonicalFlag) { - if (Tcl_IsShared(objPtr)) { - copyPtr = TclListObjCopy(interp, objPtr); - Tcl_IncrRefCount(copyPtr); - OBJ_AT_TOS = copyPtr; - listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - - /* - * Decrement the refcount on the *original* copy of the - * list directly; we know it was greater than 1 here so it - * can't be deallocated. - */ - - objPtr->refCount--; - } - objc = listRepPtr->elemCount; - objv = &listRepPtr->elements; - - /* - * Fix for [Bug 2102930] - */ - - iPtr->numLevels++; - Tcl_NRAddCallback(interp, NRCommand, NULL,NULL,NULL,NULL); - goto doInvocationFromEval; - } - } - - /* - * Run the bytecode in this same TEBC instance! - * - * TIP #280: The invoking context is left NULL for a dynamically - * constructed command. We cannot match its lines to the outer - * context. - */ - - { - ByteCode *newCodePtr; - - DECACHE_STACK_INFO(); - newCodePtr = TclCompileObj(interp, objPtr, NULL, 0); - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - pc++; - NR_DATA_BURY(); - codePtr = newCodePtr; - goto nonRecursiveCallStart; - } + pc += 1; + TEBC_YIELD(); + return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0); case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1; + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; POP_TAUX_OBJ(); if (objc) { pcAdjustment = 1; @@ -2771,13 +3025,12 @@ TclExecuteByteCode( doInvocation: objv = &OBJ_AT_DEPTH(objc-1); cleanup = objc; - doInvocationFromEval: #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { int i; - if (TAUX.traceInstructions) { + if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%u => call ", objc)); } else { @@ -2803,144 +3056,16 @@ TclExecuteByteCode( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; - /* - * Reset the instructionCount variable, since we're about to check for - * async stuff anyway while processing TclEvalObjv - */ - - TAUX.instructionCount = 1; - - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); + } DECACHE_STACK_INFO(); - TRESULT = TclNREvalObjv(interp, objc, objv, - (*pc == INST_EVAL_STK) ? 0 : TCL_EVAL_NOERR, NULL); - TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); - CACHE_STACK_INFO(); - - if (TOP_CB(interp) != BP->rootPtr) { - TEOV_callback *callbackPtr; - int type; - ClientData param; - - NRE_ASSERT(TRESULT == TCL_OK); - pc += pcAdjustment; - - nonRecursiveCallSetup: - callbackPtr = TOP_CB(interp); - type = PTR2INT(callbackPtr->data[0]); - param = callbackPtr->data[1]; - - pcAdjustment = 0; /* silence warning */ - - NRE_ASSERT(callbackPtr != BP->rootPtr); - NRE_ASSERT(callbackPtr->procPtr == NRCallTEBC); - - TOP_CB(interp) = callbackPtr->nextPtr; - TCLNR_FREE(interp, callbackPtr); - - NR_DATA_BURY(); - switch (type) { - case TCL_NR_BC_TYPE: - if (param) { - codePtr = param; - goto nonRecursiveCallStart; - } else { - OBP = BP; - goto resumeCoroutine; - } - case TCL_NR_YIELD_TYPE: { /* [yield] */ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (!corPtr) { - Tcl_SetResult(interp, - "yield can only be called in a coroutine", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", - "ILLEGAL_YIELD", NULL); - pc--; - goto gotError; - } - - NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); - NRE_ASSERT(corPtr->stackLevel != NULL); - NRE_ASSERT(BP == corPtr->eePtr->bottomPtr); - if (corPtr->stackLevel != &TAUX) { - Tcl_SetResult(interp, "cannot yield: C stack busy", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", - NULL); - pc--; - goto gotError; - } - - /* - * Mark suspended, save our state and return - */ - - corPtr->stackLevel = NULL; - iPtr->execEnvPtr = corPtr->callerEEPtr; - OBP = *corPtr->callerBPPtr; - goto returnToCaller; - } - default: - Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); - } - } - pc += pcAdjustment; - - nonRecursiveCallReturn: - if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { - iPtr->flags |= ERR_ALREADY_LOGGED; - codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; - } - NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); - - if (iPtr->execEnvPtr->rewind) { - TRESULT = TCL_ERROR; - goto abnormalReturn; - } - - if (TRESULT != TCL_OK) { - pc--; - goto processExceptionReturn; - } - -#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); - - /* - * Reset the interp's result to avoid possible duplications of large - * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any - * side effects caused by the resetting of errorInfo and errorCode - * [Bug 804681], which are not needed here. We chose instead to - * manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps the - * refCount it had in its role of iPtr->objResultPtr. - */ - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_V(0, cleanup, -1); + TEBC_YIELD(); + return TclNREvalObjv(interp, objc, objv, + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); #if TCL_SUPPORT_84_BYTECODE case INST_CALL_BUILTIN_FUNC1: @@ -2954,7 +3079,7 @@ TclExecuteByteCode( opnd = TclGetUInt1AtPtr(pc+1); if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); - Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); + Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd); } TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); @@ -3022,11 +3147,74 @@ TclExecuteByteCode( */ case INST_CALL_BUILTIN_FUNC1: - Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); + Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); case INST_CALL_FUNC1: - Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found"); + 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; + } + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); + } + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = opnd; + iPtr->ensembleRewrite.numInsertedObjs = 1; + DECACHE_STACK_INFO(); + pc += 6; + TEBC_YIELD(); + + TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); + TclSkipTailcall(interp); + return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN); + /* * ----------------------------------------------------------------- * Start of INST_LOAD instructions. @@ -3113,7 +3301,7 @@ TclExecuteByteCode( 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)))); + TRACE_ERROR(interp); goto gotError; } cleanup = 1; @@ -3139,7 +3327,7 @@ TclExecuteByteCode( TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } @@ -3166,7 +3354,7 @@ TclExecuteByteCode( part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -3315,7 +3503,7 @@ TclExecuteByteCode( 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)))); + TRACE_ERROR(interp); goto gotError; } cleanup = ((part2Ptr == NULL)? 2 : 3); @@ -3365,7 +3553,7 @@ TclExecuteByteCode( 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)))); + TRACE_ERROR(interp); goto gotError; } goto doCallPtrSetVar; @@ -3413,7 +3601,7 @@ TclExecuteByteCode( part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); CACHE_STACK_INFO(); if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } #ifndef TCL_COMPILE_DEBUG @@ -3439,7 +3627,7 @@ TclExecuteByteCode( { Tcl_Obj *incrPtr; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; #endif long increment; @@ -3488,9 +3676,11 @@ TclExecuteByteCode( 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)))); + DECACHE_STACK_INFO(); + Tcl_AddErrorInfo(interp, + "\n (reading value of variable to increment)"); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3516,7 +3706,7 @@ TclExecuteByteCode( 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)))); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3561,7 +3751,7 @@ TclExecuteByteCode( } goto doneIncr; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); @@ -3583,7 +3773,7 @@ TclExecuteByteCode( goto doneIncr; #endif } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { Tcl_WideInt sum; @@ -3628,8 +3818,7 @@ TclExecuteByteCode( TclNewLongObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); @@ -3651,7 +3840,7 @@ TclExecuteByteCode( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %ld => ", opnd, increment)); + TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr))); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -3666,8 +3855,7 @@ TclExecuteByteCode( } if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); @@ -3678,8 +3866,7 @@ TclExecuteByteCode( CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -3700,6 +3887,8 @@ TclExecuteByteCode( */ case INST_EXIST_SCALAR: + cleanup = 0; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -3716,16 +3905,11 @@ TclExecuteByteCode( 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); + goto afterExistsPeephole; case INST_EXIST_ARRAY: + cleanup = 1; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); part2Ptr = OBJ_AT_TOS; arrayPtr = LOCAL(opnd); @@ -3736,7 +3920,7 @@ TclExecuteByteCode( if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (!varPtr || !ReadTraced(varPtr)) { - goto doneExistArray; + goto afterExistsPeephole; } } varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", @@ -3753,13 +3937,11 @@ TclExecuteByteCode( varPtr = NULL; } } - doneExistArray: - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 1, 1); + goto afterExistsPeephole; case INST_EXIST_ARRAY_STK: cleanup = 2; + pcAdjustment = 1; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); @@ -3767,6 +3949,7 @@ TclExecuteByteCode( case INST_EXIST_STK: cleanup = 1; + pcAdjustment = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ TRACE(("\"%.30s\" => ", O2S(part1Ptr))); @@ -3786,9 +3969,17 @@ TclExecuteByteCode( varPtr = NULL; } } - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); + + /* + * Peep-hole optimisation: if you're about to jump, do jump from here. + */ + + afterExistsPeephole: { + int found = (varPtr && !TclIsVarUndefined(varPtr)); + + TRACE_APPEND(("%d\n", found ? 1 : 0)); + JUMP_PEEPHOLE_V(found, pcAdjustment, cleanup); + } /* * End of INST_EXIST instructions. @@ -3806,7 +3997,7 @@ TclExecuteByteCode( while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd)); + TRACE(("%s %u => ", (flags ? "normal" : "noerr"), opnd)); if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { /* * No errors, no traces, no searches: just make the variable cease @@ -3819,6 +4010,7 @@ TclExecuteByteCode( goto slowUnsetScalar; } varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 0, 0); } @@ -3839,7 +4031,7 @@ TclExecuteByteCode( while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%s %u \"%.30s\"\n", + TRACE(("%s %u \"%.30s\" => ", (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); @@ -3855,12 +4047,14 @@ TclExecuteByteCode( goto slowUnsetArray; } varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 1, 0); } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { /* * Don't need to do anything here. */ + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 1, 0); } } @@ -3884,7 +4078,7 @@ TclExecuteByteCode( cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"), + TRACE(("%s \"%.30s(%.30s)\" => ", (flags ? "normal" : "noerr"), O2S(part1Ptr), O2S(part2Ptr))); goto doUnsetStk; @@ -3893,7 +4087,8 @@ TclExecuteByteCode( cleanup = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); + TRACE(("%s \"%.30s\" => ", (flags ? "normal" : "noerr"), + O2S(part1Ptr))); doUnsetStk: DECACHE_STACK_INFO(); @@ -3902,17 +4097,139 @@ TclExecuteByteCode( goto errorInUnset; } CACHE_STACK_INFO(); + TRACE_APPEND(("OK\n")); NEXT_INST_V(2, cleanup, 0); errorInUnset: CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; + + /* + * This is really an unset operation these days. Do not issue. + */ + + case INST_DICT_DONE: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => OK\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 { + DECACHE_STACK_INFO(); + TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + CACHE_STACK_INFO(); + } + 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))) { + DECACHE_STACK_INFO(); + result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, + NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| + TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + TRACE_ERROR(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_ERROR(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); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(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. */ @@ -3923,9 +4240,11 @@ TclExecuteByteCode( Namespace *savedNsPtr; case INST_UPVAR: - TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { + TRACE_ERROR(interp); goto gotError; } @@ -3940,13 +4259,16 @@ TclExecuteByteCode( /*createPart2*/ 1, &varPtr); iPtr->varFramePtr = savedFramePtr; if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } goto doLinkVars; case INST_NSUPVAR: - TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -3961,16 +4283,18 @@ TclExecuteByteCode( /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } goto doLinkVars; case INST_VARIABLE: - TRACE(("variable ")); + TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS))); otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } @@ -3988,7 +4312,7 @@ TclExecuteByteCode( * if there are no errors; otherwise, let it handle the case. */ - opnd = TclGetInt4AtPtr(pc+1);; + opnd = TclGetInt4AtPtr(pc+1); varPtr = LOCAL(opnd); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { @@ -4000,6 +4324,7 @@ TclExecuteByteCode( Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { + TRACE_APPEND(("already linked\n")); NEXT_INST_F(5, 1, 0); } if (TclIsVarInHash(linkPtr)) { @@ -4016,6 +4341,7 @@ TclExecuteByteCode( } } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4024,6 +4350,7 @@ TclExecuteByteCode( * variables - and [variable] did not push it at all. */ + TRACE_APPEND(("link made\n")); NEXT_INST_F(5, 1, 0); } @@ -4070,32 +4397,30 @@ TclExecuteByteCode( doCondJump: valuePtr = OBJ_AT_TOS; + TRACE(("%d => ", jmpOffset[ + (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1])); /* 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)); + TRACE_ERROR(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), + TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } else { - TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], - O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); + TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), + (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); } } #endif @@ -4113,7 +4438,7 @@ TclExecuteByteCode( opnd = TclGetInt4AtPtr(pc+1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS))); + 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)); @@ -4146,14 +4471,18 @@ TclExecuteByteCode( if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); goto gotError; } @@ -4169,6 +4498,376 @@ TclExecuteByteCode( /* * ----------------------------------------------------------------- + * 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; + + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (level <= 0) { + level += framePtr->level; + } + for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; + framePtr = framePtr->callerVarPtr) { + /* Empty loop body */ + } + if (framePtr == rootFramePtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(OBJ_AT_TOS))); + TRACE_ERROR(interp); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + goto gotError; + } + objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } + { + Tcl_Command cmd, origCmd; + + case INST_RESOLVE_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_ORIGIN_COMMAND: + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + if (cmd == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_APPEND(("ERROR: not command\n")); + goto gotError; + } + origCmd = TclGetOriginalCommand(cmd); + if (origCmd == NULL) { + origCmd = cmd; + } + TclNewObj(objResultPtr); + Tcl_GetCommandFullName(interp, origCmd, objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); + NEXT_INST_F(1, 1, 1); + } + + /* + * ----------------------------------------------------------------- + * Start of TclOO support instructions. + */ + + { + Object *oPtr; + CallFrame *framePtr; + CallContext *contextPtr; + int skip, newDepth; + + case INST_TCLOO_SELF: + framePtr = iPtr->varFramePtr; + 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)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); + 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); + + case INST_TCLOO_NEXT_CLASS: + opnd = TclGetUInt1AtPtr(pc+1); + framePtr = iPtr->varFramePtr; + valuePtr = OBJ_AT_DEPTH(opnd - 2); + objv = &OBJ_AT_DEPTH(opnd - 1); + skip = 2; + TRACE(("%d => ", opnd)); + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE_APPEND(("ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "nextto may only be called from inside a method", + -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = framePtr->clientData; + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr); + if (oPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr))); + goto gotError; + } else { + Class *classPtr = oPtr->classPtr; + struct MInvoke *miPtr; + int i; + const char *methodType; + + if (classPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + + for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { + miPtr = contextPtr->callPtr->chain + i; + if (!miPtr->isFilter && + miPtr->mPtr->declaringClassPtr == classPtr) { + newDepth = i; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + } else { + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < opnd; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + goto doInvokeNext; + } + } + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", + O2S(valuePtr))); + for (i=contextPtr->index ; i>=0 ; i--) { + miPtr = contextPtr->callPtr->chain + i; + if (miPtr->isFilter + || miPtr->mPtr->declaringClassPtr != classPtr) { + continue; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s implementation by \"%s\" not reachable from here", + methodType, TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s has no non-filter implementation by \"%s\"", + methodType, TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + + case INST_TCLOO_NEXT: + opnd = TclGetUInt1AtPtr(pc+1); + objv = &OBJ_AT_DEPTH(opnd - 1); + framePtr = iPtr->varFramePtr; + skip = 1; + TRACE(("%d => ", opnd)); + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE_APPEND(("ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "next may only be called from inside a method", + -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = framePtr->clientData; + + newDepth = contextPtr->index + 1; + if (newDepth >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message unless + * the interpreter is being torn down, in which case we might be + * getting here because of methods/destructors doing a [next] (or + * equivalent) unexpectedly. + */ + + const char *methodType; + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: no TclOO next impl\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + CACHE_STACK_INFO(); + goto gotError; +#ifdef TCL_COMPILE_DEBUG + } else if (tclTraceExec >= 2) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + } else { + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < opnd; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); +#endif /*TCL_COMPILE_DEBUG*/ + } + + doInvokeNext: + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); + } + + pcAdjustment = 2; + cleanup = opnd; + DECACHE_STACK_INFO(); + iPtr->varFramePtr = framePtr->callerVarPtr; + pc += pcAdjustment; + TEBC_YIELD(); + + oPtr = contextPtr->oPtr; + if (oPtr->flags & FILTER_HANDLING) { + TclNRAddCallback(interp, FinalizeOONextFilter, + framePtr, contextPtr, INT2PTR(contextPtr->index), + INT2PTR(contextPtr->skip)); + } else { + TclNRAddCallback(interp, FinalizeOONext, + framePtr, contextPtr, INT2PTR(contextPtr->index), + INT2PTR(contextPtr->skip)); + } + contextPtr->skip = skip; + contextPtr->index = newDepth; + if (contextPtr->callPtr->chain[newDepth].isFilter + || contextPtr->callPtr->flags & FILTER_HANDLING) { + oPtr->flags |= FILTER_HANDLING; + } else { + oPtr->flags &= ~FILTER_HANDLING; + } + + { + register Method *const mPtr = + contextPtr->callPtr->chain[newDepth].mPtr; + + return mPtr->typePtr->callProc(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, opnd, objv); + } + + 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); + } + + /* + * End of TclOO support instructions. + * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ @@ -4189,19 +4888,19 @@ TclExecuteByteCode( 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)); + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TRACE_APPEND(("%d\n", length)); NEXT_INST_F(1, 1, 1); case INST_LIST_INDEX: /* lindex with objc == 3 */ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Extract the desired list element. @@ -4219,8 +4918,7 @@ TclExecuteByteCode( objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); if (!objResultPtr) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4228,8 +4926,7 @@ TclExecuteByteCode( * Stash the list element on the stack. */ - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", 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 @@ -4241,6 +4938,7 @@ TclExecuteByteCode( valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); + TRACE(("\%.30s\" %d => ", O2S(valuePtr), opnd)); /* * Get the contents of the list, making sure that it really is a list @@ -4248,8 +4946,7 @@ TclExecuteByteCode( */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4272,8 +4969,7 @@ TclExecuteByteCode( TclNewObj(objResultPtr); } - TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), - objResultPtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ @@ -4288,10 +4984,11 @@ TclExecuteByteCode( * Do the 'lindex' operation. */ + TRACE(("%d => ", opnd)); objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), numIndices, &OBJ_AT_DEPTH(numIndices - 1)); if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4299,7 +4996,7 @@ TclExecuteByteCode( * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd, -1); case INST_LSET_FLAT: @@ -4309,6 +5006,7 @@ TclExecuteByteCode( opnd = TclGetUInt4AtPtr(pc + 1); numIndices = opnd - 2; + TRACE(("%d => ", opnd)); /* * Get the old value of variable, and remove the stack ref. This is @@ -4327,7 +5025,7 @@ TclExecuteByteCode( objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4335,7 +5033,7 @@ TclExecuteByteCode( * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, numIndices+1, -1); case INST_LSET_LIST: /* 'lset' with 4 args */ @@ -4355,6 +5053,8 @@ TclExecuteByteCode( valuePtr = OBJ_AT_TOS; value2Ptr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", + O2S(value2Ptr), O2S(valuePtr), O2S(objPtr))); /* * Compute the new variable value. @@ -4362,8 +5062,7 @@ TclExecuteByteCode( objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); if (!objResultPtr) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4371,7 +5070,7 @@ TclExecuteByteCode( * Set result. */ - TRACE(("=> %s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in @@ -4384,6 +5083,8 @@ TclExecuteByteCode( valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); + TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), + TclGetInt4AtPtr(pc+5))); /* * Get the contents of the list, making sure that it really is a list @@ -4391,8 +5092,7 @@ TclExecuteByteCode( */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4434,19 +5134,37 @@ TclExecuteByteCode( */ if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { - if (fromIdx<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) { + for (index=toIdx+1; index<objc ; 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); + TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: @@ -4454,11 +5172,10 @@ TclExecuteByteCode( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - /* TODO: Consider more efficient tests than strcmp() */ s1 = TclGetStringFromObj(valuePtr, &s1len); + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } match = 0; @@ -4479,7 +5196,7 @@ TclExecuteByteCode( s2len = 0; } if (s1len == s2len) { - match = (strcmp(s1, s2) == 0); + match = (memcmp(s1, s2, s1len) == 0); } i++; } while (i < length && match == 0); @@ -4489,7 +5206,7 @@ TclExecuteByteCode( match = !match; } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -4497,21 +5214,30 @@ TclExecuteByteCode( * for branching. */ - 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); + JUMP_PEEPHOLE_F(match, 1, 2); + + case INST_LIST_CONCAT: + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + if (Tcl_ListObjAppendList(interp, objResultPtr, + value2Ptr) != TCL_OK) { + TRACE_ERROR(interp); + TclDecrRefCount(objResultPtr); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } else { + if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); /* * End of INST_LIST and related instructions. @@ -4521,114 +5247,91 @@ TclExecuteByteCode( case INST_STR_EQ: case INST_STR_NEQ: /* String (in)equality check */ - /* - * TODO: Consider merging into INST_STR_CMP - */ - + case INST_STR_CMP: /* String compare. */ + stringCompare: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; if (valuePtr == value2Ptr) { + match = 0; + } else { /* - * On the off-chance that the objects are the same, we don't - * really have to think hard about equality. + * We only need to check (in)equality when we have equal length + * strings. We can use memcmp in all (n)eq cases because we + * don't need to worry about lexical LE/BE variance. */ - match = (*pc == INST_STR_EQ); - } else { - s1 = TclGetStringFromObj(valuePtr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - if (s1len == s2len) { + typedef int (*memCmpFn_t)(const void*, const void*, size_t); + memCmpFn_t memCmpFn; + int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) + || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ)); + + if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value2Ptr)) { + s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + memCmpFn = memcmp; + } else if (((valuePtr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType))) { /* - * We only need to check (in)equality when we have equal - * length strings. + * Do a unicode-specific comparison if both of the args are of + * String type. If the char length == byte length, we can do a + * memcmp. In benchmark testing this proved the most efficient + * check between the unicode and string comparison operations. */ - if (*pc == INST_STR_NEQ) { - match = (strcmp(s1, s2) != 0); + s1len = Tcl_GetCharLength(valuePtr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == valuePtr->length) + && (s2len == value2Ptr->length)) { + s1 = valuePtr->bytes; + s2 = value2Ptr->bytes; + memCmpFn = memcmp; } else { - /* INST_STR_EQ */ - match = (strcmp(s1, s2) == 0); + s1 = (char *) Tcl_GetUnicode(valuePtr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); + if ( +#ifdef WORDS_BIGENDIAN + 1 +#else + checkEq +#endif + ) { + memCmpFn = memcmp; + s1len *= sizeof(Tcl_UniChar); + s2len *= sizeof(Tcl_UniChar); + } else { + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + } } } else { - match = (*pc == INST_STR_NEQ); - } - } - - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),match)); - - /* - * Peep-hole optimisation: if you're about to jump, do jump from here. - */ - - 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); - - stringCompare: - case INST_STR_CMP: /* String compare. */ - value2Ptr = OBJ_AT_TOS; - valuePtr = OBJ_UNDER_TOS; - - /* - * The comparison function should compare up to the minimum byte - * length only. - */ - - if (valuePtr == value2Ptr) { - /* - * In the pure equality case, set lengths too for the checks below - * (or we could goto beyond it). - */ + /* + * strcmp can't do a simple memcmp in order to handle the + * special Tcl \xC0\x80 null encoding for utf-8. + */ - match = s1len = s2len = 0; - } else if (TclIsPureByteArray(valuePtr) - && TclIsPureByteArray(value2Ptr)) { - s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); - s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - match = memcmp(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); - } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType))) { - /* - * Do a unicode-specific comparison if both of the args are of - * String type. If the char length == byte length, we can do a - * memcmp. In benchmark testing this proved the most efficient - * check between the unicode and string comparison operations. - */ + s1 = TclGetStringFromObj(valuePtr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + if (checkEq) { + memCmpFn = memcmp; + } else { + memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + } + } - s1len = Tcl_GetCharLength(valuePtr); - s2len = Tcl_GetCharLength(value2Ptr); - if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) { - match = memcmp(valuePtr->bytes, value2Ptr->bytes, - (unsigned) ((s1len < s2len) ? s1len : s2len)); + if (checkEq && (s1len != s2len)) { + match = 1; } else { - match = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), - Tcl_GetUnicode(value2Ptr), - (unsigned) ((s1len < s2len) ? s1len : s2len)); + /* + * The comparison function should compare up to the minimum + * byte length only. + */ + match = memCmpFn(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + if (match == 0) { + match = s1len - s2len; + } } - } else { - /* - * We can't do a simple memcmp in order to handle the special Tcl - * \xC0\x80 null encoding for utf-8. - */ - - s1 = TclGetStringFromObj(valuePtr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - match = TclpUtfNcmp2(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); } /* @@ -4636,19 +5339,17 @@ TclExecuteByteCode( * TODO: consider peephole opt. */ - if (match == 0) { - match = s1len - s2len; - } - if (*pc != INST_STR_CMP) { /* * Take care of the opcodes that goto'ed into here. */ switch (*pc) { + case INST_STR_EQ: case INST_EQ: match = (match == 0); break; + case INST_STR_NEQ: case INST_NEQ: match = (match != 0); break; @@ -4666,25 +5367,74 @@ TclExecuteByteCode( break; } } - if (match < 0) { - TclNewIntObj(objResultPtr, -1); - } else { - objResultPtr = TCONST(match > 0); - } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), + (match < 0 ? -1 : match > 0 ? 1 : 0))); + JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); + case INST_STR_UPPER: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToUpper(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToUpper(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); + TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_LOWER: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToLower(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToLower(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); + TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_TITLE: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToTitle(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToTitle(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); + TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr))); /* * Get char length to calulate what 'end' means. @@ -4692,6 +5442,7 @@ TclExecuteByteCode( length = Tcl_GetCharLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4717,10 +5468,382 @@ TclExecuteByteCode( objResultPtr = Tcl_NewStringObj(buf, length); } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); + TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + + case INST_STR_RANGE: + TRACE(("\"%.20s\" %.20s %.20s =>", + 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) { + TRACE_ERROR(interp); + 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_REPLACE: + value3Ptr = POP_OBJECT(); + valuePtr = OBJ_AT_DEPTH(2); + length = Tcl_GetCharLength(valuePtr) - 1; + TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &toIdx) != TCL_OK) { + TclDecrRefCount(value3Ptr); + TRACE_ERROR(interp); + goto gotError; + } + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + if (fromIdx < 0) { + fromIdx = 0; + } + + if (fromIdx > toIdx || fromIdx > length) { + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + TclDecrRefCount(value3Ptr); + NEXT_INST_F(1, 0, 0); + } + + if (toIdx > length) { + toIdx = length; + } + + if (fromIdx == 0 && toIdx == length) { + TclDecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = value3Ptr; + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + NEXT_INST_F(1, 0, 0); + } + + length3 = Tcl_GetCharLength(value3Ptr); + + /* + * Remove substring. In-place. + */ + + if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) { + TclDecrRefCount(value3Ptr); + Tcl_SetObjLength(valuePtr, fromIdx); + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + + /* + * See if we can splice in place. This happens when the number of + * characters being replaced is the same as the number of characters + * in the string to be inserted. + */ + + if (length3 - 1 == toIdx - fromIdx) { + unsigned char *bytes1, *bytes2; + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + if (TclIsPureByteArray(objResultPtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); + } else { + ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; + } + Tcl_InvalidateStringRep(objResultPtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); + } else { + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; + } + Tcl_InvalidateStringRep(valuePtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + } + + /* + * Get the unicode representation; this is where we guarantee to lose + * bytearrays. + */ + + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + length--; + + /* + * Remove substring using copying. + */ + + if (length3 == 0) { + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, + length - toIdx); + } + TclDecrRefCount(value3Ptr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } + + /* + * Splice string pieces by full copying. + */ + + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + Tcl_AppendObjToObj(objResultPtr, value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else if (Tcl_IsShared(value3Ptr)) { + objResultPtr = Tcl_DuplicateObj(value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + /* + * Be careful with splicing the stack in this case; we have a + * refCount:1 object in value3Ptr and we want to append to it and + * make it be the refCount:1 object at the top of the stack + * afterwards. [Bug 82e7f67325] + */ + + if (toIdx < length) { + Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1, + length - toIdx); + } + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + TclDecrRefCount(valuePtr); + OBJ_AT_TOS = value3Ptr; /* Tricky! */ + NEXT_INST_F(1, 0, 0); + } + TclDecrRefCount(value3Ptr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + + 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; + goto doneStringMap; + } else if (valuePtr == value2Ptr) { + objResultPtr = value3Ptr; + goto doneStringMap; + } + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + if (length == 0) { + objResultPtr = valuePtr; + goto doneStringMap; + } + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + if (length2 > length || length2 == 0) { + objResultPtr = valuePtr; + goto doneStringMap; + } else if (length2 == length) { + if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { + objResultPtr = valuePtr; + } else { + objResultPtr = value3Ptr; + } + goto doneStringMap; + } + 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); + } + doneStringMap: + 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_CLASS: + opnd = TclGetInt1AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, + O2S(valuePtr))); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + match = 1; + if (length > 0) { + end = ustring1 + length; + for (p=ustring1 ; p<end ; p++) { + if (!tclStringClassTable[opnd].comparator(*p)) { + match = 0; + break; + } + } + } + TRACE_APPEND(("%d\n", match)); + JUMP_PEEPHOLE_F(match, 2, 1); + } + case INST_STR_MATCH: nocase = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; /* String */ @@ -4761,26 +5884,77 @@ TclExecuteByteCode( * 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); + JUMP_PEEPHOLE_F(match, 2, 2); + + { + const char *string1, *string2; + int trim1, trim2; + + case INST_STR_TRIM_LEFT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrimLeft(string1, length, string2, length2); + trim2 = 0; + goto createTrimmedString; + case INST_STR_TRIM_RIGHT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim2 = TclTrimRight(string1, length, string2, length2); + trim1 = 0; + goto createTrimmedString; + case INST_STR_TRIM: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrimLeft(string1, length, string2, length2); + if (trim1 < length) { + trim2 = TclTrimRight(string1, length, string2, length2); + } else { + trim2 = 0; + } + createTrimmedString: + /* + * Careful here; trim set often contains non-ASCII characters so we + * take care when printing. [Bug 971cb4f1db] + */ + +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TRACE(("\"%.30s\" ", O2S(valuePtr))); + TclPrintObject(stdout, value2Ptr, 30); + printf(" => "); } #endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + if (trim1 == 0 && trim2 == 0) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TclPrintObject(stdout, valuePtr, 30); + printf("\n"); + } +#endif + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TclPrintObject(stdout, objResultPtr, 30); + printf("\n"); + } +#endif + NEXT_INST_F(1, 2, 1); + } + } case INST_REGEXP: cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Compile and match the regular expression. @@ -4791,44 +5965,24 @@ TclExecuteByteCode( Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); if (regExpr == NULL) { - goto regexpFailure; + TRACE_ERROR(interp); + goto gotError; } - 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 + TRACE_ERROR(interp); goto gotError; } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", 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); + JUMP_PEEPHOLE_F(match, 2, 2); } /* @@ -4842,6 +5996,39 @@ TclExecuteByteCode( int type1, type2; long l1, l2, lResult; + case INST_NUM_TYPE: + if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { + type1 = 0; + } else if (type1 == TCL_NUMBER_LONG) { + /* value is between LONG_MIN and LONG_MAX */ + /* [string is integer] is -UINT_MAX to UINT_MAX range */ + int i; + + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } +#ifndef TCL_WIDE_INT_IS_LONG + } else if (type1 == TCL_NUMBER_WIDE) { + /* value is between WIDE_MIN and WIDE_MAX */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + int i; + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + type1 = TCL_NUMBER_LONG; + } +#endif + } else if (type1 == TCL_NUMBER_BIG) { + /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + Tcl_WideInt w; + + if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } + } + TclNewIntObj(objResultPtr, type1); + TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); + NEXT_INST_F(1, 1, 1); + case INST_EQ: case INST_NEQ: case INST_LT: @@ -4926,21 +6113,9 @@ TclExecuteByteCode( */ 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); + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), + iResult)); + JUMP_PEEPHOLE_F(iResult, 1, 2); } case INST_MOD: @@ -4957,7 +6132,9 @@ TclExecuteByteCode( TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } @@ -4966,7 +6143,9 @@ TclExecuteByteCode( TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); goto gotError; } @@ -5021,13 +6200,15 @@ TclExecuteByteCode( case INST_RSHIFT: if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); -#if 0 + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); -#endif + CACHE_STACK_INFO(); +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5067,13 +6248,15 @@ TclExecuteByteCode( case INST_LSHIFT: if (l2 < 0) { - Tcl_SetResult(interp, "negative shift argument", - TCL_STATIC); -#if 0 + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); -#endif + CACHE_STACK_INFO(); +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else if (l1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5088,13 +6271,14 @@ TclExecuteByteCode( * good place to draw the line. */ - Tcl_SetResult(interp, - "integer value too large to represent", - TCL_STATIC); -#if 0 + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); -#endif + CACHE_STACK_INFO(); +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { int shift = (int) l2; @@ -5152,8 +6336,7 @@ TclExecuteByteCode( TRACE_APPEND(("DIVIDE BY ZERO\n")); goto divideByZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); @@ -5176,7 +6359,9 @@ TclExecuteByteCode( TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name: "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } @@ -5195,7 +6380,9 @@ TclExecuteByteCode( TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(value2Ptr), O2S(valuePtr), (value2Ptr->typePtr? value2Ptr->typePtr->name: "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); goto gotError; } @@ -5226,7 +6413,7 @@ TclExecuteByteCode( w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; wResult = w1 + w2; -#ifdef NO_WIDE_TYPE +#ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. */ @@ -5241,7 +6428,7 @@ TclExecuteByteCode( w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; wResult = w1 - w2; -#ifdef NO_WIDE_TYPE +#ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in * sums by looking at the sign bits. As we have a subtraction @@ -5321,8 +6508,7 @@ TclExecuteByteCode( TRACE_APPEND(("EXPONENT OF ZERO\n")); goto exponOfZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); @@ -5340,74 +6526,92 @@ TclExecuteByteCode( /* 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), + TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } /* TODO: Consider peephole opt. */ objResultPtr = TCONST(!b); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 1, 1); } - case INST_BITNOT: + case INST_BITNOT: valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { /* * ... ~$NonInteger => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } if (type1 == TCL_NUMBER_LONG) { l1 = *((const long *) ptr1); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, ~l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, ~l1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } case INST_UMINUS: valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s \n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); case TCL_NUMBER_LONG: l1 = *((const long *) ptr1); if (l1 != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, -l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, -l1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5420,6 +6624,7 @@ TclExecuteByteCode( */ valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { if (*pc == INST_UPLUS) { @@ -5427,14 +6632,16 @@ TclExecuteByteCode( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); goto gotError; } /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + TRACE_APPEND(("not numeric\n")); NEXT_INST_F(1, 0, 0); } if (IsErroringNaNType(type1)) { @@ -5443,17 +6650,20 @@ TclExecuteByteCode( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); + DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); } else { /* * Numeric conversion of NaN -> error. */ - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); + TRACE_APPEND(("ERROR: IEEE floating pt error\n")); + DECACHE_STACK_INFO(); TclExprFloatError(interp, *((const double *) ptr1)); + CACHE_STACK_INFO(); } goto gotError; } @@ -5468,7 +6678,7 @@ TclExecuteByteCode( */ if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { @@ -5483,11 +6693,11 @@ TclExecuteByteCode( valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, new Tcl_Obj\n")); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } @@ -5496,14 +6706,26 @@ TclExecuteByteCode( * ----------------------------------------------------------------- */ + case INST_TRY_CVT_TO_BOOLEAN: + valuePtr = OBJ_AT_TOS; + if (valuePtr->typePtr == &tclBooleanType) { + objResultPtr = TCONST(1); + } else { + int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); + objResultPtr = TCONST(result); + } + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_BREAK: /* DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); */ - TRESULT = TCL_BREAK; + result = TCL_BREAK; cleanup = 0; + TRACE(("=> BREAK!\n")); goto processExceptionReturn; case INST_CONTINUE: @@ -5512,8 +6734,9 @@ TclExecuteByteCode( Tcl_ResetResult(interp); CACHE_STACK_INFO(); */ - TRESULT = TCL_CONTINUE; + result = TCL_CONTINUE; cleanup = 0; + TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; { @@ -5525,7 +6748,7 @@ TclExecuteByteCode( int varIndex, valIndex, continueLoop, j, iterTmpIndex; long i; - case INST_FOREACH_START4: + case INST_FOREACH_START4: /* DEPRECATED */ /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. @@ -5558,13 +6781,14 @@ TclExecuteByteCode( NEXT_INST_F(5, 0, 0); #endif - case INST_FOREACH_STEP4: + case INST_FOREACH_STEP4: /* DEPRECATED */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. */ opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; @@ -5591,8 +6815,8 @@ TclExecuteByteCode( 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)); + TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (listLen > iterNum * numVars) { @@ -5647,9 +6871,9 @@ TclExecuteByteCode( if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); + TRACE_APPEND(( + "ERROR init. index temp %d: %s\n", + varIndex, O2S(Tcl_GetObjResult(interp)))); TclDecrRefCount(listPtr); goto gotError; } @@ -5661,8 +6885,8 @@ TclExecuteByteCode( listTmpIndex++; } } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); + TRACE_APPEND(("%d lists, iter %d, %s loop\n", + numLists, iterNum, (continueLoop? "continue" : "exit"))); /* * Run-time peep-hole optimisation: the compiler ALWAYS follows @@ -5676,6 +6900,200 @@ TclExecuteByteCode( } else { NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); } + + } + { + ForeachInfo *infoPtr; + Tcl_Obj *listPtr, **elements, *tmpPtr; + ForeachVarList *varListPtr; + int numLists, iterMax, listLen, numVars; + int iterTmp, iterNum, listTmpDepth; + int varIndex, valIndex, j; + long i; + + case INST_FOREACH_START: + /* + * Initialize the data for the looping construct, pushing the + * corresponding Tcl_Objs to the stack. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; + TRACE(("%u => ", opnd)); + + /* + * Compute the number of iterations that will be run: iterMax + */ + + iterMax = 0; + listTmpDepth = numLists-1; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + listPtr = OBJ_AT_DEPTH(listTmpDepth); + if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + if (Tcl_IsShared(listPtr)) { + objPtr = TclListObjCopy(NULL, listPtr); + Tcl_IncrRefCount(objPtr); + Tcl_DecrRefCount(listPtr); + OBJ_AT_DEPTH(listTmpDepth) = objPtr; + } + iterTmp = (listLen + (numVars - 1))/numVars; + if (iterTmp > iterMax) { + iterMax = iterTmp; + } + listTmpDepth--; + } + + /* + * Store the iterNum and iterMax in a single Tcl_Obj; we keep a + * nul-string obj with the pointer stored in the ptrValue so that the + * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but + * it will never leave this scope and is read-only. + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0); + tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); + PUSH_OBJECT(tmpPtr); /* iterCounts object */ + + /* + * Store a pointer to the ForeachInfo struct; same dirty trick + * as above + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.otherValuePtr = infoPtr; + PUSH_OBJECT(tmpPtr); /* infoPtr object */ + TRACE_APPEND(("jump to loop step\n")); + + /* + * Jump directly to the INST_FOREACH_STEP instruction; the C code just + * falls through. + */ + + pc += 5 - infoPtr->loopCtTemp; + + case INST_FOREACH_STEP: + /* + * "Step" a foreach loop (i.e., begin its next iteration) by assigning + * the next value list element to each loop var. + */ + + tmpPtr = OBJ_AT_TOS; + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + TRACE(("=> ")); + + tmpPtr = OBJ_AT_DEPTH(1); + iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); + iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2); + + /* + * If some list still has a remaining list element iterate one more + * time. Assign to var the next element from its value list. + */ + + if (iterNum < iterMax) { + /* + * Set the variables and jump back to run the body + */ + + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1); + + listTmpDepth = numLists + 1; + + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listPtr = OBJ_AT_DEPTH(listTmpDepth); + TclListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = LOCAL(varIndex); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_APPEND(("ERROR init. index temp %d: %.30s", + varIndex, O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + CACHE_STACK_INFO(); + } + valIndex++; + } + listTmpDepth--; + } + TRACE_APPEND(("jump to loop start\n")); + /* loopCtTemp being 'misused' for storing the jump size */ + NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); + } + + TRACE_APPEND(("loop has no more iterations\n")); +#ifdef TCL_COMPILE_DEBUG + NEXT_INST_F(1, 0, 0); +#else + /* + * FALL THROUGH + */ + pc++; +#endif + + case INST_FOREACH_END: + /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ + tmpPtr = OBJ_AT_TOS; + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + TRACE(("=> loop terminated\n")); + NEXT_INST_V(1, numLists+2, 0); + + case INST_LMAP_COLLECT: + /* + * This instruction is only issued by lmap. The stack is: + * - result + * - infoPtr + * - loop counters + * - valLists + * - collecting obj (unshared) + * The instruction lappends the result to the collecting obj. + */ + + tmpPtr = OBJ_AT_DEPTH(1); + infoPtr = tmpPtr->internalRep.otherValuePtr; + numLists = infoPtr->numLists; + TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); + + objPtr = OBJ_AT_DEPTH(3 + numLists); + Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); + NEXT_INST_F(1, 1, 0); } case INST_BEGIN_CATCH4: @@ -5693,8 +7111,10 @@ TclExecuteByteCode( case INST_END_CATCH: catchTop--; + DECACHE_STACK_INFO(); Tcl_ResetResult(interp); - TRESULT = TCL_OK; + CACHE_STACK_INFO(); + result = TCL_OK; TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); @@ -5712,12 +7132,14 @@ TclExecuteByteCode( NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - TclNewIntObj(objResultPtr, TRESULT); - TRACE(("=> %u\n", TRESULT)); + TclNewIntObj(objResultPtr, result); + TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); case INST_PUSH_RETURN_OPTIONS: - objResultPtr = Tcl_GetReturnOptions(interp, TRESULT); + DECACHE_STACK_INFO(); + objResultPtr = Tcl_GetReturnOptions(interp, result); + CACHE_STACK_INFO(); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); @@ -5733,7 +7155,8 @@ TclExecuteByteCode( if (code < TCL_ERROR || code > TCL_CONTINUE) { code = TCL_CONTINUE + 1; } - NEXT_INST_F(2*code -1, 1, 0); + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); + NEXT_INST_F(2*code-1, 1, 0); } /* @@ -5743,44 +7166,86 @@ TclExecuteByteCode( { int opnd2, allocateDict, done, i, allocdict; - Tcl_Obj *dictPtr, *statePtr, *keyPtr; + 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(("\"%.30s\" => ", O2S(dictPtr))); + if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { + TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", + O2S(dictPtr), 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; + register int found; + opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); + if (*pc == INST_DICT_EXISTS) { + interp2 = NULL; + } if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { + if (*pc == INST_DICT_EXISTS) { + found = 0; + goto afterDictExists; + } TRACE_WITH_OBJ(( - "%u => ERROR tracing dictionary path into \"%s\": ", - opnd, O2S(OBJ_AT_DEPTH(opnd))), + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); goto gotError; } } - if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, + if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { - if (objResultPtr) { - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + if (*pc == INST_DICT_EXISTS) { + found = (objResultPtr ? 1 : 0); + goto afterDictExists; + } + if (!objResultPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; } - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS), - "\" not known in dictionary", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } else if (*pc != INST_DICT_EXISTS) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; } else { - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); + found = 0; } - goto gotError; + afterDictExists: + TRACE_APPEND(("%d\n", found)); + + /* + * The INST_DICT_EXISTS instruction is usually 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). + */ + + JUMP_PEEPHOLE_V(found, 5, opnd+1); + } case INST_DICT_SET: case INST_DICT_UNSET: @@ -5813,14 +7278,14 @@ TclExecuteByteCode( switch (*pc) { case INST_DICT_SET: cleanup = opnd + 1; - TRESULT = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, + 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); - TRESULT = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); - if (TRESULT != TCL_OK) { + result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); + if (result != TCL_OK) { break; } if (valuePtr == NULL) { @@ -5832,16 +7297,16 @@ TclExecuteByteCode( valuePtr = Tcl_DuplicateObj(valuePtr); Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); } - TRESULT = TclIncrObj(interp, valuePtr, value2Ptr); - if (TRESULT == TCL_OK) { - Tcl_InvalidateStringRep(dictPtr); + result = TclIncrObj(interp, valuePtr, value2Ptr); + if (result == TCL_OK) { + TclInvalidateStringRep(dictPtr); } TclDecrRefCount(value2Ptr); } break; case INST_DICT_UNSET: cleanup = opnd; - TRESULT = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, + result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, &OBJ_AT_DEPTH(opnd-1)); break; default: @@ -5849,12 +7314,12 @@ TclExecuteByteCode( Tcl_Panic("Should not happen!"); } - if (TRESULT != TCL_OK) { + if (result != TCL_OK) { if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", - opnd, opnd2), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR updating dictionary: %s\n", + O2S(Tcl_GetObjResult(interp)))); goto checkForCatch; } @@ -5876,8 +7341,7 @@ TclExecuteByteCode( CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -5886,7 +7350,7 @@ TclExecuteByteCode( NEXT_INST_V(10, cleanup, 0); } #endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(9, cleanup, 1); case INST_DICT_APPEND: @@ -5919,6 +7383,7 @@ TclExecuteByteCode( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -5938,6 +7403,16 @@ TclExecuteByteCode( 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: @@ -5957,6 +7432,7 @@ TclExecuteByteCode( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); @@ -5966,8 +7442,19 @@ TclExecuteByteCode( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); 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: @@ -5992,8 +7479,7 @@ TclExecuteByteCode( CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6009,10 +7495,11 @@ TclExecuteByteCode( opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); - searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch)); + searchPtr = ckalloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { - ckfree((char *) searchPtr); + ckfree(searchPtr); + TRACE_ERROR(interp); goto gotError; } TclNewObj(statePtr); @@ -6048,8 +7535,9 @@ TclExecuteByteCode( PUSH_OBJECT(valuePtr); PUSH_OBJECT(keyPtr); } + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); -#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 @@ -6057,70 +7545,17 @@ TclExecuteByteCode( * 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_DONE: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL) { - Tcl_Panic("mis-issued dictDone!"); - } - - if (statePtr->typePtr == &dictIteratorType) { - /* - * First kill the search, and then release the reference to the - * dictionary that we were holding. - */ - - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjDone(searchPtr); - ckfree((char *) searchPtr); - - dictPtr = statePtr->internalRep.twoPtrValue.ptr2; - TclDecrRefCount(dictPtr); - - /* - * Set the internal variable to an empty object to signify that we - * don't hold an iterator. - */ - - TclDecrRefCount(statePtr); - TclNewObj(emptyPtr); - (*LOCAL(opnd)).value.objPtr = emptyPtr; - Tcl_IncrRefCount(emptyPtr); - } - NEXT_INST_F(5, 0, 0); + JUMP_PEEPHOLE_F(done, 5, 0); case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); 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 { @@ -6129,11 +7564,13 @@ TclExecuteByteCode( TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (dictPtr == NULL) { + TRACE_ERROR(interp); goto gotError; } } if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } if (length != duiPtr->length) { @@ -6142,6 +7579,7 @@ TclExecuteByteCode( for (i=0 ; i<length ; i++) { if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], &valuePtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } varPtr = LOCAL(duiPtr->varIndices[i]); @@ -6157,21 +7595,23 @@ TclExecuteByteCode( valuePtr, TCL_LEAVE_ERR_MSG, duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); + TRACE_ERROR(interp); goto gotError; } CACHE_STACK_INFO(); } + TRACE_APPEND(("OK\n")); NEXT_INST_F(9, 0, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); 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 { @@ -6180,17 +7620,22 @@ TclExecuteByteCode( CACHE_STACK_INFO(); } if (dictPtr == NULL) { + TRACE_APPEND(("storage was unset\n")); NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); 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]); @@ -6227,10 +7672,83 @@ TclExecuteByteCode( if (allocdict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } } + TRACE_APPEND(("written back\n")); NEXT_INST_F(9, 1, 0); + + case INST_DICT_EXPAND: + dictPtr = OBJ_UNDER_TOS; + listPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); + if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); + if (objResultPtr == NULL) { + TRACE_ERROR(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_ERROR(interp); + TclDecrRefCount(keysPtr); + goto gotError; + } + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, + TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); + if (varPtr == NULL) { + TRACE_ERROR(interp); + TclDecrRefCount(keysPtr); + goto gotError; + } + DECACHE_STACK_INFO(); + result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1, + objc, objv, keysPtr); + CACHE_STACK_INFO(); + TclDecrRefCount(keysPtr); + if (result != TCL_OK) { + TRACE_ERROR(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_ERROR(interp); + goto gotError; + } + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + DECACHE_STACK_INFO(); + result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, + objc, objv, keysPtr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("OK\n")); + NEXT_INST_F(5, 2, 0); } /* @@ -6239,7 +7757,7 @@ TclExecuteByteCode( */ default: - Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); + Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ /* @@ -6261,7 +7779,7 @@ TclExecuteByteCode( */ processExceptionReturn: -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: opnd = TclGetUInt1AtPtr(pc+1); @@ -6283,50 +7801,50 @@ TclExecuteByteCode( TRACE(("=> ")); } #endif - if ((TRESULT == TCL_CONTINUE) || (TRESULT == TCL_BREAK)) { + 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(TRESULT))); + StringForResultCode(result))); goto abnormalReturn; } if (rangePtr->type == CATCH_EXCEPTION_RANGE) { - TRACE_APPEND(("%s ...\n", StringForResultCode(TRESULT))); + TRACE_APPEND(("%s ...\n", StringForResultCode(result))); goto processCatch; } while (cleanup--) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } - if (TRESULT == TCL_BREAK) { - TRESULT = TCL_OK; + if (result == TCL_BREAK) { + result = TCL_OK; pc = (codePtr->codeStart + rangePtr->breakOffset); TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(TRESULT), + 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(TRESULT))); + StringForResultCode(result))); goto checkForCatch; } - TRESULT = TCL_OK; + result = TCL_OK; pc = (codePtr->codeStart + rangePtr->continueOffset); TRACE_APPEND(("%s, range at %d, new pc %d\n", - StringForResultCode(TRESULT), + StringForResultCode(result), rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); } -#if TCL_COMPILE_DEBUG - if (TAUX.traceInstructions) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { objPtr = Tcl_GetObjResult(interp); - if ((TRESULT != TCL_ERROR) && (TRESULT != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", - TRESULT, O2S(objPtr))); + if ((result != TCL_ERROR) && (result != TCL_RETURN)) { + TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ", + result, O2S(objPtr))); } else { - TRACE_APPEND(("%s, result= \"%s\"\n", - StringForResultCode(TRESULT), O2S(objPtr))); + TRACE_APPEND(("%s, result=\"%.30s\"\n", + StringForResultCode(result), O2S(objPtr))); } } #endif @@ -6338,8 +7856,10 @@ TclExecuteByteCode( */ divideByZero: - Tcl_SetResult(interp, "divide by zero", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); + CACHE_STACK_INFO(); goto gotError; /* @@ -6348,18 +7868,20 @@ TclExecuteByteCode( */ exponOfZero: - Tcl_SetResult(interp, "exponentiation of zero by negative power", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponentiation of zero by negative power", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); + CACHE_STACK_INFO(); /* * Almost all error paths feed through here rather than assigning to - * TRESULT themselves (for a small but consistent saving). + * result themselves (for a small but consistent saving). */ gotError: - TRESULT = TCL_ERROR; + result = TCL_ERROR; /* * Execution has generated an "exception" such as TCL_ERROR. If the @@ -6373,10 +7895,13 @@ TclExecuteByteCode( if (iPtr->execEnvPtr->rewind) { goto abnormalReturn; } - if ((TRESULT == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + const unsigned char *pcBeg; + + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); DECACHE_STACK_INFO(); - Tcl_LogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0); + TclLogCommandInfo(interp, codePtr->source, bytes, + bytes ? length : 0, pcBeg, tosPtr); CACHE_STACK_INFO(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -6387,8 +7912,9 @@ TclExecuteByteCode( */ while (auxObjList) { - if ((catchTop != initCatchTop) && (*catchTop > - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) { + if ((catchTop != initCatchTop) + && (*catchTop > (ptrdiff_t) + auxObjList->internalRep.ptrAndLongRep.value)) { break; } POP_TAUX_OBJ(); @@ -6403,11 +7929,11 @@ TclExecuteByteCode( * already be set prior to vectoring down to this point in the code. */ - if (Tcl_Canceled(interp, 0) == TCL_ERROR) { + if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { #ifdef TCL_COMPILE_DEBUG - if (TAUX.traceInstructions) { + if (traceInstructions) { fprintf(stdout, " ... cancel with unwind, returning %s\n", - StringForResultCode(TRESULT)); + StringForResultCode(result)); } #endif goto abnormalReturn; @@ -6421,18 +7947,18 @@ TclExecuteByteCode( if (TclLimitExceeded(iPtr->limit)) { #ifdef TCL_COMPILE_DEBUG - if (TAUX.traceInstructions) { + if (traceInstructions) { fprintf(stdout, " ... limit exceeded, returning %s\n", - StringForResultCode(TRESULT)); + StringForResultCode(result)); } #endif goto abnormalReturn; } if (catchTop == initCatchTop) { #ifdef TCL_COMPILE_DEBUG - if (TAUX.traceInstructions) { + if (traceInstructions) { fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(TRESULT)); + StringForResultCode(result)); } #endif goto abnormalReturn; @@ -6446,9 +7972,9 @@ TclExecuteByteCode( */ #ifdef TCL_COMPILE_DEBUG - if (TAUX.traceInstructions) { + if (traceInstructions) { fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(TRESULT)); + StringForResultCode(result)); } #endif goto abnormalReturn; @@ -6468,7 +7994,7 @@ TclExecuteByteCode( TclDecrRefCount(valuePtr); } #ifdef TCL_COMPILE_DEBUG - if (TAUX.traceInstructions) { + if (traceInstructions) { fprintf(stdout, " ... found catch at %d, catchTop=%d, " "unwound to %ld, new pc %u\n", rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1), @@ -6492,18 +8018,6 @@ TclExecuteByteCode( TCL_DTRACE_INST_LAST(); /* - * Winding down: insure that all pending cleanups are done before - * dropping out of this bytecode. - */ - if (TOP_CB(interp) != BP->rootPtr) { - TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); - - if (TOP_CB(interp) != BP->rootPtr) { - Tcl_Panic("Abnormal return with busy callback stack"); - } - } - - /* * Clear all expansions and same-level NR calls. * * Note that expansion markers have a NULL type; avoid removing other @@ -6520,66 +8034,61 @@ TclExecuteByteCode( if (tosPtr < initTosPtr) { fprintf(stderr, - "\nTclExecuteByteCode: abnormal return at pc %u: " + "\nTclNRExecuteByteCode: abnormal return at pc %u: " "stack top %d < entry stack top %d\n", (unsigned)(pc - codePtr->codeStart), (unsigned) CURR_DEPTH, (unsigned) 0); - Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top"); + Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); } CLANG_ASSERT(bcFramePtr); } - /* - * Store the previous bottomPtr for returning to it, then free all - * resources used by this bytecode and process callbacks until you return - * to the previous bytecode (if any). - */ - - OBP = BP->prevBottomPtr; iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclStackFree(interp, BP); /* free my stack */ - if (--codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } + TclStackFree(interp, TD); /* free my stack */ - returnToCaller: - if (OBP) { - BP = OBP; /* back to old bc */ - TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); + return result; - NR_DATA_DIG(); - if (TOP_CB(interp) == BP->rootPtr) { - /* - * The bytecode is returning, all callbacks were run: keep - * processing the caller. - */ + /* + * INST_START_CMD failure case removed where it doesn't bother that much + * + * Remark that if the interpreter is marked for deletion its + * compileEpoch is modified, so that the epoch check also verifies + * that the interp is not deleted. If no outside call has been made + * since the last check, it is safe to omit the check. - goto nonRecursiveCallReturn; - } else { - TEOV_callback *callbackPtr = TOP_CB(iPtr); - int type = PTR2INT(callbackPtr->data[0]); + * case INST_START_CMD: + */ - NRE_ASSERT(TOP_CB(interp)->procPtr == NRCallTEBC); - NRE_ASSERT(TRESULT == TCL_OK); + instStartCmdFailed: + { + const char *bytes; - switch (type) { - case TCL_NR_BC_TYPE: - /* - * One of the callbacks requested a new execution: a tailcall! - * Start the new bytecode. - */ + checkInterp = 1; + length = 0; - goto nonRecursiveCallSetup; - default: - Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); + /* + * 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; } - } - } - iPtr->execEnvPtr->bottomPtr = NULL; - return TRESULT; + codePtr->flags |= TCL_BYTECODE_RECOMPILE; + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); + opnd = TclGetUInt4AtPtr(pc+1); + pc += (opnd-1); + PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); + goto instEvalStk; + } } + +#undef codePtr #undef iPtr #undef bcFramePtr #undef initCatchTop @@ -6587,6 +8096,58 @@ TclExecuteByteCode( #undef auxObjList #undef catchTop #undef TCONST + +static int +FinalizeOONext( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[2]); + contextPtr->skip = PTR2INT(data[3]); + contextPtr->oPtr->flags &= ~FILTER_HANDLING; + return result; +} + +static int +FinalizeOONextFilter( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[2]); + contextPtr->skip = PTR2INT(data[3]); + contextPtr->oPtr->flags |= FILTER_HANDLING; + return result; +} /* *---------------------------------------------------------------------- @@ -6683,7 +8244,7 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); if (type2 != TCL_NUMBER_BIG) { @@ -6758,7 +8319,7 @@ ExecuteExtendedBinaryMathOp( case TCL_NUMBER_LONG: invalid = (*((const long *)ptr2) < 0L); break; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; @@ -6773,7 +8334,8 @@ ExecuteExtendedBinaryMathOp( invalid = 0; } if (invalid) { - Tcl_SetResult(interp, "negative shift argument", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "negative shift argument", -1)); return GENERAL_ARITHMETIC_ERROR; } @@ -6803,8 +8365,8 @@ ExecuteExtendedBinaryMathOp( * place to draw the line. */ - Tcl_SetResult(interp, "integer value too large to represent", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } shift = (int)(*((const long *)ptr2)); @@ -6841,7 +8403,7 @@ ExecuteExtendedBinaryMathOp( case TCL_NUMBER_LONG: zero = (*(const long *)ptr1 > 0L); break; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; @@ -6862,7 +8424,7 @@ ExecuteExtendedBinaryMathOp( } shift = (int)(*(const long *)ptr2); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ @@ -7045,7 +8607,7 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); @@ -7123,7 +8685,7 @@ ExecuteExtendedBinaryMathOp( negativeExponent = (l2 < 0); oddExponent = (int) (l2 & 1); break; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); @@ -7205,7 +8767,8 @@ ExecuteExtendedBinaryMathOp( */ if (type2 != TCL_NUMBER_LONG) { - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } @@ -7314,7 +8877,7 @@ ExecuteExtendedBinaryMathOp( #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) if (type1 == TCL_NUMBER_LONG) { w1 = l1; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG } else if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); #endif @@ -7443,7 +9006,8 @@ ExecuteExtendedBinaryMathOp( Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if (big2.used > 1) { mp_clear(&big2); - Tcl_SetResult(interp, "exponent too large", TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -7516,7 +9080,7 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = w1 + w2; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif { @@ -7532,7 +9096,7 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif { @@ -7658,7 +9222,7 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); @@ -7680,7 +9244,7 @@ ExecuteExtendedUnaryMathOp( } TclBNInitBignumFromLong(&big, *(const long *) ptr); break; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); if (w != LLONG_MIN) { @@ -7732,7 +9296,7 @@ TclCompareTwoNumbers( mp_int big1, big2; double d1, d2, tmp; long l1, l2; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; #endif @@ -7747,7 +9311,7 @@ TclCompareTwoNumbers( l2 = *((const long *)ptr2); longCompare: return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); w1 = (Tcl_WideInt)l1; @@ -7799,7 +9363,7 @@ TclCompareTwoNumbers( return compare; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { @@ -7860,7 +9424,7 @@ TclCompareTwoNumbers( } l1 = (long) d1; goto longCompare; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; @@ -7904,7 +9468,7 @@ TclCompareTwoNumbers( case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: #endif case TCL_NUMBER_LONG: @@ -7952,7 +9516,7 @@ TclCompareTwoNumbers( * PrintByteCodeInfo -- * * This procedure prints a summary about a bytecode object to stdout. It - * is called by TclExecuteByteCode when starting to execute the bytecode + * is called by TclNRExecuteByteCode when starting to execute the bytecode * object if tclTraceExec has the value 2 or more. * * Results: @@ -8013,7 +9577,7 @@ PrintByteCodeInfo( * * ValidatePcAndStackTop -- * - * This procedure is called by TclExecuteByteCode when debugging to + * This procedure is called by TclNRExecuteByteCode when debugging to * verify that the program counter and stack top are valid during * execution. * @@ -8037,11 +9601,10 @@ ValidatePcAndStackTop( int stackTop, /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ - int stackLowerBound, /* Smallest legal value for stackTop. */ int checkStack) /* 0 if the stack depth check should be * skipped. */ { - int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; + int stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ unsigned relativePc = (unsigned) (pc - codePtr->codeStart); unsigned long codeStart = (unsigned long) codePtr->codeStart; @@ -8050,22 +9613,22 @@ ValidatePcAndStackTop( unsigned char opCode = *pc; if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { - fprintf(stderr, "\nBad instruction pc 0x%p in TclExecuteByteCode\n", + fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", pc); - Tcl_Panic("TclExecuteByteCode execution failure: bad pc"); + Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } if ((unsigned) opCode > LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", + fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n", (unsigned) opCode, relativePc); - Tcl_Panic("TclExecuteByteCode execution failure: bad opcode"); + Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } - if (checkStack && - ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { + if (checkStack && + ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); - fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", - stackTop, relativePc, stackLowerBound, stackUpperBound); + fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", + stackTop, relativePc, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message; @@ -8077,7 +9640,7 @@ ValidatePcAndStackTop( } else { fprintf(stderr, "\n"); } - Tcl_Panic("TclExecuteByteCode execution failure: bad stack top"); + Tcl_Panic("TclNRExecuteByteCode execution failure: bad stack top"); } } #endif /* TCL_COMPILE_DEBUG */ @@ -8087,7 +9650,7 @@ ValidatePcAndStackTop( * * IllegalExprOperandType -- * - * Used by TclExecuteByteCode to append an error message to the interp + * Used by TclNRExecuteByteCode to append an error message to the interp * result when an illegal operand type is detected by an expression * instruction. The argument opndPtr holds the operand object in error. * @@ -8112,10 +9675,12 @@ IllegalExprOperandType( ClientData ptr; int type; const unsigned char opcode = *pc; - const char *description, *operator = operatorStrings[opcode - INST_LOR]; + const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { operator = "**"; + } else if (opcode <= INST_STR_NEQ) { + operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { @@ -8146,7 +9711,7 @@ IllegalExprOperandType( /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd -- + * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -8167,16 +9732,26 @@ IllegalExprOperandType( *---------------------------------------------------------------------- */ -const char * -TclGetSrcInfoForCmd( - Interp *iPtr, - int *lenPtr) +Tcl_Obj * +TclGetSourceFromFrame( + CmdFrame *cfPtr, + int objc, + Tcl_Obj *const objv[]) { - CmdFrame *cfPtr = iPtr->cmdFramePtr; - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - - return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr); + if (cfPtr == NULL) { + return Tcl_NewListObj(objc, objv); + } + if (cfPtr->cmdObj == NULL) { + if (cfPtr->cmd == NULL) { + ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + + cfPtr->cmd = GetSrcInfoForPc((unsigned char *) + cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); + } + cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); + Tcl_IncrRefCount(cfPtr->cmdObj); + } + return cfPtr->cmdObj; } void @@ -8185,13 +9760,16 @@ TclGetSrcInfoForPc( { ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - if (cfPtr->cmd.str.cmd == NULL) { - cfPtr->cmd.str.cmd = GetSrcInfoForPc( + assert(cfPtr->type == TCL_LOCATION_BC); + + if (cfPtr->cmd == NULL) { + + cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len); + &cfPtr->len, NULL, NULL); } - if (cfPtr->cmd.str.cmd != NULL) { + if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. @@ -8208,7 +9786,7 @@ TclGetSrcInfoForPc( return; } - srcOffset = cfPtr->cmd.str.cmd - codePtr->source; + srcOffset = cfPtr->cmd - codePtr->source; eclPtr = Tcl_GetHashValue(hePtr); for (i=0; i < eclPtr->nuloc; i++) { @@ -8239,15 +9817,21 @@ TclGetSrcInfoForPc( static const char * GetSrcInfoForPc( - const unsigned char *pc, /* The program counter value for which to + const unsigned char *pc, /* The program counter value for which to * return the closest command's source info. - * This points to a bytecode instruction in - * codePtr's code. */ + * This points within a bytecode instruction + * in codePtr's code. */ ByteCode *codePtr, /* The bytecode sequence in which to look up * the command source for the pc. */ - int *lengthPtr) /* If non-NULL, the location where the length + int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ + const unsigned char **pcBeg,/* If non-NULL, the bytecode location + * where the current instruction starts. + * If NULL; no pointer is stored. */ + int *cmdIdxPtr) /* If non-NULL, the location where the index + * of the command containing the pc should + * be stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -8257,8 +9841,10 @@ GetSrcInfoForPc( int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + int bestCmdIdx = -1; if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + if (pcBeg != NULL) *pcBeg = NULL; return NULL; } @@ -8323,10 +9909,28 @@ GetSrcInfoForPc( bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; + bestCmdIdx = i; } } } + if (pcBeg != NULL) { + const unsigned char *curr, *prev; + + /* + * Walk from beginning of command or BC to pc, by complete + * instructions. Stop when crossing pc; keep previous. + */ + + curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist); + prev = curr; + while (curr <= pc) { + prev = curr; + curr += tclInstructionTable[*curr].numBytes; + } + *pcBeg = prev; + } + if (bestDist == INT_MAX) { return NULL; } @@ -8334,6 +9938,11 @@ GetSrcInfoForPc( if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } + + if (cmdIdxPtr != NULL) { + *cmdIdxPtr = bestCmdIdx; + } + return (codePtr->source + bestSrcOffset); } @@ -8411,7 +10020,7 @@ GetExceptRangeForPc( * GetOpcodeName -- * * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used - * in TclExecuteByteCode when debugging. It returns the name of the + * in TclNRExecuteByteCode when debugging. It returns the name of the * bytecode instruction at a specified instruction pc. * * Results: @@ -8556,9 +10165,13 @@ EvalStatsCmd( 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) { @@ -8589,65 +10202,65 @@ EvalStatsCmd( * Summary statistics, total and current source and ByteCode sizes. */ - fprintf(stdout, "\n----------------------------------------------------------------\n"); - fprintf(stdout, - "Compilation and execution statistics for interpreter 0x%p\n", - iPtr); + Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); + Tcl_AppendPrintfToObj(objPtr, + "Compilation and execution statistics for interpreter %#lx\n", + (long int)iPtr); - fprintf(stdout, "\nNumber ByteCodes executed\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n", statsPtr->numExecutions); - fprintf(stdout, "Number ByteCodes compiled\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n", statsPtr->numCompilations); - fprintf(stdout, " Mean executions/compile\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", statsPtr->numExecutions / (float)statsPtr->numCompilations); - fprintf(stdout, "\nInstructions executed\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed\t\t%.0f\n", numInstructions); - fprintf(stdout, " Mean inst/compile\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile\t\t%.0f\n", numInstructions / statsPtr->numCompilations); - fprintf(stdout, " Mean inst/execution\t\t%.0f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", numInstructions / statsPtr->numExecutions); - fprintf(stdout, "\nTotal ByteCodes\t\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n", statsPtr->numCompilations); - fprintf(stdout, " Source bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->totalSrcBytes); - fprintf(stdout, " Code bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", totalCodeBytes); - fprintf(stdout, " ByteCode bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", statsPtr->totalByteCodeBytes); - fprintf(stdout, " Literal bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", totalLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + 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); - fprintf(stdout, " Mean code/compile\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", totalCodeBytes / statsPtr->numCompilations); - fprintf(stdout, " Mean code/source\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - fprintf(stdout, "\nCurrent (active) ByteCodes\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n", numCurrentByteCodes); - fprintf(stdout, " Source bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->currentSrcBytes); - fprintf(stdout, " Code bytes\t\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n", currentCodeBytes); - fprintf(stdout, " ByteCode bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n", statsPtr->currentByteCodeBytes); - fprintf(stdout, " Literal bytes\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", currentLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + 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); - fprintf(stdout, " Mean code/source\t\t%.1f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); - fprintf(stdout, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", + Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n", (currentCodeBytes + statsPtr->currentSrcBytes), (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); @@ -8659,18 +10272,18 @@ EvalStatsCmd( */ numSharedMultX = 0; - fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); - fprintf(stdout, " Object had refcount <=1 (not shared)\t%ld\n", + 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++) { - fprintf(stdout, " refcount ==%d\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - fprintf(stdout, " refcount >=%d\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - fprintf(stdout, " Total shared objects\t\t\t%d\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n", numSharedMultX); /* @@ -8707,48 +10320,48 @@ EvalStatsCmd( sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - fprintf(stdout, "\nTotal objects (all interps)\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n", tclObjsAlloced); - fprintf(stdout, "Current objects\t\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n", (tclObjsAlloced - tclObjsFreed)); - fprintf(stdout, "Total literal objects\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n", statsPtr->numLiteralsCreated); - fprintf(stdout, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - fprintf(stdout, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", numByteCodeLits, Percent(numByteCodeLits, globalTablePtr->numEntries)); - fprintf(stdout, " Literals reused > 1x\t\t%d\n", + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n", numSharedMultX); - fprintf(stdout, " Mean reference count\t\t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); - fprintf(stdout, " Mean len, str reused >1x \t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x \t%.2f\n", (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0)); - fprintf(stdout, " Mean len, str used 1x\t\t%.2f\n", + Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x\t\t%.2f\n", (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0)); - fprintf(stdout, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Total sharing savings\t\t%.6g (%0.1f%% of bytes if no sharing)\n", sharingBytesSaved, Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared)); - fprintf(stdout, " Bytes with sharing\t\t%.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing\t\t%.6g\n", currentLiteralBytes); - fprintf(stdout, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", + 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); - fprintf(stdout, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing\t\t%.6g = objects %.6g + strings %.6g\n", (objBytesIfUnshared + strBytesIfUnshared), objBytesIfUnshared, strBytesIfUnshared); - fprintf(stdout, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - fprintf(stdout, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, Percent(literalMgmtBytes, currentLiteralBytes)); - fprintf(stdout, " table %lu + buckets %lu + entries %lu\n", + 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))); @@ -8757,33 +10370,33 @@ EvalStatsCmd( * Breakdown of current ByteCode space requirements. */ - fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); - fprintf(stdout, " Bytes Pct of Avg per\n"); - fprintf(stdout, " total ByteCode\n"); - fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", + 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); - fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n", currentHeaderBytes, Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes), currentHeaderBytes / numCurrentByteCodes); - fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n", statsPtr->currentInstBytes, Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes), statsPtr->currentInstBytes / numCurrentByteCodes); - fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n", statsPtr->currentLitBytes, Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes), statsPtr->currentLitBytes / numCurrentByteCodes); - fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n", statsPtr->currentExceptBytes, Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes), statsPtr->currentExceptBytes / numCurrentByteCodes); - fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n", statsPtr->currentAuxBytes, Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes), statsPtr->currentAuxBytes / numCurrentByteCodes); - fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", + Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n", statsPtr->currentCmdMapBytes, Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes), statsPtr->currentCmdMapBytes / numCurrentByteCodes); @@ -8792,8 +10405,8 @@ EvalStatsCmd( * Detailed literal statistics. */ - fprintf(stdout, "\nLiteral string sizes:\n"); - fprintf(stdout, "\t Up to length\t\tPercentage\n"); + 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) { @@ -8805,21 +10418,21 @@ EvalStatsCmd( for (i = 0; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->literalCount[i]; - fprintf(stdout, "\t%10d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } litTableStats = TclLiteralStats(globalTablePtr); - fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); - ckfree((char *) litTableStats); + ckfree(litTableStats); /* * Source and ByteCode size distributions. */ - fprintf(stdout, "\nSource sizes:\n"); - fprintf(stdout, "\t Up to size\t\tPercentage\n"); + 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) { @@ -8837,12 +10450,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->srcCount[i]; - fprintf(stdout, "\t%10d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } - fprintf(stdout, "\nByteCode sizes:\n"); - fprintf(stdout, "\t Up to size\t\tPercentage\n"); + 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) { @@ -8860,12 +10473,12 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->byteCodeCount[i]; - fprintf(stdout, "\t%10d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } - fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); - fprintf(stdout, "\t Up to ms\t\tPercentage\n"); + 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) { @@ -8883,7 +10496,7 @@ EvalStatsCmd( for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; sum += statsPtr->lifetimeCount[i]; - fprintf(stdout, "\t%12.3f\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); } @@ -8891,28 +10504,46 @@ EvalStatsCmd( * Instruction counts. */ - fprintf(stdout, "\nInstruction counts:\n"); + Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s %8ld %6.1f%%\n", - tclInstructionTable[i].name, - statsPtr->instructionCount[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)); - } - } - - fprintf(stdout, "\nInstructions NEVER executed:\n"); - for (i = 0; i <= LAST_INST_OPCODE; i++) { - if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s\n", tclInstructionTable[i].name); + } else { + Tcl_AppendPrintfToObj(objPtr, "0\n"); } } #ifdef TCL_MEM_DEBUG - fprintf(stdout, "\nHeap Statistics:\n"); - TclDumpMemoryInfo(stdout); + Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n"); + TclDumpMemoryInfo((ClientData) objPtr, 1); #endif - fprintf(stdout, "\n----------------------------------------------------------------\n"); + 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 */ |