diff options
Diffstat (limited to 'generic/tclBasic.c')
| -rw-r--r-- | generic/tclBasic.c | 327 |
1 files changed, 136 insertions, 191 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 211771a..e426178 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 2010/08/31 20:48:17 nijtmans Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.466 2010/09/27 19:42:37 msofer 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) @@ -810,7 +814,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 /* @@ -3049,7 +3053,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). */ @@ -4095,7 +4099,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 @@ -4279,11 +4283,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; @@ -4305,23 +4307,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); @@ -4381,41 +4367,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 */ -} /* *---------------------------------------------------------------------- @@ -5933,7 +5884,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 @@ -6060,9 +6011,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); } { @@ -8166,7 +8115,7 @@ Tcl_NRCallObjProc( (Tcl_Obj **)(objv + 1)); } result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr, 0); + return TclNRRunCallbacks(interp, result, rootPtr); } /* @@ -8480,8 +8429,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; @@ -8498,38 +8445,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, @@ -8623,7 +8545,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; @@ -8641,7 +8562,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); } } @@ -8677,7 +8598,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 @@ -8717,17 +8638,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. @@ -8735,13 +8649,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, @@ -8750,7 +8749,6 @@ NRInterpCoroutine( Tcl_Obj *const objv[]) /* Argument objects. */ { CoroutineData *corPtr = clientData; - int nestNumLevels = corPtr->auxNumLevels; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_ResetResult(interp); @@ -8791,26 +8789,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; } @@ -8823,11 +8803,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 ...?"); @@ -8866,18 +8844,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) { @@ -8906,84 +8876,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; } |