summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2008-08-17 19:37:04 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2008-08-17 19:37:04 (GMT)
commit66b7825d012cdec4bf088bf8c35be432c0ade73a (patch)
treeb9e0527c030a241429a14d5d20be1ef6b52db633 /generic/tclBasic.c
parentd49908850f4747e397786cba1c88d3aca348eb36 (diff)
downloadtcl-66b7825d012cdec4bf088bf8c35be432c0ade73a.zip
tcl-66b7825d012cdec4bf088bf8c35be432c0ade73a.tar.gz
tcl-66b7825d012cdec4bf088bf8c35be432c0ade73a.tar.bz2
* 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:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c446
1 files changed, 443 insertions, 3 deletions
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: