diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclBasic.c | 134 | ||||
| -rw-r--r-- | generic/tclExecute.c | 8 | ||||
| -rw-r--r-- | generic/tclInt.h | 18 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 20 |
5 files changed, 123 insertions, 68 deletions
@@ -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); - } } /* |