diff options
-rw-r--r-- | ChangeLog | 28 | ||||
-rw-r--r-- | generic/tclAssembly.c | 5 | ||||
-rw-r--r-- | generic/tclBasic.c | 327 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 19 | ||||
-rw-r--r-- | generic/tclCompExpr.c | 6 | ||||
-rw-r--r-- | generic/tclCompile.c | 10 | ||||
-rw-r--r-- | generic/tclCompile.h | 9 | ||||
-rw-r--r-- | generic/tclExecute.c | 847 | ||||
-rw-r--r-- | generic/tclInt.decls | 4 | ||||
-rw-r--r-- | generic/tclInt.h | 9 | ||||
-rw-r--r-- | generic/tclIntDecls.h | 6 | ||||
-rw-r--r-- | generic/tclOOMethod.c | 61 | ||||
-rw-r--r-- | generic/tclObj.c | 4 | ||||
-rw-r--r-- | generic/tclProc.c | 6 | ||||
-rw-r--r-- | generic/tclTest.c | 6 | ||||
-rw-r--r-- | generic/tclVar.c | 7 |
16 files changed, 527 insertions, 827 deletions
@@ -1,14 +1,42 @@ 2010-09-27 Kevin B. Kenny <kennykb@acm.org> + [dogeen-assembler-branch] + * tests/assemble.test: Added more "white box" tests. * generic/tclAssembly.c: Fixed bugs exposed by the new tests. (a) [eval] and [expr] had incorrect stack balance computed if the arg was not a simple word. (b) [concat] accepted a negative operand count. (c) [invoke] accepted a zero or negative operand count. (d) more misspelt error messages. + Also replaced a funky NRCallTEBC with the new call + TclNRExecuteByteCode, necessitated by a merge with changes on the + HEAD. + +2010-09-26 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic.c: [Patch 3072080] (minus the itcl + * generic/tclCmdIL.c: update): a saner NRE. + * generic/tclCompExpr.c: + * generic/tclCompile.c: This makes TclNRExecuteByteCode + * generic/tclCompile.h: (ex TEBC) to be a normal NRE + * generic/tclExecute.c: citizen: it loses its special status. + * generic/tclInt.decls: The logic flow within the BC engine is + * generic/tclInt.h: simplified considerably. + * generic/tclIntDecls.h: + * generic/tclObj.c: + * generic/tclProc.c: + * generic/tclTest.c: + + * generic/tclVar.c: use the macro HasLocalVars everywhere + + * generic/tclOOMethod.c (ProcedureMethodVarResolver): avoid code + duplication, let the runtime var resolver call the compiled var + resolver. 2010-09-26 Kevin B. Kenny <kennykb@acm.org> + [dogeen-assembler-branch] + * tests/assemble.test: Added many new tests moving toward a more comprehensive test suite for the assembler. * generic/tclAssembly.c: Fixed bugs exposed by the new tests: diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 660f101..4735a59 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -533,10 +533,13 @@ TclNRAssembleObjCmd( /* Use NRE to evaluate the bytecode from the trampoline */ + /* Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, NULL, NULL); - return TCL_OK; + */ + return TclNRExecuteByteCode(interp, codePtr); + } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1413f66..1937ccc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.465.2.1 2010/09/21 19:32:26 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.465.2.2 2010/09/27 20:33:37 kennykb Exp $ */ #include "tclInt.h" @@ -135,6 +135,7 @@ static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); +static Tcl_NRPostProc NRCoroutineActivateCallback; static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRRunObjProc; @@ -175,6 +176,9 @@ MODULE_SCOPE const TclStubs tclStubs; * after particular kinds of [yield]. */ +#define CORO_ACTIVATE_YIELD PTR2INT(NULL) +#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 + #define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) #define COROUTINE_ARGUMENTS_ARBITRARY (-2) @@ -817,7 +821,7 @@ Tcl_CreateInterp(void) Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL, TclNRYieldToObjCmd, NULL, NULL); Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL, - TclNRYieldmObjCmd, NULL, NULL); + TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL); #ifdef USE_DTRACE /* @@ -3056,7 +3060,7 @@ Tcl_DeleteCommandFromToken( * from a CmdName Tcl object in some ByteCode code sequence. In that case, * delay the cleanup until all references are either discarded (when a * ByteCode is freed) or replaced by a new reference (when a cached - * CmdName Command reference is found to be invalid and TclExecuteByteCode + * CmdName Command reference is found to be invalid and TclNRExecuteByteCode * looks up the command in the command hashtable). */ @@ -4102,7 +4106,7 @@ Tcl_EvalObjv( TEOV_callback *rootPtr = TOP_CB(interp); result = TclNREvalObjv(interp, objc, objv, flags, NULL); - return TclNRRunCallbacks(interp, result, rootPtr, 0); + return TclNRRunCallbacks(interp, result, rootPtr); } int @@ -4286,11 +4290,9 @@ int TclNRRunCallbacks( Tcl_Interp *interp, int result, - struct TEOV_callback *rootPtr, + struct TEOV_callback *rootPtr) /* All callbacks down to rootPtr not inclusive * are to be run. */ - int tebcCall) /* Normal callers set this to 0; only TEBC - * sets it to 1. */ { Interp *iPtr = (Interp *) interp; TEOV_callback *callbackPtr; @@ -4312,23 +4314,7 @@ TclNRRunCallbacks( while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); - procPtr = callbackPtr->procPtr; - - if (tebcCall && (procPtr == NRCallTEBC)) { - NRE_ASSERT(result==TCL_OK); - return TCL_OK; - } - - /* - * IMPLEMENTATION REMARKS (FIXME) - * - * Add here other direct handling possibilities for optimisation? One - * could handle the very frequent NRCommand and NRRunObjProc right - * here to save an indirect function call and improve icache - * management. Would it? Test it, time it ... - */ - TOP_CB(interp) = callbackPtr->nextPtr; result = procPtr(callbackPtr->data, interp, result); TCLNR_FREE(interp, callbackPtr); @@ -4388,41 +4374,6 @@ NRRunObjProc( return result; } -int -NRCallTEBC( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* - * This is not run normally, the callback is passed up to tebc. This - * function is only called when no tebc is above. - */ - - int type = PTR2INT(data[0]); - Interp *iPtr = ((Interp *) interp); - - NRE_ASSERT(result == TCL_OK); - - switch (type) { - case TCL_NR_BC_TYPE: - return TclExecuteByteCode(interp, data[1]); - case TCL_NR_YIELD_TYPE: - if (iPtr->execEnvPtr->corPtr) { - Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", NULL); - } else { - Tcl_SetResult(interp, "yield can only be called in a coroutine", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", - NULL); - } - return TCL_ERROR; - default: - Tcl_Panic("unknown call type to TEBC"); - } - return result; /* not reached */ -} /* *---------------------------------------------------------------------- @@ -5940,7 +5891,7 @@ TclEvalObjEx( TEOV_callback *rootPtr = TOP_CB(interp); result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); - return TclNRRunCallbacks(interp, result, rootPtr, 0); + return TclNRRunCallbacks(interp, result, rootPtr); } int @@ -6067,9 +6018,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, objPtr, INT2PTR(allowExceptions), NULL); - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, - NULL, NULL); - return TCL_OK; + return TclNRExecuteByteCode(interp, codePtr); } { @@ -8173,7 +8122,7 @@ Tcl_NRCallObjProc( (Tcl_Obj **)(objv + 1)); } result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr, 0); + return TclNRRunCallbacks(interp, result, rootPtr); } /* @@ -8487,8 +8436,6 @@ TclNRYieldObjCmd( Tcl_Obj *const objv[]) { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - int numLevels = iPtr->numLevels; - if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); return TCL_ERROR; @@ -8505,38 +8452,13 @@ TclNRYieldObjCmd( Tcl_SetObjResult(interp, objv[1]); } - iPtr->numLevels = corPtr->auxNumLevels; - corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; - corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; - - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE), - NULL, NULL, NULL); + NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); + TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + clientData, NULL, NULL); return TCL_OK; } int -TclNRYieldmObjCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - int result; - - if (!corPtr) { - Tcl_SetResult(interp, "yieldm can only be called in a coroutine", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); - return TCL_ERROR; - } - - result = TclNRYieldObjCmd(clientData, interp, objc, objv); - corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; - return result; -} - -int TclNRYieldToObjCmd( ClientData clientData, Tcl_Interp *interp, @@ -8630,7 +8552,6 @@ RewindCoroutine( NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); NRE_ASSERT(corPtr->eePtr != NULL); - NRE_ASSERT(corPtr->eePtr->bottomPtr != NULL); NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr); corPtr->eePtr->rewind = 1; @@ -8648,7 +8569,7 @@ DeleteCoroutine( TEOV_callback *rootPtr = TOP_CB(interp); if (COR_IS_SUSPENDED(corPtr)) { - TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr, 0); + TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr); } } @@ -8684,7 +8605,7 @@ NRCoroutineCallerCallback( NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); - + if (cmdPtr->flags & CMD_IS_DELETED) { /* * The command was deleted while it was running: wind down the @@ -8724,17 +8645,10 @@ NRCoroutineExitCallback( TclCleanupCommandMacro(cmdPtr); corPtr->eePtr->corPtr = NULL; - TclPopStackFrame(interp); TclDeleteExecEnv(corPtr->eePtr); corPtr->eePtr = NULL; - RESTORE_CONTEXT(corPtr->caller); - - NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); - NRE_ASSERT(iPtr->varFramePtr = corPtr->caller.varFramePtr); - NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); - - iPtr->execEnvPtr = corPtr->callerEEPtr; + corPtr->stackLevel = NULL; /* * #280. @@ -8742,13 +8656,98 @@ NRCoroutineExitCallback( * command arguments in bytecode. */ - Tcl_DeleteHashTable(corPtr->base.lineLABCPtr); - ckfree((char *) corPtr->base.lineLABCPtr); - corPtr->base.lineLABCPtr = NULL; + Tcl_DeleteHashTable(corPtr->lineLABCPtr); + ckfree((char *) corPtr->lineLABCPtr); + corPtr->lineLABCPtr = NULL; + + RESTORE_CONTEXT(corPtr->caller); + iPtr->execEnvPtr = corPtr->callerEEPtr; + iPtr->numLevels++; return result; } + +/* + * NRCoroutineActivateCallback -- + * + * This is the workhorse for coroutines: it implements both yield and resume. + * + * It is important that both be implemented in the same callback: the + * detection of the impossibility to suspend due to a busy C-stack relies on + * the precise position of a local variable in the stack. We do not want the + * compiler to play tricks on us, either by moving things around or inlining. + */ + +static int +NRCoroutineActivateCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + int type = PTR2INT(data[1]); + int numLevels, unused; + int *stackLevel = &unused; + + if (!corPtr->stackLevel) { + /* + * -- Coroutine is suspended -- + * Push the callback to restore the caller's context on yield or return + */ + + TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, + NULL); + + /* + * Record the stackLevel at which the resume is happening, then swap + * the interp's environment to make it suitable to run this + * coroutine. + */ + + corPtr->stackLevel = stackLevel; + numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = iPtr->numLevels; + + SAVE_CONTEXT(corPtr->caller); + corPtr->callerEEPtr = iPtr->execEnvPtr; + RESTORE_CONTEXT(corPtr->running); + iPtr->execEnvPtr = corPtr->eePtr; + iPtr->numLevels += numLevels; + + return TCL_OK; + } else { + /* + * Coroutine is active: yield + */ + + if (corPtr->stackLevel != stackLevel) { + Tcl_SetResult(interp, "cannot yield: C stack busy", + TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", + NULL); + return TCL_ERROR; + } + + if (type == CORO_ACTIVATE_YIELD) { + corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; + } else if (type == CORO_ACTIVATE_YIELDM) { + corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY; + } else { + Tcl_Panic("Yield received an option which is not implemented"); + } + + corPtr->stackLevel = NULL; + + numLevels = iPtr->numLevels; + iPtr->numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; + + iPtr->execEnvPtr = corPtr->callerEEPtr; + return TCL_OK; + } +} + int NRInterpCoroutine( ClientData clientData, @@ -8757,7 +8756,6 @@ NRInterpCoroutine( Tcl_Obj *const objv[]) /* Argument objects. */ { CoroutineData *corPtr = clientData; - int nestNumLevels = corPtr->auxNumLevels; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_ResetResult(interp); @@ -8798,26 +8796,8 @@ NRInterpCoroutine( break; } - /* - * Swap the interp's environment to make it suitable to run this - * coroutine. TEBC needs no info to resume executing after a suspension: - * the codePtr will be read from the execEnv's saved bottomPtr. - */ - - SAVE_CONTEXT(corPtr->caller); - corPtr->base.framePtr->callerPtr = iPtr->framePtr; - RESTORE_CONTEXT(corPtr->running); - corPtr->auxNumLevels = iPtr->numLevels; - iPtr->numLevels += nestNumLevels; - - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, - NULL); - - corPtr->callerEEPtr = iPtr->execEnvPtr; - iPtr->execEnvPtr = corPtr->eePtr; - - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), NULL, - NULL, NULL); + TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + NULL, NULL, NULL); return TCL_OK; } @@ -8830,11 +8810,9 @@ TclNRCoroutineObjCmd( { Command *cmdPtr; CoroutineData *corPtr; - Tcl_Obj *cmdObjPtr; const char *fullName, *procName; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_DString ds; - Tcl_CallFrame *framePtr; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); @@ -8873,18 +8851,10 @@ TclNRCoroutineObjCmd( /* * We ARE creating the coroutine command: allocate the corresponding - * struct, add the callback in caller's env and record the caller's - * frames. + * struct and create the corresponding command. */ corPtr = (CoroutineData *) ckalloc(sizeof(CoroutineData)); - TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, - NULL); - SAVE_CONTEXT(corPtr->caller); - - /* - * Create the coroutine command. - */ Tcl_DStringInit(&ds); if (nsPtr != iPtr->globalNsPtr) { @@ -8913,84 +8883,59 @@ TclNRCoroutineObjCmd( Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; - corPtr->base.lineLABCPtr = (Tcl_HashTable *) + corPtr->lineLABCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(corPtr->base.lineLABCPtr, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) { int isNew; Tcl_HashEntry *newPtr = - Tcl_CreateHashEntry(corPtr->base.lineLABCPtr, + Tcl_CreateHashEntry(corPtr->lineLABCPtr, Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), &isNew); Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr)); } - - /* - * The new copy is immediately plugged interpreter for use by the - * first coroutine commands (see below). The interp's copy of the - * table is already saved, see the SAVE_CONTEXT found just above this - * whole code block. This also properly prepares us for the - * SAVE/RESTORE dances during yields which swizzle the pointers - * around. - */ - - iPtr->lineLABCPtr = corPtr->base.lineLABCPtr; } /* - * Create the coro's execEnv and switch to it so that any CallFrames or - * callbacks refer to the new execEnv's stack. + * Save the base context. + */ + + corPtr->running.framePtr = iPtr->rootFramePtr; + corPtr->running.varFramePtr = iPtr->rootFramePtr; + corPtr->running.cmdFramePtr = NULL; + corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; + corPtr->stackLevel = NULL; + corPtr->auxNumLevels = 0; + iPtr->numLevels--; + + /* + * Create the coro's execEnv, switch to it to push the exit and coro + * command callbacks, then switch back. */ corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE); corPtr->callerEEPtr = iPtr->execEnvPtr; corPtr->eePtr->corPtr = corPtr; + iPtr->execEnvPtr = corPtr->eePtr; - /* push a base call frame; save the current namespace to do a correct - * command lookup. - */ + TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, + NULL, NULL, NULL); - nsPtr = iPtr->varFramePtr->nsPtr; - TclPushStackFrame(interp, &framePtr, - (Tcl_Namespace *) iPtr->globalNsPtr, 0); - iPtr->varFramePtr = iPtr->rootFramePtr; + iPtr->lookupNsPtr = iPtr->varFramePtr->nsPtr; + Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); + iPtr->execEnvPtr = corPtr->callerEEPtr; /* - * Save the base context. The base cmdFramePtr is unknown at this time: it - * will be allocated in the Tcl stack. So signal TEBC that it has to - * initialize the base cmdFramePtr by setting it to NULL. + * Now just resume the coroutine. Take care to insure that the command is + * looked up in the correct namespace. */ - SAVE_CONTEXT(corPtr->base); - corPtr->base.cmdFramePtr = NULL; - corPtr->running = NULL_CONTEXT; - corPtr->stackLevel = NULL; - corPtr->auxNumLevels = iPtr->numLevels; - - /* - * Create the command that will run at the bottom of the coroutine. - * Be sure not to pass a canonical list for the command so that we insure - * the body is bytecompiled: we need a TEBC instance to handle [yield] - */ - - cmdObjPtr = Tcl_NewListObj(objc-2, &objv[2]); - TclGetString(cmdObjPtr); - TclFreeIntRep(cmdObjPtr); - cmdObjPtr->typePtr = NULL; - - /* - * Add the exit callback, then the callback to eval the coro body - */ - - TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, - NULL, NULL, NULL); - iPtr->lookupNsPtr = nsPtr; - TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0); - + TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + NULL, NULL, NULL); return TCL_OK; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 6c9a623..44a3bf3 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.184 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.184.2.1 2010/09/27 20:33:37 kennykb Exp $ */ #include "tclInt.h" @@ -1155,11 +1155,22 @@ InfoFrameCmd( if (iPtr->execEnvPtr->corPtr) { /* - * A coroutine: must fix the level computations + * A coroutine: must fix the level computations AND the cmdFrame chain, + * which is interrupted at the base. */ - topLevel += iPtr->execEnvPtr->corPtr->caller.cmdFramePtr->level - - iPtr->execEnvPtr->corPtr->base.cmdFramePtr->level; + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + CmdFrame *runPtr = iPtr->cmdFramePtr; + CmdFrame *lastPtr = NULL; + + topLevel += corPtr->caller.cmdFramePtr->level; + while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) { + lastPtr = runPtr; + runPtr = runPtr->nextPtr; + } + if (lastPtr && !runPtr) { + lastPtr->nextPtr = corPtr->caller.cmdFramePtr; + } } if (objc == 1) { diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index eb72a45..ead8f51 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.105 2010/04/29 23:39:32 msofer Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.105.2.1 2010/09/27 20:33:37 kennykb Exp $ */ #include "tclInt.h" @@ -2101,6 +2101,7 @@ ExecConstantExprTree( ByteCode *byteCodePtr; int code; Tcl_Obj *byteCodeObj = Tcl_NewObj(); + TEOV_callback *rootPtr = TOP_CB(interp); /* * Note we are compiling an expression with literal arguments. This means @@ -2118,7 +2119,8 @@ ExecConstantExprTree( TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr; - code = TclExecuteByteCode(interp, byteCodePtr); + TclNRExecuteByteCode(interp, byteCodePtr); + code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); Tcl_DecrRefCount(byteCodeObj); return code; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 0807151..4584d78 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.187 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.187.2.1 2010/09/27 20:33:37 kennykb Exp $ */ #include "tclInt.h" @@ -915,7 +915,7 @@ Tcl_SubstObj( TEOV_callback *rootPtr = TOP_CB(interp); if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags), - rootPtr, 0) != TCL_OK) { + rootPtr) != TCL_OK) { return NULL; } return Tcl_GetObjResult(interp); @@ -949,9 +949,7 @@ Tcl_NRSubstObj( /* TODO: Confirm we do not need this. */ /* Tcl_ResetResult(interp); */ - Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, - NULL, NULL); - return TCL_OK; + return TclNRExecuteByteCode(interp, codePtr); } /* @@ -1651,7 +1649,7 @@ TclCompileScript( * length will be updated later. There is no need to * do this for the first bytecode in the compile env, * as the check is done before calling - * TclExecuteByteCode(). Do emit an INST_START_CMD in + * TclNRExecuteByteCode(). Do emit an INST_START_CMD in * special cases where the first bytecode is in a * loop, to insure that the corresponding command is * counted properly. Compilers for commands able to diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 686f508..e8a40d7 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.126 2010/08/18 15:44:12 msofer Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.126.2.1 2010/09/27 20:33:37 kennykb Exp $ */ #ifndef _TCLCOMPILATION @@ -863,14 +863,9 @@ typedef struct { *---------------------------------------------------------------- */ -MODULE_SCOPE Tcl_NRPostProc NRCallTEBC; MODULE_SCOPE Tcl_NRPostProc NRCommand; MODULE_SCOPE Tcl_ObjCmdProc NRInterpCoroutine; -#define TCL_NR_BC_TYPE 0 -#define TCL_NR_ATEXIT_TYPE 1 -#define TCL_NR_YIELD_TYPE 2 - /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c @@ -923,7 +918,7 @@ MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE int TclExecuteByteCode(Tcl_Interp *interp, +MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2998657..ac11a51 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6,7 +6,7 @@ * 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. @@ -14,7 +14,7 @@ * 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.2.2 2010/09/25 14:51:12 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.494.2.3 2010/09/27 20:33:37 kennykb Exp $ */ #include "tclInt.h" @@ -171,40 +171,29 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { */ typedef struct BottomData { - struct BottomData *prevBottomPtr; - TEOV_callback *rootPtr; /* State when this bytecode execution - * began: */ - ByteCode *codePtr; /* constant until it returns */ + ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ + struct BottomData *expanded;/* NULL if unchanged, pointer to the succesor + * if it was expanded */ 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. */ + int checkInterp; } 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; \ - } 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;\ - } while (0) +#define NR_YIELD(invoke) \ + esPtr->tosPtr = tosPtr; \ + BP->pc = pc; \ + BP->cleanup = cleanup; \ + TclNRAddCallback(interp, TEBCresume, BP, \ + INT2PTR(invoke), NULL, NULL) + +#define NR_DATA_DIG() \ + pc = BP->pc; \ + cleanup = BP->cleanup; \ + tosPtr = esPtr->tosPtr + #define PUSH_TAUX_OBJ(objPtr) \ do { \ @@ -309,19 +298,16 @@ VarHashCreateVar( /* * 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 @@ -353,13 +339,13 @@ VarHashCreateVar( /* * 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 +354,12 @@ VarHashCreateVar( break; \ } # define TRACE_APPEND(a) \ - while (TAUX.traceInstructions) { \ + while (traceInstructions) { \ printf a; \ break; \ } # 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), \ @@ -399,13 +385,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 +401,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) @@ -734,6 +720,9 @@ static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; +static Tcl_NRPostProc TEBCresume; +static Tcl_NRPostProc TEBCreturn; + /* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. @@ -793,7 +782,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 +791,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. * *---------------------------------------------------------------------- */ @@ -826,7 +815,6 @@ TclCreateExecEnv( eePtr->interp = interp; eePtr->callbackPtr = NULL; eePtr->corPtr = NULL; - eePtr->bottomPtr = NULL; eePtr->rewind = 0; esPtr->prevPtr = NULL; @@ -1300,7 +1288,7 @@ Tcl_ExprObj( 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 @@ -1363,9 +1351,7 @@ Tcl_NRExprObj( /*Tcl_ResetResult(interp);*/ Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr, NULL, NULL); - Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, - NULL, NULL); - return TCL_OK; + return TclNRExecuteByteCode(interp, codePtr); } static int @@ -1870,7 +1856,7 @@ TclIncrObj( /* *---------------------------------------------------------------------- * - * TclExecuteByteCode -- + * TclNRExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It * returns when a "done" instruction is executed or an error occurs. @@ -1885,12 +1871,113 @@ TclIncrObj( * *---------------------------------------------------------------------- */ +#define bcFramePtr ((CmdFrame *) (BP + 1)) +#define initCatchTop (((ptrdiff_t *) (bcFramePtr + 1)) - 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; + BottomData *BP; + + if (iPtr->execEnvPtr->rewind) { + return TCL_ERROR; + } + + codePtr->refCount++; + + /* + * Reserve the stack, setup the BottomPtr and CallFrame + * + * 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. + */ + + BP = (BottomData *) GrowEvaluationStack(iPtr->execEnvPtr, + sizeof(BottomData) + codePtr->maxExceptDepth + sizeof(CmdFrame) + + codePtr->maxStackDepth, 0); + esPtr->tosPtr = initTosPtr; + + BP->codePtr = codePtr; + BP->expanded = NULL; + BP->pc = codePtr->codeStart; + BP->catchTop = initCatchTop; + BP->cleanup = 0; + BP->auxObjList = NULL; + BP->checkInterp = 0; + + /* + * 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; + +#ifdef TCL_COMPILE_STATS + iPtr->stats.numExecutions++; +#endif + + /* + * Push the callbacks for + * - exception handling and cleanup + * - bytecode execution + */ + + TclNRAddCallback(interp, TEBCreturn, BP, NULL, + NULL, NULL); + TclNRAddCallback(interp, TEBCresume, BP, + /*resume*/ INT2PTR(0), NULL, NULL); + + return TCL_OK; +} + +static int +TEBCreturn( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + BottomData *BP = data[0]; + ByteCode *codePtr = BP->codePtr; + + if (--codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + while (BP->expanded) { + BP = BP->expanded; + } + TclStackFree(interp, BP); /* free my stack */ + + return result; +} + +static int +TEBCresume( + ClientData data[], + Tcl_Interp *interp, + int result) +{ /* * Compiler cast directive - not a real variable. * Interp *iPtr = (Interp *) interp; @@ -1915,62 +2002,40 @@ TclExecuteByteCode( * 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) +#define LOCAL(i) (&iPtr->varFramePtr->compiledLocals[(i)]) +#define TCONST(i) (iPtr->execEnvPtr->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)) + BottomData *BP = data[0]; #define auxObjList (BP->auxObjList) #define catchTop (BP->catchTop) +#define codePtr (BP->codePtr) +#define checkInterp (BP->checkInterp) + /* Indicates when a check of interp readyness + * is necessary. Set by CACHE_STACK_INFO() */ /* * Globals: variables that store state, must remain valid at all times. */ - Tcl_Obj **tosPtr = NULL; /* Cached pointer to top of evaluation - * stack. */ - const unsigned char *pc = NULL; - /* The current program counter. */ + Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation + * stack. */ + const unsigned char *pc; /* The current program counter. */ + +#ifdef TCL_COMPILE_DEBUG + traceInstructions = (tclTraceExec == 3); +#endif /* * Transfer variables - needed only between opcodes, but not while @@ -1994,120 +2059,80 @@ TclExecuteByteCode( char cmdNameBuf[21]; #endif - TAUX.constants = &iPtr->execEnvPtr->constants[0]; - if (!codePtr) { - CoroutineData *corPtr; + NR_DATA_DIG(); - 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)); +#ifdef TCL_COMPILE_DEBUG + if (!data[1] && (tclTraceExec >= 2)) { + PrintByteCodeInfo(codePtr); + fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); + fflush(stdout); + } +#endif + if (data[1] /* resume from invocation */) { if (iPtr->execEnvPtr->rewind) { - TRESULT = TCL_ERROR; + result = TCL_ERROR; + } + NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); + NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn); + iPtr->cmdFramePtr = bcFramePtr->nextPtr; + TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + + if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { + iPtr->flags |= ERR_ALREADY_LOGGED; + codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - 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); + CACHE_STACK_INFO(); + if (result == TCL_OK) { +#ifndef TCL_COMPILE_DEBUG + if (*pc == INST_POP) { + NEXT_INST_V(1, cleanup, 0); + } #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 + * Push the call's object result and continue execution with + * the next instruction. */ - - corPtr->base.cmdFramePtr = bcFramePtr; - corPtr->callerBPPtr = &BP->prevBottomPtr; - corPtr->stackLevel = &TAUX; - } - - if (iPtr->execEnvPtr->rewind) { - TRESULT = TCL_ERROR; - goto abnormalReturn; + + 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); } + + /* + * Result not TCL_OK: fall through + */ } - -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); - fflush(stdout); + + if (iPtr->execEnvPtr->rewind) { + result = TCL_ERROR; + goto abnormalReturn; } -#endif -#ifdef TCL_COMPILE_STATS - iPtr->stats.numExecutions++; -#endif + if (result != TCL_OK) { + pc--; + goto processExceptionReturn; + } /* * Loop executing instructions until a "done" instruction, a TCL_RETURN, @@ -2181,7 +2206,7 @@ TclExecuteByteCode( ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0, /*checkStack*/ auxObjList == NULL); - if (TAUX.traceInstructions) { + if (traceInstructions) { fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); TclPrintInstruction(codePtr, pc); fflush(stdout); @@ -2197,11 +2222,11 @@ TclExecuteByteCode( * 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; } @@ -2249,9 +2274,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\")", O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); } @@ -2266,11 +2291,11 @@ TclExecuteByteCode( case INST_RETURN_STK: TRACE(("=> ")); objResultPtr = POP_OBJECT(); - TRESULT = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); + result = 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\")", + if (result == TCL_OK) { + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(1, 0, 0); } @@ -2289,9 +2314,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 @@ -2354,12 +2379,12 @@ TclExecuteByteCode( */ iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - if (!TAUX.checkInterp) { + if (!checkInterp) { goto instStartCmdOK; } else if (((codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch)) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - TAUX.checkInterp = 0; + checkInterp = 0; instStartCmdOK: NEXT_INST_F(9, 0, 0); } else { @@ -2613,7 +2638,6 @@ TclExecuteByteCode( 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 @@ -2621,8 +2645,9 @@ TclExecuteByteCode( * stack-allocated parameter, update the stack pointers. */ - BP = (BottomData *) (((Tcl_Obj **)BP) + moved); - TAUX.esPtr = iPtr->execEnvPtr->execStackPtr; + esPtr = iPtr->execEnvPtr->execStackPtr; + BP->expanded = (BottomData *) (((Tcl_Obj **)BP) + moved); + BP = BP->expanded; catchTop += moved; tosPtr += moved; @@ -2642,11 +2667,6 @@ TclExecuteByteCode( } 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 +2676,8 @@ TclExecuteByteCode( CACHE_STACK_INFO(); cleanup = 1; pc++; - NR_DATA_BURY(); - codePtr = newCodePtr; - goto nonRecursiveCallStart; + NR_YIELD(1); + return TclNRExecuteByteCode(interp, newCodePtr); } /* @@ -2667,80 +2686,13 @@ 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; + NR_YIELD(1); + return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0); case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); @@ -2771,13 +2723,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,148 +2754,15 @@ 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); 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); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", - "ILLEGAL_YIELD", NULL); - CACHE_STACK_INFO(); - pc--; - goto gotError; - } - - NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); - NRE_ASSERT(corPtr->stackLevel != NULL); - if (corPtr->stackLevel != &TAUX) { - Tcl_SetResult(interp, "cannot yield: C stack busy", - TCL_STATIC); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", - NULL); - CACHE_STACK_INFO(); - pc--; - goto gotError; - } - - /* - * Mark suspended, save our state and return - */ - - DECACHE_STACK_INFO(); - 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); + NR_YIELD(1); + return TclNREvalObjv(interp, objc, objv, + TCL_EVAL_NOERR, NULL); #if TCL_SUPPORT_84_BYTECODE case INST_CALL_BUILTIN_FUNC1: @@ -2958,7 +2776,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::"); @@ -3026,9 +2844,9 @@ 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 /* @@ -5509,7 +5327,7 @@ TclExecuteByteCode( Tcl_ResetResult(interp); CACHE_STACK_INFO(); */ - TRESULT = TCL_BREAK; + result = TCL_BREAK; cleanup = 0; goto processExceptionReturn; @@ -5519,7 +5337,7 @@ TclExecuteByteCode( Tcl_ResetResult(interp); CACHE_STACK_INFO(); */ - TRESULT = TCL_CONTINUE; + result = TCL_CONTINUE; cleanup = 0; goto processExceptionReturn; @@ -5703,7 +5521,7 @@ TclExecuteByteCode( DECACHE_STACK_INFO(); Tcl_ResetResult(interp); CACHE_STACK_INFO(); - TRESULT = TCL_OK; + result = TCL_OK; TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1))); NEXT_INST_F(1, 0, 0); @@ -5721,12 +5539,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); @@ -5824,14 +5644,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) { @@ -5843,8 +5663,8 @@ TclExecuteByteCode( valuePtr = Tcl_DuplicateObj(valuePtr); Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); } - TRESULT = TclIncrObj(interp, valuePtr, value2Ptr); - if (TRESULT == TCL_OK) { + result = TclIncrObj(interp, valuePtr, value2Ptr); + if (result == TCL_OK) { Tcl_InvalidateStringRep(dictPtr); } TclDecrRefCount(value2Ptr); @@ -5852,7 +5672,7 @@ TclExecuteByteCode( 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: @@ -5860,7 +5680,7 @@ TclExecuteByteCode( Tcl_Panic("Should not happen!"); } - if (TRESULT != TCL_OK) { + if (result != TCL_OK) { if (allocateDict) { TclDecrRefCount(dictPtr); } @@ -6250,7 +6070,7 @@ TclExecuteByteCode( */ default: - Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); + Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ /* @@ -6294,50 +6114,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) { + if (traceInstructions) { objPtr = Tcl_GetObjResult(interp); - if ((TRESULT != TCL_ERROR) && (TRESULT != TCL_RETURN)) { + if ((result != TCL_ERROR) && (result != TCL_RETURN)) { TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", - TRESULT, O2S(objPtr))); + result, O2S(objPtr))); } else { TRACE_APPEND(("%s, result= \"%s\"\n", - StringForResultCode(TRESULT), O2S(objPtr))); + StringForResultCode(result), O2S(objPtr))); } } #endif @@ -6370,11 +6190,11 @@ TclExecuteByteCode( /* * 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 @@ -6388,7 +6208,7 @@ TclExecuteByteCode( if (iPtr->execEnvPtr->rewind) { goto abnormalReturn; } - if ((TRESULT == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { bytes = GetSrcInfoForPc(pc, codePtr, &length); DECACHE_STACK_INFO(); Tcl_LogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0); @@ -6420,9 +6240,9 @@ TclExecuteByteCode( if (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; @@ -6436,18 +6256,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; @@ -6461,9 +6281,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; @@ -6483,7 +6303,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), @@ -6507,18 +6327,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 @@ -6535,11 +6343,11 @@ 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); } @@ -6550,51 +6358,10 @@ TclExecuteByteCode( * 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); - } - - returnToCaller: - if (OBP) { - BP = OBP; /* back to old bc */ - TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); - - NR_DATA_DIG(); - if (TOP_CB(interp) == BP->rootPtr) { - /* - * The bytecode is returning, all callbacks were run: keep - * processing the caller. - */ - - goto nonRecursiveCallReturn; - } else { - TEOV_callback *callbackPtr = TOP_CB(iPtr); - int type = PTR2INT(callbackPtr->data[0]); - - NRE_ASSERT(TOP_CB(interp)->procPtr == NRCallTEBC); - NRE_ASSERT(TRESULT == TCL_OK); - - switch (type) { - case TCL_NR_BC_TYPE: - /* - * One of the callbacks requested a new execution: a tailcall! - * Start the new bytecode. - */ - - goto nonRecursiveCallSetup; - default: - Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); - } - } - } - - iPtr->execEnvPtr->bottomPtr = NULL; - return TRESULT; + return result; } +#undef codePtr #undef iPtr #undef bcFramePtr #undef initCatchTop @@ -7967,7 +7734,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: @@ -8028,7 +7795,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. * @@ -8065,21 +7832,21 @@ 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))) { int numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); - fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", + fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min %i, max %i)", stackTop, relativePc, stackLowerBound, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message; @@ -8092,7 +7859,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 */ @@ -8102,7 +7869,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. * @@ -8426,7 +8193,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: diff --git a/generic/tclInt.decls b/generic/tclInt.decls index b7b23d5..44afe71 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.148 2010/09/15 07:33:55 nijtmans Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.148.2.1 2010/09/27 20:33:37 kennykb Exp $ library tcl @@ -961,7 +961,7 @@ declare 239 { } declare 240 { int TclNRRunCallbacks(Tcl_Interp *interp, int result, - struct TEOV_callback *rootPtr, int tebcCall) + struct TEOV_callback *rootPtr) } declare 241 { int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, diff --git a/generic/tclInt.h b/generic/tclInt.h index a2fb49f..644eabc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.482.2.1 2010/09/21 19:32:26 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.482.2.2 2010/09/27 20:33:37 kennykb Exp $ */ #ifndef _TCLINT @@ -1477,16 +1477,12 @@ typedef struct CoroutineData { * coroutine. */ CorContext caller; CorContext running; - CorContext base; + Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ void *stackLevel; int auxNumLevels; /* While the coroutine is running the * numLevels of the create/resume command is * stored here; for suspended coroutines it * holds the nesting numLevels at yield. */ - struct BottomData **callerBPPtr; - /* Where to stash the caller's bottomPointer, - * if the coro is running in the caller's TEBC - * instance. Put a NULL in there otherwise. */ int nargs; /* Number of args required for resuming this * coroutine; -2 means "0 or 1" (default), -1 * means "any" */ @@ -1500,7 +1496,6 @@ typedef struct ExecEnv { struct TEOV_callback *callbackPtr; /* Top callback in TEOV's stack. */ struct CoroutineData *corPtr; - struct BottomData *bottomPtr; int rewind; } ExecEnv; diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 6231111..5c21492 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.142 2010/08/21 16:30:26 nijtmans Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.142.2.1 2010/09/27 20:33:37 kennykb Exp $ */ #ifndef _TCLINTDECLS @@ -571,7 +571,7 @@ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp, ProcErrorProc *errorProc); /* 240 */ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, - struct TEOV_callback *rootPtr, int tebcCall); + struct TEOV_callback *rootPtr); /* 241 */ EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); @@ -841,7 +841,7 @@ typedef struct TclIntStubs { int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ - int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct TEOV_callback *rootPtr, int tebcCall); /* 240 */ + int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct TEOV_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index fcc0638..20f6ab6 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOMethod.c,v 1.26.2.1 2010/09/22 01:08:49 kennykb Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.26.2.2 2010/09/27 20:33:37 kennykb Exp $ */ #ifdef HAVE_CONFIG_H @@ -928,59 +928,18 @@ ProcedureMethodVarResolver( int flags, Tcl_Var *varPtr) { - Interp *iPtr = (Interp *) interp; - CallFrame *framePtr = iPtr->varFramePtr; - CallContext *contextPtr; - Tcl_Obj *variableObj; - Tcl_HashEntry *hPtr; - int i, isNew; - - /* - * Check that the variable is being requested in a context that is also a - * method call; if not (i.e. we're evaluating in the object's namespace or - * in a procedure of that namespace) then we do nothing. - */ - - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - return TCL_CONTINUE; - } - contextPtr = framePtr->clientData; - - /* - * Check if the variable is one we want to resolve at all (i.e. whether it - * is in the list provided by the user). If not, we mustn't do anything - * either. - */ + int result; + Tcl_ResolvedVarInfo *rPtr; + + result = ProcedureMethodCompiledVarResolver(interp, varName, + strlen(varName), contextNs, &rPtr); - if (contextPtr->callPtr->chain[contextPtr->index] - .mPtr->declaringClassPtr != NULL) { - FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] - .mPtr->declaringClassPtr->variables) { - if (!strcmp(Tcl_GetString(variableObj), varName)) { - goto gotMatch; - } - } - } else { - FOREACH(variableObj, contextPtr->oPtr->variables) { - if (!strcmp(Tcl_GetString(variableObj), varName)) { - goto gotMatch; - } - } + if (result != TCL_OK) { + return result; } - return TCL_CONTINUE; - - /* - * It is a variable we want to resolve, so resolve it. - */ - gotMatch: - hPtr = Tcl_CreateHashEntry(TclVarTable(contextNs), (char *) variableObj, - &isNew); - if (isNew) { - TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr)); - } - *varPtr = TclVarHashGetValue(hPtr); - return TCL_OK; + *varPtr = rPtr->fetchProc(interp, rPtr); + return (*varPtr? TCL_OK : TCL_CONTINUE); } static Tcl_Var diff --git a/generic/tclObj.c b/generic/tclObj.c index 842c421..5b8cb89 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.174 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.174.2.1 2010/09/27 20:33:37 kennykb Exp $ */ #include "tclInt.h" @@ -4180,7 +4180,7 @@ Tcl_GetCommandFromObj( * The object's old internal rep is freed. It's string rep is not * changed. The refcount in the Command structure is incremented to keep * it from being freed if the command is later deleted until - * TclExecuteByteCode has a chance to recognize that it was deleted. + * TclNRExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- */ diff --git a/generic/tclProc.c b/generic/tclProc.c index d1a90ad..d0c1ca3 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.181 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.181.2.1 2010/09/27 20:33:37 kennykb Exp $ */ #include "tclInt.h" @@ -1811,9 +1811,7 @@ TclNRInterpProcCore( TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); - TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, - NULL, NULL); - return TCL_OK; + return TclNRExecuteByteCode(interp, codePtr); } static int diff --git a/generic/tclTest.c b/generic/tclTest.c index 036a50c..982bd50 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.153 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.153.2.1 2010/09/27 20:33:37 kennykb Exp $ */ #undef STATIC_BUILD @@ -1182,7 +1182,7 @@ TestcmdtraceCmd( * Create a command trace then eval a script to check whether it is * called. Note that this trace procedure removes itself as a further * check of the robustness of the trace proc calling code in - * TclExecuteByteCode. + * TclNRExecuteByteCode. */ cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL); @@ -1282,7 +1282,7 @@ CmdTraceDeleteProc( { /* * Remove ourselves to test whether calling Tcl_DeleteTrace within a trace - * callback causes the for loop in TclExecuteByteCode that calls traces to + * callback causes the for loop in TclNRExecuteByteCode that calls traces to * reference freed memory. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index c36dedf..75363cf 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.203.2.1 2010/09/22 01:08:49 kennykb Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.203.2.2 2010/09/27 20:33:37 kennykb Exp $ */ #include "tclInt.h" @@ -5998,8 +5998,7 @@ TclInfoVarsCmd( listPtr = Tcl_NewListObj(0, NULL); - if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) - || specificNsInPattern) { + if (!HasLocalVars(iPtr->varFramePtr) || specificNsInPattern) { /* * There is no frame pointer, the frame pointer was pushed only to * activate a namespace, or we are in a procedure call frame but a @@ -6235,7 +6234,7 @@ TclInfoLocalsCmd( return TCL_ERROR; } - if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC)) { + if (!HasLocalVars(iPtr->varFramePtr)) { return TCL_OK; } |