summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclBasic.c134
-rw-r--r--generic/tclExecute.c8
-rw-r--r--generic/tclInt.h18
-rw-r--r--generic/tclNamesp.c20
5 files changed, 123 insertions, 68 deletions
diff --git a/ChangeLog b/ChangeLog
index d2b8e13..605c9b0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,15 @@
2010-08-18 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclBasic.c: New redesign of [tailcall]: find
+ * generic/tclExecute.c: errors early on, so that errorInfo
+ * generic/tclInt.h: contains the proper info [Bug 3047235]
+ * generic/tclNamesp.c:
+
* generic/tclCmdAH.c (TclNRTryObjCmd): block tailcalling out of
- the body of a non-bc'ed [try], #3046594
+ the body of a non-bc'ed [try], [Bug 3046594]
* generic/tclBasic.c: Redesign of [tailcall] to
- * generic/tclCmdAH.c: (a) fix #3047235
- * generic/tclCompile.h: (b) enable fix for #3046594
+ * generic/tclCmdAH.c: (a) fix [Bug 3047235]
+ * generic/tclCompile.h: (b) enable fix for [Bug 3046594]
* generic/tclExecute.c: (c) enable recursive tailcalls
* generic/tclInt.h:
* generic/tclNamesp.c:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5b767fe..366e45e 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.461 2010/08/18 15:44:10 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.462 2010/08/18 22:33:26 msofer Exp $
*/
#include "tclInt.h"
@@ -165,6 +165,13 @@ static Tcl_NRPostProc TEOV_RestoreVarFrame;
static Tcl_NRPostProc TEOV_RunLeaveTraces;
static Tcl_NRPostProc YieldToCallback;
+static void ClearTailcall(Tcl_Interp *interp,
+ struct TEOV_callback *tailcallPtr);
+static int SpliceTailcall(Tcl_Interp *interp,
+ struct TEOV_callback *tailcallPtr,
+ int skip);
+
+
MODULE_SCOPE const TclStubs tclStubs;
/*
@@ -8284,10 +8291,30 @@ Tcl_NRCmdSwap(
* FIXME NRE!
*/
-void
-TclSpliceTailcall(
+void TclRemoveTailcall(
+ Tcl_Interp *interp)
+{
+ TEOV_callback *runPtr, *tailcallPtr;
+
+ for (runPtr = TOP_CB(interp); runPtr->nextPtr; runPtr = runPtr->nextPtr) {
+ if (runPtr->nextPtr->procPtr == NRTailcallEval) {
+ break;
+ }
+ }
+ if (!runPtr->nextPtr) {
+ Tcl_Panic("TclRemoveTailcall did not find a tailcall");
+ }
+
+ tailcallPtr = runPtr->nextPtr;
+ runPtr->nextPtr = tailcallPtr->nextPtr;
+ ClearTailcall(interp, tailcallPtr);
+}
+
+static int
+SpliceTailcall(
Tcl_Interp *interp,
- TEOV_callback *tailcallPtr)
+ TEOV_callback *tailcallPtr,
+ int skip)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
@@ -8297,13 +8324,27 @@ TclSpliceTailcall(
Interp *iPtr = (Interp *) interp;
TEOV_callback *runPtr;
- ExecEnv *eePtr = NULL;
- restart:
- for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+ runPtr = TOP_CB(interp);
+ if (skip) {
+ while (runPtr && (runPtr != iPtr->varFramePtr->wherePtr)) {
+ if ((runPtr->procPtr) == TclNRBlockTailcall) {
+ ClearTailcall(interp, tailcallPtr);
+ Tcl_SetResult(interp,"tailcall called from within a catch environment",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
+ NULL);
+ return TCL_ERROR;
+ }
+ runPtr = runPtr->nextPtr;
+ }
+ }
+
+ restart:
+ for (; runPtr; runPtr = runPtr->nextPtr) {
if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
break;
- }
+ }
}
if (!runPtr) {
/*
@@ -8314,24 +8355,20 @@ TclSpliceTailcall(
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
if (corPtr) {
- eePtr = iPtr->execEnvPtr;
- iPtr->execEnvPtr = corPtr->callerEEPtr;
+ runPtr = corPtr->callerEEPtr->callbackPtr;
goto restart;
}
- Tcl_Panic("Tailcall cannot find the right splicing spot: should not happen!");
+
+ Tcl_SetResult(interp,
+ "tailcall cannot find the right splicing spot: should not happen!",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "UNKNOWN", NULL);
+ return TCL_ERROR;
}
tailcallPtr->nextPtr = runPtr->nextPtr;
runPtr->nextPtr = tailcallPtr;
-
- if (eePtr) {
- /*
- * Restore the right execEnv if it was swapped for tailcalling out
- * of a coroutine.
- */
-
- iPtr->execEnvPtr = eePtr;
- }
+ return TCL_OK;
}
int
@@ -8354,10 +8391,10 @@ TclNRTailcallObjCmd(
if (!iPtr->varFramePtr->isProcCallFrame || /* is not a body */
(iPtr->framePtr != iPtr->varFramePtr)) { /* or is upleveled */
- Tcl_SetResult(interp,
- "tailcall can only be called from a proc or lambda",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+ Tcl_SetResult(interp,
+ "tailcall can only be called from a proc or lambda",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
return TCL_ERROR;
}
@@ -8381,8 +8418,12 @@ TclNRTailcallObjCmd(
TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
tailcallPtr = TOP_CB(interp);
TOP_CB(interp) = tailcallPtr->nextPtr;
- iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+
+ if (SpliceTailcall(interp, tailcallPtr, 1) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ iPtr->varFramePtr->isProcCallFrame |= FRAME_TAILCALLING;
return TCL_OK;
}
@@ -8399,16 +8440,28 @@ NRTailcallEval(
int objc;
Tcl_Obj **objv;
- TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
- if (result == TCL_OK) {
- iPtr->lookupNsPtr = (Namespace *) nsPtr;
- ListObjGetElements(listPtr, objc, objv);
- result = TclNREvalObjv(interp, objc, objv, 0, NULL);
- }
}
- return result;
+
+ if (result != TCL_OK) {
+ /*
+ * Tailcall execution was preempted, eg by an intervening catch or by
+ * a now-gone namespace: cleanup and return.
+ */
+
+ TailcallCleanup(data, interp, result);
+ return result;
+ }
+
+ /*
+ * Perform the tailcall
+ */
+
+ TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
+ iPtr->lookupNsPtr = (Namespace *) nsPtr;
+ ListObjGetElements(listPtr, objc, objv);
+ return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
static int
@@ -8422,8 +8475,8 @@ TailcallCleanup(
return result;
}
-void
-TclClearTailcall(
+static void
+ClearTailcall(
Tcl_Interp *interp,
TEOV_callback *tailcallPtr)
{
@@ -8437,17 +8490,6 @@ TclNRBlockTailcall(
Tcl_Interp *interp,
int result)
{
- Interp *iPtr = (Interp *) interp;
-
- if (iPtr->varFramePtr->tailcallPtr) {
- TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
- iPtr->varFramePtr->tailcallPtr = NULL;
- result = TCL_ERROR;
- Tcl_SetResult(interp,"tailcall called from within a catch environment",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
- NULL);
- }
return result;
}
@@ -8619,7 +8661,7 @@ YieldToCallback(
cbPtr = TOP_CB(interp);
TOP_CB(interp) = cbPtr->nextPtr;
- TclSpliceTailcall(interp, cbPtr);
+ SpliceTailcall(interp, cbPtr, 0);
return TCL_OK;
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index c3201a5..715c404 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.490 2010/08/18 15:44:12 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.491 2010/08/18 22:33:27 msofer Exp $
*/
#include "tclInt.h"
@@ -2905,13 +2905,13 @@ TclExecuteByteCode(
* If the CallFrame is marked as tailcalling, keep tailcalling
*/
- if (iPtr->varFramePtr->tailcallPtr) {
+ if (iPtr->varFramePtr->isProcCallFrame & FRAME_TAILCALLING) {
if (catchTop == initCatchTop) {
goto abnormalReturn;
}
- TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
- iPtr->varFramePtr->tailcallPtr = NULL;
+ iPtr->varFramePtr->isProcCallFrame &= ~FRAME_TAILCALLING;
+ TclRemoveTailcall(interp);
Tcl_SetResult(interp,
"tailcall called from within a catch environment",
TCL_STATIC);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2f18375..881dec4 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.480 2010/08/18 15:44:12 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.481 2010/08/18 22:33:27 msofer Exp $
*/
#ifndef _TCLINT
@@ -1152,10 +1152,10 @@ typedef struct CallFrame {
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
- struct TEOV_callback *tailcallPtr;
- /* The callback implementing the call to be
- * executed by the command that pushed this
- * frame. */
+ struct TEOV_callback *wherePtr;
+ /* The top of the callback stack when this
+ * frame was pushed; used to find the spot
+ * where to tailcall to. */
} CallFrame;
#define FRAME_IS_PROC 0x1
@@ -1168,6 +1168,8 @@ typedef struct CallFrame {
* field contains an Object reference that has
* been confirmed to refer to a class. Part of
* TIP#257. */
+#define FRAME_TAILCALLING 0x10 /* Flag is set while the CallFrame is winding
+ * down to process a tailcall */
/*
* TIP #280
@@ -2756,10 +2758,8 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
-MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp,
- struct TEOV_callback *tailcallPtr);
-MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
- struct TEOV_callback *tailcallPtr);
+MODULE_SCOPE void TclRemoveTailcall(Tcl_Interp *interp);
+
MODULE_SCOPE Tcl_NRPostProc TclNRBlockTailcall;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 401eea4..5bd3c24 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -22,7 +22,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.210 2010/08/18 15:44:13 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.211 2010/08/18 22:33:27 msofer Exp $
*/
#include "tclInt.h"
@@ -313,15 +313,27 @@ Tcl_PushCallFrame(
framePtr->compiledLocals = NULL;
framePtr->clientData = NULL;
framePtr->localCachePtr = NULL;
- framePtr->tailcallPtr = NULL;
/*
+ * Record the top of the callback stack, so that tailcall can identify
+ * the spot where to splice the new command.
+ */
+
+ if (iPtr->execEnvPtr) {
+ framePtr->wherePtr = TOP_CB(interp);
+ } else {
+ framePtr->wherePtr = NULL;
+ }
+
+
+ /*
* Push the new call frame onto the interpreter's stack of procedure call
* frames making it the current frame.
*/
iPtr->framePtr = framePtr;
iPtr->varFramePtr = framePtr;
+
return TCL_OK;
}
@@ -391,10 +403,6 @@ Tcl_PopCallFrame(
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
-
- if (framePtr->tailcallPtr) {
- TclSpliceTailcall(interp, framePtr->tailcallPtr);
- }
}
/*