summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2009-12-08 20:56:28 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2009-12-08 20:56:28 (GMT)
commitb475ec90cf97e4e17e2fda2954e1983c882ab339 (patch)
treef0440b1ff94865fad5e6d9f65c92fec53d2f6615
parent5291a66f405cc624cacbafb313ad1a5c0e34e3a5 (diff)
downloadtcl-b475ec90cf97e4e17e2fda2954e1983c882ab339.zip
tcl-b475ec90cf97e4e17e2fda2954e1983c882ab339.tar.gz
tcl-b475ec90cf97e4e17e2fda2954e1983c882ab339.tar.bz2
* generic/tclBasic.c: Partial nre-enabling of coroutines.
* generic/tclExecute.c: The initial call still requires its * generic/tclInt.h: own instance of tebc, but on resume coros can execute in the caller's tebc.
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclBasic.c87
-rw-r--r--generic/tclExecute.c73
-rw-r--r--generic/tclInt.h5
4 files changed, 104 insertions, 66 deletions
diff --git a/ChangeLog b/ChangeLog
index d6d53ee..06d9a4e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
2009-12-08 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclBasic.c: Partial nre-enabling of coroutines.
+ * generic/tclExecute.c: The initial call still requires its
+ * generic/tclInt.h: own instance of tebc, but on resume coros
+ can execute in the caller's tebc.
+
* generic/tclExecute.c (TEBC): silence warning about pcAdjustment
2009-12-08 Donal K. Fellows <dkf@users.sf.net>
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 11da4cc..3d777d3 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.417 2009/12/08 14:18:34 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.418 2009/12/08 20:56:29 msofer Exp $
*/
#include "tclInt.h"
@@ -143,7 +143,8 @@ static Tcl_NRPostProc NRRunObjProc;
static Tcl_NRPostProc TailcallCleanup;
static Tcl_NRPostProc NRTailcallEval;
-static Tcl_NRPostProc YieldCallback;
+static Tcl_NRPostProc RewindCoroutineCallback;
+static Tcl_NRPostProc YieldToCallback;
/*
* The following structure define the commands in the Tcl core.
@@ -8417,29 +8418,24 @@ static const CorContext NULL_CONTEXT = {NULL, NULL, NULL, NULL};
#define iPtr ((Interp *) interp)
static int
-YieldCallback(
+YieldToCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
- CoroutineData *corPtr = data[0];
+ /* CoroutineData *corPtr = data[0];*/
Tcl_Obj *listPtr = data[1];
+ ClientData nsPtr = data[2];
- corPtr->stackLevel = NULL; /* mark suspended */
- iPtr->execEnvPtr = corPtr->callerEEPtr;
-
- if (listPtr) {
- /* yieldTo: invoke the command using tailcall tech */
- TEOV_callback *cbPtr;
- ClientData nsPtr = data[2];
-
- TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr,
- NULL, NULL);
- cbPtr = TOP_CB(interp);
- TOP_CB(interp) = cbPtr->nextPtr;
-
- TclSpliceTailcall(interp, cbPtr);
- }
+ /* yieldTo: invoke the command using tailcall tech */
+ TEOV_callback *cbPtr;
+
+ TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr,
+ NULL, NULL);
+ cbPtr = TOP_CB(interp);
+ TOP_CB(interp) = cbPtr->nextPtr;
+
+ TclSpliceTailcall(interp, cbPtr);
return TCL_OK;
}
@@ -8471,7 +8467,6 @@ TclNRYieldObjCmd(
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
- TclNRAddCallback(interp, YieldCallback, corPtr, NULL, NULL, NULL);
TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
NULL, NULL, NULL);
return TCL_OK;
@@ -8518,8 +8513,15 @@ TclNRYieldToObjCmd(
Tcl_Panic("yieldTo failed to find the proper namespace");
}
Tcl_IncrRefCount(nsObjPtr);
+
+ /*
+ * Add the callback in the caller's env, then instruct TEBC to yield
+ */
- TclNRAddCallback(interp, YieldCallback, corPtr, listPtr, nsObjPtr, NULL);
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr, NULL);
+ iPtr->execEnvPtr = corPtr->eePtr;
+
TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
NULL, NULL, NULL);
return TCL_OK;
@@ -8527,11 +8529,19 @@ TclNRYieldToObjCmd(
static int
+RewindCoroutineCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ return Tcl_RestoreInterpState(interp, data[0]);
+}
+
+static int
RewindCoroutine(
CoroutineData *corPtr,
int result)
{
- Tcl_Obj *objPtr;
Tcl_Interp *interp = corPtr->eePtr->interp;
Tcl_InterpState state = Tcl_SaveInterpState(interp, result);
@@ -8540,17 +8550,10 @@ RewindCoroutine(
NRE_ASSERT(corPtr->eePtr->bottomPtr != NULL);
NRE_ASSERT(corPtr->eePtr != iPtr->execEnvPtr);
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
-
corPtr->eePtr->rewind = 1;
- result = NRInterpCoroutine(corPtr, interp, 1, &objPtr);
-
- NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
-
- Tcl_DecrRefCount(objPtr);
- result = Tcl_RestoreInterpState(interp, state);
- return result;
+ TclNRAddCallback(interp, RewindCoroutineCallback, state,
+ NULL, NULL, NULL);
+ return NRInterpCoroutine(corPtr, interp, 0, NULL);
}
static void
@@ -8718,7 +8721,11 @@ NRInterpCoroutine(
CoroutineData *corPtr = clientData;
int nestNumLevels = corPtr->auxNumLevels;
- if ((objc != 1) && (objc != 2)) {
+ /*
+ * objc==0 indicates a call to rewind the coroutine
+ */
+
+ if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?arg?");
return TCL_ERROR;
}
@@ -8750,9 +8757,13 @@ NRInterpCoroutine(
TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL,
NULL);
+ corPtr->callerBP = NULL;;
corPtr->callerEEPtr = iPtr->execEnvPtr;
iPtr->execEnvPtr = corPtr->eePtr;
- return TclExecuteByteCode(interp, NULL);
+
+ TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), NULL,
+ NULL, NULL);
+ return TCL_OK;
}
int
@@ -8771,7 +8782,6 @@ TclNRCoroutineObjCmd(
const char *procName;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_DString ds;
- int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
@@ -8810,7 +8820,8 @@ TclNRCoroutineObjCmd(
corPtr->callerEEPtr = iPtr->execEnvPtr;
corPtr->eePtr->corPtr = corPtr;
corPtr->stackLevel = NULL;
-
+ corPtr->callerBP = NULL;
+
/*
* On first run just set a 0 level-offset, the natural numbering is
* correct. The offset will be fixed for later runs.
@@ -8924,9 +8935,9 @@ TclNRCoroutineObjCmd(
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL,NULL,NULL);
iPtr->evalFlags |= TCL_EVAL_REDIRECT;
- result = TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
+ TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
- return TclNRRunCallbacks(interp, result, rootPtr, 0);
+ return TclNRRunCallbacks(interp, TCL_OK, rootPtr, 0);
}
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d8cd7f6..039ad24 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.454 2009/12/08 19:00:25 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.455 2009/12/08 20:56:29 msofer Exp $
*/
#include "tclInt.h"
@@ -205,6 +205,7 @@ typedef struct BottomData {
cleanup = BP->cleanup; \
TAUX.esPtr = iPtr->execEnvPtr->execStackPtr; \
tosPtr = TAUX.esPtr->tosPtr; \
+ TAUX.compiledLocals = iPtr->varFramePtr->compiledLocals;\
} while (0)
#define PUSH_TAUX_OBJ(objPtr) \
@@ -2006,7 +2007,7 @@ TclExecuteByteCode(
iPtr->execEnvPtr->bottomPtr = BP;
TAUX.esPtr = iPtr->execEnvPtr->execStackPtr;
- TAUX.compiledLocals = iPtr->varFramePtr->compiledLocals;//
+ TAUX.compiledLocals = iPtr->varFramePtr->compiledLocals;
pc = codePtr->codeStart;
catchTop = initCatchTop;
@@ -2817,15 +2818,17 @@ TclExecuteByteCode(
if (param) {
codePtr = param;
goto nonRecursiveCallStart;
+ } else {
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+ corPtr->callerBP = BP;
+ goto resumeCoroutine;
}
- /* NOT CALLED, does not (yet?) work */
- goto resumeCoroutine;
- case TCL_NR_TAILCALL_TYPE:
- /*
- * A request to perform a tailcall: just drop this
- * bytecode.
- */
-
+ break;
+ case TCL_NR_TAILCALL_TYPE:
+ /*
+ * A request to perform a tailcall: just drop this
+ * bytecode. */
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " Tailcall request received\n");
@@ -2860,34 +2863,35 @@ TclExecuteByteCode(
pc--;
goto checkForCatch;
}
+
NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
NRE_ASSERT(corPtr->stackLevel != NULL);
NRE_ASSERT(BP == corPtr->eePtr->bottomPtr);
if (corPtr->stackLevel != &TAUX) {
- Tcl_SetResult(interp,
- "cannot yield: C stack busy", TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "COROUTINE",
- "CANT_YIELD", NULL);
+ Tcl_SetResult(interp, "cannot yield: C stack busy",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "COROUTINE_CANT_YIELD", NULL);
TRESULT = TCL_ERROR;
pc--;
goto checkForCatch;
}
-
+
/*
* Save our state and return
*/
-
- NR_DATA_BURY();
- TAUX.esPtr->tosPtr = tosPtr;
- iPtr->execEnvPtr->bottomPtr = BP;
- return TCL_OK;
+
+ corPtr->stackLevel = NULL; /* mark suspended */
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ OBP = corPtr->callerBP;
+ goto returnToCaller;
}
default:
Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
}
}
}
-
+
pc += pcAdjustment;
nonRecursiveCallReturn:
@@ -7448,7 +7452,7 @@ TclExecuteByteCode(
statePtr->typePtr = &dictIteratorType;
statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
- varPtr = LOCAL(opnd);//
+ varPtr = LOCAL(opnd);
if (varPtr->value.objPtr) {
if (varPtr->value.objPtr->typePtr != &dictIteratorType) {
TclDecrRefCount(varPtr->value.objPtr);
@@ -7971,13 +7975,10 @@ TclExecuteByteCode(
NR_DATA_DIG();
if (TOP_CB(interp) == BP->rootPtr) {
/*
- * The bytecode is returning, all callbacks were run. Remove the
- * caller's arguments and keep processing the caller.
+ * The bytecode is returning, all callbacks were run: keep
+ * processing the caller.
*/
- TAUX.esPtr = iPtr->execEnvPtr->execStackPtr;
- TAUX.compiledLocals = iPtr->varFramePtr->compiledLocals;
-
goto nonRecursiveCallReturn;
} else {
TEOV_callback *callbackPtr = TOP_CB(iPtr);
@@ -8009,6 +8010,24 @@ TclExecuteByteCode(
}
}
+ /*
+ * Deal with coros running in the caller's TEBC
+ */
+
+ if (iPtr->execEnvPtr->corPtr) {
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ /*
+ * The coro is returning internally iff
+ * - this is its base TEBC
+ * - this is it's callers TEBC, signalled by callerBP!=NULL
+ */
+
+ OBP = corPtr->callerBP;
+ if (OBP && (corPtr->stackLevel == &TAUX)) {
+ goto returnToCaller;
+ }
+ }
+
iPtr->execEnvPtr->bottomPtr = NULL;
return TRESULT;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6eb542e..91f301f 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.451 2009/12/08 01:34:05 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.452 2009/12/08 20:56:29 msofer Exp $
*/
#ifndef _TCLINT
@@ -1405,6 +1405,9 @@ typedef struct CoroutineData {
* numLevels of the create/resume command is
* stored here; for suspended coroutines it
* holds the nesting numLevels at yield. */
+ struct BottomData *callerBP;/* The caller's bottomPointer, if the coro is
+ * running in the caller's TEBC instance. NULL
+ * otherwise. */
} CoroutineData;
typedef struct ExecEnv {