diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 446 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 6 | ||||
| -rw-r--r-- | generic/tclCompile.h | 3 | ||||
| -rw-r--r-- | generic/tclExecute.c | 99 | ||||
| -rw-r--r-- | generic/tclInt.h | 38 | ||||
| -rw-r--r-- | tests/unsupported.test | 322 |
7 files changed, 891 insertions, 30 deletions
@@ -1,5 +1,12 @@ 2008-08-17 Miguel Sofer <msofer@users.sf.net> + * generic/tclBasic.c: Implementation of [coroutine] and [yield] + * generic/tclCmdAH.c: commands (in tcl::unsupported). + * generic/tclCompile.h: + * generic/tclExecute.c: + * generic/tclInt.h: + * tests/unsupported.test: + * generic/tclTest.c (TestconcatobjCmd): * generic/tclUtil.c (Tcl_ConcatObj): * tests/util.test (util-4.7): diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8f6c1af..6d91c02 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.354 2008/08/14 10:32:19 das Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.355 2008/08/17 19:37:10 msofer Exp $ */ #include "tclInt.h" @@ -777,6 +777,7 @@ Tcl_CreateInterp(void) Tcl_DisassembleObjCmd, NULL, NULL); /* + * Create unsupported commands for tailcall, coroutine and yield * Create unsupported commands for atProcExit and tailcall */ @@ -787,6 +788,11 @@ Tcl_CreateInterp(void) /*objProc*/ NULL, TclNRAtProcExitObjCmd, INT2PTR(TCL_NR_TAILCALL_TYPE), NULL); + Tcl_NRCreateCommand(interp, "::tcl::unsupported::coroutine", + /*objProc*/ NULL, TclNRCoroutineObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "::tcl::unsupported::yield", + /*objProc*/ NULL, TclNRYieldObjCmd, NULL, NULL); + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. @@ -3679,7 +3685,8 @@ TclInterpReady( return TCL_ERROR; } - if (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG)) { + if (iPtr->execEnvPtr->rewind || + (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } @@ -4186,6 +4193,7 @@ TclNRRunCallbacks( restart: while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); + procPtr = callbackPtr->procPtr; if (tebcCall && (procPtr == NRCallTEBC)) { @@ -4282,7 +4290,10 @@ NRCallTEBC( 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]); @@ -4292,6 +4303,13 @@ NRCallTEBC( Tcl_SetResult(interp, "atProcExit/tailcall can only be called from a proc or lambda", TCL_STATIC); return TCL_ERROR; + case TCL_NR_YIELD_TYPE: + if (iPtr->execEnvPtr->corPtr) { + Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC); + } else { + Tcl_SetResult(interp, "yield can only be called in a coroutine", TCL_STATIC); + } + return TCL_ERROR; default: Tcl_Panic("unknown call type to TEBC"); } @@ -8023,6 +8041,428 @@ Tcl_NRAddCallback( } TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3); } + + +/* + *---------------------------------------------------------------------- + * + * TclNRCoroutineObjCmd -- (and friends) + * + * This object-based function is invoked to process the "coroutine" Tcl + * command. It is heavily based on "apply". + * + * Results: + * A standard Tcl object result value. + * + * Side effects: + * A new procedure gets created. + * + * ** FIRST EXPERIMENTAL IMPLEMENTATION ** + * + * It is fairly amateurish and not up to our standards - mainly in terms of + * error messages and [info] interaction. Just to test the infrastructure in + * teov and tebc. + *---------------------------------------------------------------------- + */ + +static int NRInterpCoroutine(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int RewindCoroutine(CoroutineData *corPtr, int result); +static void DeleteCoroutine(ClientData clientData); +static void PlugCoroutineChains(CoroutineData *corPtr); + +static int NRCoroutineFirstCallback(ClientData data[], + Tcl_Interp *interp, int result); +static int NRCoroutineExitCallback(ClientData data[], + Tcl_Interp *interp, int result); +static int NRCoroutineCallerCallback(ClientData data[], + Tcl_Interp *interp, int result); + + + +static const CorContext NULL_CONTEXT = {NULL, NULL, NULL}; + +#define SAVE_CONTEXT(context) \ + (context).framePtr = iPtr->framePtr; \ + (context).varFramePtr = iPtr->varFramePtr; \ + (context).cmdFramePtr = iPtr->cmdFramePtr + +#define RESTORE_CONTEXT(context) \ + iPtr->framePtr = (context).framePtr; \ + iPtr->varFramePtr = (context).varFramePtr; \ + iPtr->cmdFramePtr = (context).cmdFramePtr + +#define iPtr ((Interp *) interp) + +int +TclNRYieldObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?"); + return TCL_ERROR; + } + + if (!iPtr->execEnvPtr->corPtr) { + Tcl_SetResult(interp, "yield can only be called in a coroutine", TCL_STATIC); + return TCL_ERROR; + } + + if (objc == 2) { + Tcl_SetObjResult(interp, objv[1]); + } + + TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE), + NULL, NULL, NULL); + return TCL_OK; +} + +static int +RewindCoroutine( + CoroutineData *corPtr, + int result) +{ + Tcl_Obj *objPtr; + Tcl_Interp *interp = corPtr->eePtr->interp; + Tcl_InterpState state = Tcl_SaveInterpState(interp, result); + + NRE_ASSERT(COR_IS_SUSPENDED(corPtr)); + NRE_ASSERT(corPtr->eePtr != NULL); + NRE_ASSERT(corPtr->eePtr->bottomPtr != NULL); + NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr); + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + + corPtr->eePtr->rewind = 1; + result = NRInterpCoroutine((ClientData) corPtr, interp, 1, &objPtr); + + NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); + + Tcl_DecrRefCount(objPtr); + result = Tcl_RestoreInterpState(interp, state); + return result; +} + +static void +DeleteCoroutine( + ClientData clientData) +{ + CoroutineData *corPtr = (CoroutineData *) clientData; + + if (COR_IS_SUSPENDED(corPtr)) { + (void) RewindCoroutine(corPtr, TCL_OK); + } +} + +static void +PlugCoroutineChains( + CoroutineData *corPtr) +{ + Tcl_Interp *interp = corPtr->eePtr->interp; + /* + * Called to plug the coroutine's running environment into the caller's, + * so that the frame chains are uninterrupted. Note that the levels and + * numlevels may be wrong - we should fix them for the whole chain and not + * just the base! This probably breaks Tip 280 and should be fixed, or at + * least rethought as some of 280's functionality makes doubtful sense in + * presence of coroutines (maybe the cmdFrame should be attached to the + * execEnv and not the interp?) + */ + + corPtr->base.framePtr->callerPtr = corPtr->caller.framePtr; + corPtr->base.framePtr->callerVarPtr = corPtr->caller.varFramePtr; + + corPtr->base.cmdFramePtr->nextPtr = corPtr->caller.cmdFramePtr; + corPtr->base.cmdFramePtr->level = (iPtr->cmdFramePtr == NULL? + 1 : iPtr->cmdFramePtr->level + 1); + corPtr->base.cmdFramePtr->numLevels = iPtr->numLevels; +} + +static int +NRCoroutineFirstCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + + { + CmdFrame *tmpPtr = iPtr->cmdFramePtr; + + if (corPtr->eePtr) { + while (tmpPtr->nextPtr != corPtr->caller.cmdFramePtr) { + tmpPtr = tmpPtr->nextPtr; + } + corPtr->base.cmdFramePtr = tmpPtr; + } + } + + return result; +} + +static int +NRCoroutineCallerCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + Command *cmdPtr = corPtr->cmdPtr; + + /* + * This is the last callback in the caller execEnv, right before switching + * to the coroutine's + */ + + NRE_ASSERT(iPtr->execEnvPtr == corPtr->callerEEPtr); + + if (!corPtr->eePtr) { + /* + * The execEnv was wound down but not deleted for our sake. We finish + * the job here. The caller context has already been restored. + */ + + NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); + NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); + NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); + ckfree((char *) corPtr); + return result; + } + + 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 execEnv, + * this will do the complete cleanup. RewindCoroutine will restore both + * the caller's context and interp state. + */ + + return RewindCoroutine(corPtr, result); + } + + return result; +} + +static int +NRCoroutineExitCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + Command *cmdPtr = corPtr->cmdPtr; + + /* + * This runs at the bottom of the Coroutine's execEnv: it will be executed + * when the coroutine returns or is wound down, but not when it yields. It + * deletes the coroutine and restores the caller's environment. + */ + + NRE_ASSERT(interp == corPtr->eePtr->interp); + NRE_ASSERT(TOP_CB(interp) == NULL); + NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); + NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); + NRE_ASSERT(TOP_CB(interp) == NULL); + NRE_ASSERT((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineCallerCallback) + || ((corPtr->callerEEPtr->callbackPtr->procPtr == NRCoroutineFirstCallback) && + (corPtr->callerEEPtr->callbackPtr->nextPtr->procPtr == NRCoroutineCallerCallback))); + + NRE_ASSERT(iPtr->framePtr->compiledLocals == NULL); + TclPopStackFrame(interp); + + cmdPtr->deleteProc = NULL; + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + TclCleanupCommandMacro(cmdPtr); + + corPtr->eePtr->corPtr = NULL; + TclDeleteExecEnv(corPtr->eePtr); + corPtr->eePtr = NULL; + + /* RESTORE_CONTEXT(corPtr->caller); AUTOMATIC! */ + + NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); + NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); + iPtr->varFramePtr = corPtr->caller.varFramePtr; + + iPtr->execEnvPtr = corPtr->callerEEPtr; + + return result; +} + +static int +NRInterpCoroutine( + ClientData clientData, + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + CoroutineData *corPtr = (CoroutineData *) clientData; + + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?arg?"); + return TCL_ERROR; + } + + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]), + "\" is already running", NULL); + return TCL_ERROR; + } + + + /* + * 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. + */ + + if (objc == 2) { + Tcl_SetObjResult(interp, objv[1]); + } + + SAVE_CONTEXT(corPtr->caller); + RESTORE_CONTEXT(corPtr->running); + PlugCoroutineChains(corPtr); + + TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, NULL); + + iPtr->execEnvPtr = corPtr->eePtr; + return TclExecuteByteCode(interp, NULL); +} + +int +TclNRCoroutineObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Command *cmdPtr; + CoroutineData *corPtr; + Tcl_Obj *cmdObjPtr; + CallFrame *framePtr, **framePtrPtr; + TEOV_callback *rootPtr = TOP_CB(interp); + char *fullName; + const char *procName; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr; + Tcl_DString ds; + + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?"); + return TCL_ERROR; + } + + /* + * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have + * something in tclUtil.c to find the FQ name. + */ + + fullName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, fullName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + + if (nsPtr == NULL) { + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": unknown namespace", NULL); + return TCL_ERROR; + } + if (procName == NULL) { + Tcl_AppendResult(interp, "can't create procedure \"", fullName, + "\": bad procedure name", NULL); + return TCL_ERROR; + } + if ((nsPtr != iPtr->globalNsPtr) + && (procName != NULL) && (procName[0] == ':')) { + Tcl_AppendResult(interp, "can't create procedure \"", procName, + "\" in non-global namespace with name starting with \":\"", + NULL); + return TCL_ERROR; + } + + corPtr = (CoroutineData *) ckalloc(sizeof(CoroutineData)); + corPtr->eePtr = TclCreateExecEnv(interp); + corPtr->callerEEPtr = iPtr->execEnvPtr; + corPtr->eePtr->corPtr = corPtr; + corPtr->stackLevel = NULL; + + Tcl_DStringInit(&ds); + if (nsPtr != iPtr->globalNsPtr) { + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, procName, -1); + + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), + /*objProc*/ NULL, NRInterpCoroutine, (ClientData) corPtr, + DeleteCoroutine); + Tcl_DStringFree(&ds); + + corPtr->cmdPtr = cmdPtr; + cmdPtr->refCount++; + + /* + * 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; + Tcl_IncrRefCount(cmdObjPtr); + + /* + * Set up the callback in caller execEnv and switch to the new + * execEnv. Switch now so that the CallFrame is allocated on the new + * execEnv's stack. Then push a CallFrame and CmdFrame. + */ + + TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL, NULL); + TclNRAddCallback(interp, NRCoroutineFirstCallback, corPtr, NULL, NULL, NULL); + SAVE_CONTEXT(corPtr->caller); + + iPtr->execEnvPtr = corPtr->eePtr; + + framePtrPtr = &framePtr; + if (TCL_OK != TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + NULL, 0)) { + corPtr->eePtr->corPtr = NULL; + TclDeleteExecEnv(corPtr->eePtr); + ckfree((char *) corPtr); + return TCL_ERROR; + } + framePtr->objc = objc-2; + framePtr->objv = &objv[2]; + + SAVE_CONTEXT(corPtr->base); + corPtr->running = NULL_CONTEXT; + + /* + * Eval things in 'uplevel #0', except for the very first command lookup + * which should be looked up in caller's context. + * + * A better approach would use the lambda infrastructure, but it is a bit + * clumsy for now: we have the "lambda is a nameless proc" hack, we'd need + * the cleaner "proc is a named lambda" to do this properly. + */ + + iPtr->varFramePtr = iPtr->rootFramePtr; + iPtr->lookupNsPtr = iPtr->framePtr->nsPtr; + + TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); + return TclNRRunCallbacks(interp, TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0), rootPtr, 0); +} + /* * Local Variables: diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 868b0b8..8e26dcf 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.101 2008/07/31 20:01:39 msofer Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.102 2008/08/17 19:37:11 msofer Exp $ */ #include "tclInt.h" @@ -278,13 +278,13 @@ CatchObjCmdCallback( int objc = PTR2INT(data[0]); Tcl_Obj *varNamePtr = data[1]; Tcl_Obj *optionVarNamePtr = data[2]; - + int rewind = ((Interp *) interp)->execEnvPtr->rewind; /* * We disable catch in interpreters where the limit has been exceeded. */ - if (Tcl_LimitExceeded(interp)) { + if (rewind || Tcl_LimitExceeded(interp)) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"catch\" body line %d)", interp->errorLine)); return TCL_ERROR; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 044a978..c7539ba 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.105 2008/08/14 10:49:08 das Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.106 2008/08/17 19:37:11 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -842,6 +842,7 @@ MODULE_SCOPE Tcl_NRPostProc NRCallTEBC; #define TCL_NR_BC_TYPE 0 #define TCL_NR_ATEXIT_TYPE 1 #define TCL_NR_TAILCALL_TYPE 2 +#define TCL_NR_YIELD_TYPE 3 /* *---------------------------------------------------------------- diff --git a/generic/tclExecute.c b/generic/tclExecute.c index cc7e4bc..65795bd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.405 2008/08/16 14:27:28 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.406 2008/08/17 19:37:11 msofer Exp $ */ #include "tclInt.h" @@ -804,7 +804,11 @@ TclCreateExecEnv( Tcl_IncrRefCount(eePtr->constants[0]); TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); + eePtr->interp = interp; eePtr->callbackPtr = NULL; + eePtr->corPtr = NULL; + eePtr->bottomPtr = NULL; + eePtr->rewind = 0; esPtr->prevPtr = NULL; esPtr->nextPtr = NULL; @@ -882,6 +886,9 @@ TclDeleteExecEnv( if (eePtr->callbackPtr) { Tcl_Panic("Deleting execEnv with pending TEOV callbacks!"); } + if (eePtr->corPtr) { + Tcl_Panic("Deleting execEnv with existing coroutine"); + } ckfree((char *) eePtr); } @@ -1826,6 +1833,28 @@ TclExecuteByteCode( TEOV_callback *atExitPtr = NULL; int isTailcall = 0; + if (!codePtr) { + /* + * Reawakening a suspended coroutine: the [yield] command + * is returning. + */ + + NRE_ASSERT(iPtr->execEnvPtr->corPtr->eePtr == iPtr->execEnvPtr); + NRE_ASSERT(iPtr->execEnvPtr->corPtr != NULL); + NRE_ASSERT(iPtr->execEnvPtr->corPtr->eePtr == iPtr->execEnvPtr); + NRE_ASSERT(COR_IS_SUSPENDED(iPtr->execEnvPtr->corPtr)); + + initLevel = 0; + nested = 1; + + oldBottomPtr = iPtr->execEnvPtr->bottomPtr; + iPtr->execEnvPtr->corPtr->stackLevel = &initLevel; + if (iPtr->execEnvPtr->rewind) { + result = TCL_ERROR; + } + goto returnToCaller; + } + nonRecursiveCallStart: if (nested) { TEOV_callback *callbackPtr = TOP_CB(interp); @@ -1848,13 +1877,12 @@ TclExecuteByteCode( * variables, swap codePtr and start running the new one. */ - NR_DATA_BURY(); codePtr = param; break; case TCL_NR_ATEXIT_TYPE: { /* * A request to perform a command at exit: put it in the stack - * and continue eexec'ing the current bytecode + * and continue exec'ing the current bytecode */ TEOV_callback *newPtr = TOP_CB(interp); @@ -1868,11 +1896,8 @@ TclExecuteByteCode( #endif newPtr->nextPtr = bottomPtr->atExitPtr; bottomPtr->atExitPtr = newPtr; - while (cleanup--) { - Tcl_Obj *objPtr = POP_OBJECT(); - Tcl_DecrRefCount(objPtr); - } - goto nonRecursiveCallReturn; + oldBottomPtr = bottomPtr; + goto returnToCaller; } case TCL_NR_TAILCALL_TYPE: { /* @@ -1915,6 +1940,37 @@ TclExecuteByteCode( } goto abnormalReturn; } + 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); + result = TCL_ERROR; + goto checkForCatch; + } + NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); + NRE_ASSERT(corPtr->stackLevel != NULL); + NRE_ASSERT(bottomPtr == corPtr->eePtr->bottomPtr); + if (corPtr->stackLevel != &initLevel) { + Tcl_SetResult(interp, + "cannot yield: C stack busy", TCL_STATIC); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Save our state, restore the caller's execEnv and return + */ + + NR_DATA_BURY(); + esPtr->tosPtr = tosPtr; + corPtr->stackLevel = NULL; /* mark suspended */ + iPtr->execEnvPtr->bottomPtr = bottomPtr; + + iPtr->execEnvPtr = corPtr->callerEEPtr; + return TCL_OK; + } default: Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); } @@ -1929,8 +1985,13 @@ TclExecuteByteCode( auxObjList = NULL; initLevel = 1; NR_DATA_INIT(); /* record this level's data */ + + if (iPtr->execEnvPtr->corPtr && !iPtr->execEnvPtr->corPtr->stackLevel) { + iPtr->execEnvPtr->corPtr->stackLevel = &initLevel; + } nonRecursiveCallReturn: + iPtr->execEnvPtr->bottomPtr = bottomPtr; bcFramePtr = (CmdFrame *) (bottomPtr + 1); initCatchTop = ((ptrdiff_t *) (bcFramePtr + 1)) - 1; initTosPtr = (Tcl_Obj **) (initCatchTop + codePtr->maxExceptDepth); @@ -1965,6 +2026,11 @@ TclExecuteByteCode( TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,bcFramePtr); + if (iPtr->execEnvPtr->rewind) { + result = TCL_ERROR; + goto abnormalReturn; + } + } else { /* * Returning from a non-recursive call. State is already completely @@ -1973,7 +2039,12 @@ TclExecuteByteCode( NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); iPtr->cmdFramePtr = bcFramePtr->nextPtr; - + + if (iPtr->execEnvPtr->rewind) { + result = TCL_ERROR; + goto abnormalReturn; + } + if (result == TCL_OK) { /* * Reset the interp's result to avoid possible duplications of @@ -2731,7 +2802,11 @@ TclExecuteByteCode( pc += pcAdjustment; goto nonRecursiveCallStart; } + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr->nextPtr); + + iPtr->execEnvPtr->bottomPtr = bottomPtr; if (result == TCL_OK) { Tcl_Obj *objPtr; @@ -7591,6 +7666,9 @@ TclExecuteByteCode( */ checkForCatch: + if (iPtr->execEnvPtr->rewind) { + goto abnormalReturn; + } if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { bytes = GetSrcInfoForPc(pc, codePtr, &length); if (bytes != NULL) { @@ -7747,6 +7825,7 @@ TclExecuteByteCode( TclCleanupByteCode(codePtr); } + returnToCaller: if (oldBottomPtr) { /* * Restore the state to what it was previous to this bytecode, deal @@ -7759,7 +7838,6 @@ TclExecuteByteCode( result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1); NR_DATA_DIG(); - DECACHE_STACK_INFO(); if (TOP_CB(interp) == bottomPtr->rootPtr) { /* * The bytecode is returning, all callbacks were run. Run atExit @@ -7856,6 +7934,7 @@ TclExecuteByteCode( iPtr->atExitPtr = atExitPtr; } + iPtr->execEnvPtr->bottomPtr = NULL; return result; } #undef iPtr diff --git a/generic/tclInt.h b/generic/tclInt.h index 8992044..c40220f 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.390 2008/08/13 23:08:38 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.391 2008/08/17 19:37:12 msofer Exp $ */ #ifndef _TCLINT @@ -1330,15 +1330,38 @@ typedef struct ExecStack { * currently active execution stack. */ +typedef struct CorContext { + struct CallFrame *framePtr; + struct CallFrame *varFramePtr; + struct CmdFrame *cmdFramePtr; +} CorContext; + +typedef struct CoroutineData { + struct Command *cmdPtr; + struct ExecEnv *eePtr; + struct ExecEnv *callerEEPtr; + CorContext caller; + CorContext running; + CorContext base; + int *stackLevel; +} CoroutineData; + typedef struct ExecEnv { ExecStack *execStackPtr; /* Points to the first item in the * evaluation stack on the heap. */ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" * objs. */ + struct Tcl_Interp *interp; struct TEOV_callback *callbackPtr; /* Top callback in TEOV's stack */ + struct CoroutineData *corPtr; + struct BottomData *bottomPtr; + int rewind; } ExecEnv; +#define COR_IS_SUSPENDED(corPtr) \ + ((corPtr)->stackLevel == NULL) + /* * The definitions for the LiteralTable and LiteralEntry structures. Each * interpreter contains a LiteralTable. It is used to reduce the storage @@ -2523,13 +2546,14 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; + /* *---------------------------------------------------------------- - * Procedures shared among Tcl modules but not used by the outside world: + * Procedures shared among Tcl modules but not used by the outside world, + * introduced by/for NRE. *---------------------------------------------------------------- */ -/* Introduced by/for NRE */ MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; @@ -2540,6 +2564,14 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRAtProcExitObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl modules but not used by the outside world: + *---------------------------------------------------------------- + */ MODULE_SCOPE int TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); diff --git a/tests/unsupported.test b/tests/unsupported.test index c043ae2..48cd130 100644 --- a/tests/unsupported.test +++ b/tests/unsupported.test @@ -1,4 +1,4 @@ -# Commands covered: proc, apply, [interp alias], [namespce import], tailcall +# Commands covered: tailcall, atProcExit, coroutine, yield # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files @@ -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: unsupported.test,v 1.3 2008/08/04 14:59:53 msofer Exp $ +# RCS: @(#) $Id: unsupported.test,v 1.4 2008/08/17 19:37:13 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -19,15 +19,11 @@ if {[lsearch [namespace children] ::tcltest] == -1} { testConstraint testnrelevels [llength [info commands testnrelevels]] testConstraint atProcExit [llength [info commands ::tcl::unsupported::atProcExit]] testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]] +testConstraint coroutine [llength [info commands ::tcl::unsupported::yield]] -if {[testConstraint atProcExit]} { - namespace eval tcl::unsupported namespace export atProcExit - namespace import tcl::unsupported::atProcExit -} - -if {[testConstraint tailcall]} { - namespace eval tcl::unsupported namespace export tailcall - namespace import tcl::unsupported::tailcall +if {[namespace exists tcl::unsupported]} { + namespace eval tcl::unsupported namespace export * + namespace import tcl::unsupported::* } # @@ -424,10 +420,311 @@ test unsupported-AT.1 {atProcExit and tailcall} -constraints { rename a {} } -result {{0 2 3 1 6} {0 2 3 1 6} 0} +# +# Test coroutines +# + +if {[testConstraint coroutine]} { + namespace import tcl::unsupported::coroutine + namespace import tcl::unsupported::yield +} + +set lambda [list {{start 0} {stop 10}} { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + yield [expr {$i*$stop}] + incr i + } +}] + + +test unsupported-C.1.1 {coroutine basic} -constraints {coroutine} \ +-setup { + coroutine foo ::apply $lambda + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {0 10 20} + +test unsupported-C.1.2 {coroutine basic} -constraints {coroutine} \ +-setup { + coroutine foo ::apply $lambda 2 8 + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {16 24 32} + +test unsupported-C.1.3 {yield returns new arg} -constraints {coroutine} \ +-setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + set stop [yield [expr {$i*$stop}]] + incr i + } + } + coroutine foo ::apply [list {{start 2} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {20 6 12} + +test unsupported-C.1.4 {yield in nested proc} -constraints {coroutine} \ +-setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + moo + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename foo {} + rename moo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.5 {just yield} -constraints {coroutine} \ +-body { + coroutine foo yield + list [foo] [catch foo msg] $msg +} -cleanup { + unset msg +} -result {{} 1 {invalid command name "foo"}} + +test unsupported-C.1.6 {just yield} -constraints {coroutine} \ +-body { + coroutine foo [list yield] + list [foo] [catch foo msg] $msg +} -cleanup { + unset msg +} -result {{} 1 {invalid command name "foo"}} + +test unsupported-C.1.7 {yield in nested uplevel} -constraints {coroutine} \ +-setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 [list yield [expr {$i*$stop}]] + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + rename foo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.8 {yield in nested uplevel} -constraints {coroutine} \ +-setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 yield [expr {$i*$stop}] + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + rename foo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.9 {yield in nested eval} -constraints {coroutine} \ +-setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + eval moo + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename moo {} + unset body res +} -returnCodes error -result {cannot yield: C stack busy} + +test unsupported-C.1.10 {yield in nested eval} -constraints {coroutine} \ +-setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + eval yield + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + unset body res +} -returnCodes error -result {cannot yield: C stack busy} + +test unsupported-C.1.11 {yield outside coroutine} -constraints {coroutine} \ +-setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } +} -body { + variable i 5 stop 6 + moo +} -cleanup { + rename moo {} + unset i stop +} -returnCodes error -result {yield can only be called in a coroutine} + +test unsupported-C.1.12 {proc as coroutine} -constraints {coroutine} \ +-setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 [list yield [expr {$i*$stop}]] + incr i + } + } + proc moo {{start 0} {stop 10}} $body + coroutine foo moo 2 8 +} -body { + list [foo] [foo] +} -cleanup { + unset body + rename moo {} + rename foo {} +} -result {16 24} + +test unsupported-C.2.1 {self deletion on return} -constraints {coroutine} \ +-body { + coroutine foo set x 3 + foo +} -returnCodes error -result {invalid command name "foo"} + +test unsupported-C.2.2 {self deletion on return} -constraints {coroutine} \ +-body { + coroutine foo ::apply [list {} {yield; yield 1; return 2}] + list [foo] [foo] [catch foo msg] $msg +} -result {1 2 1 {invalid command name "foo"}} + +test unsupported-C.2.3 {self deletion on error return} -constraints {coroutine} \ +-body { + coroutine foo ::apply [list {} {yield;yield 1; error ouch!}] + list [foo] [catch foo msg] $msg [catch foo msg] $msg +} -result {1 1 ouch! 1 {invalid command name "foo"}} + +test unsupported-C.2.4 {self deletion on other return} -constraints {coroutine} \ +-body { + coroutine foo ::apply [list {} {yield;yield 1; return -code 100 ouch!}] + list [foo] [catch foo msg] $msg [catch foo msg] $msg +} -result {1 100 ouch! 1 {invalid command name "foo"}} + +test unsupported-C.2.5 {deletion of suspended coroutine} -constraints {coroutine} \ +-body { + coroutine foo ::apply [list {} {yield; yield 1; return 2}] + list [foo] [rename foo {}] [catch foo msg] $msg +} -result {1 {} 1 {invalid command name "foo"}} + +test unsupported-C.2.6 {deletion of running coroutine} -constraints {coroutine} \ +-body { + coroutine foo ::apply [list {} {yield; rename foo {}; yield 1; return 2}] + list [foo] [catch foo msg] $msg +} -result {1 1 {invalid command name "foo"}} + + # cleanup ::tcltest::cleanupTests + +unset -nocomplain lambda + if {[testConstraint tailcall]} { namespace forget tcl::unsupported::tailcall } @@ -436,6 +733,11 @@ if {[testConstraint atProcExit]} { namespace forget tcl::unsupported::atProcExit } +if {[testConstraint coroutine]} { + namespace forget tcl::unsupported::coroutine + namespace forget tcl::unsupported::yield +} + if {[testConstraint testnrelevels]} { namespace forget testnre::* namespace delete testnre |