diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 319 | ||||
| -rw-r--r-- | generic/tclExecute.c | 239 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclNRE.h | 14 | ||||
| -rw-r--r-- | generic/tclProc.c | 6 | ||||
| -rw-r--r-- | tests/NRE.test | 35 |
7 files changed, 373 insertions, 254 deletions
@@ -1,3 +1,12 @@ +2008-07-21 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic.c: NRE: enabled calling NR commands + * generic/tclExecute.c: from the callbacks. Completely + * generic/tclInt.h: redone tailcall implementation + * generic/tclNRE.h: using the new feature. + * generic/tclProc.c: + * tests/NRE.test: + 2008-07-20 Kevin B. Kenny <kenykb@acm.org> * tests/fileName.test: Repaired the failing test fileName-15.7 diff --git a/generic/tclBasic.c b/generic/tclBasic.c index eb35aaf..c06a514 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.316 2008/07/18 23:29:41 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.317 2008/07/21 03:43:26 msofer Exp $ */ #include "tclInt.h" @@ -129,6 +129,8 @@ static Tcl_NRPostProc TEOV_Error; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOEx_ByteCodeCallback; +static Tcl_NRPostProc TailcallCallback; + /* * The following structure define the commands in the Tcl core. */ @@ -4082,21 +4084,13 @@ Tcl_EvalObjv( * record and proceed with the next call. */ + callbackReentryPoint: switch(recordPtr->type) { case TCL_NR_NO_TYPE: break; case TCL_NR_BC_TYPE: tcl_nr_bc_type: if (USE_NR_TEBC && tebcCall) { - /* - * We were called by TEBC, and we need a bytecode to be executed: - * just ask our caller to do that. - * TEBC_CALL(iPtr) = TEBC_DO_EXEC = 0 is not really needed, as it - * is already 0==TEBC_DO_EXEC - */ - - TEBC_CALL(iPtr) = TEBC_DO_EXEC; - TEBC_DATA(iPtr) = recordPtr->data.codePtr; return TCL_OK; } @@ -4107,40 +4101,17 @@ Tcl_EvalObjv( result = TclExecuteByteCode(interp, recordPtr->data.codePtr); goto done; - case TCL_NR_TAILCALL_TYPE: { + case TCL_NR_TAILCALL_TYPE: /* - * Got to save this record, free the stack (i.e., perform all pending - * callbacks) and restore the record. + * Proceed to cleanup the current command, the tailcall will be run + * from the callbacks. */ - Tcl_Obj *tailObjPtr = recordPtr->data.obj.objPtr; - - result = TclEvalObjv_NR2(interp, result, rootPtr); - - if (result != TCL_OK) { - goto done; - } if (USE_NR_TEBC && tebcCall) { - /* - * We were called by TEBC, and we need it to drop a frame: let him - * know. - */ - - TEBC_CALL(iPtr) = TEBC_DO_TAILCALL; - TEBC_DATA(iPtr) = tailObjPtr; return TCL_OK; } - - /* - * ONLY supported if called from TEBC. Could do an 'uplevel 1'? Run - * from here (as hinted below)? Mmhhh ... FIXME. Maybe tailcalls - * SHOULD actually be bytecompiled (we know how to more or less fake - * it when falling off TEBC)? - */ - - Tcl_Panic("tailcall called from a non-compiled command?"); - /* FALL THROUGH */ - } + recordPtr->type = TCL_NR_NO_TYPE; + break; case TCL_NR_CMD_TYPE: { /* * We got an unshared canonical list to eval , do it from here. @@ -4182,8 +4153,7 @@ Tcl_EvalObjv( case TCL_NR_OBJPROC_TYPE: /* * This is a rewrite like ns-import does, without a new cmdPtr or new - * reentrant call. FIXME: add the possibility of a new callback - * (Tcl_NRObjProc has that), and maybe also edition of objc/objv? + * reentrant call. FIXME NRE: add edition of objc/objv? */ objProc = recordPtr->data.objProc.objProc; @@ -4195,7 +4165,19 @@ Tcl_EvalObjv( } done: - return TclEvalObjv_NR2(interp, result, rootPtr); + result = TclEvalObjv_NR2(interp, result, rootPtr); + recordPtr = TOP_RECORD(iPtr); + if (recordPtr == rootPtr) { + return result; + } + + /* + * A callback scheduled a new evaluation! Deal with it. + * Note that recordPtr was already updated right above. + */ + + assert((result == TCL_OK)); + goto callbackReentryPoint; } int @@ -4206,6 +4188,7 @@ TclEvalObjv_NR2( { Interp *iPtr = (Interp *) interp; TEOV_record *recordPtr; + TEOV_callback *callbackPtr; /* * If the interpreter has a non-empty string result, the result object is @@ -4221,17 +4204,41 @@ TclEvalObjv_NR2( (void) Tcl_GetObjResult(interp); } - while (TOP_RECORD(iPtr) != rootPtr) { - POP_RECORD(iPtr, recordPtr); - + restart: + while ((recordPtr = TOP_RECORD(iPtr)) != rootPtr) { while (recordPtr->callbackPtr) { - TEOV_callback *callbackPtr = recordPtr->callbackPtr; - + callbackPtr = recordPtr->callbackPtr; + recordPtr->callbackPtr = callbackPtr->nextPtr; result = callbackPtr->procPtr(callbackPtr->data, interp, result); - callbackPtr = callbackPtr->nextPtr; - TclSmallFree(recordPtr->callbackPtr); - recordPtr->callbackPtr = callbackPtr; + TclSmallFree(callbackPtr); + + if (recordPtr != TOP_RECORD(iPtr)) { + + if (result != TCL_OK) { + goto restart; + } + + /* + * A callback scheduled a new evaluation; return so that our + * caller can run it. + */ + + switch(recordPtr->type) { + case TCL_NR_NO_TYPE: + goto restart; + case TCL_NR_BC_TYPE: + case TCL_NR_CMD_TYPE: + case TCL_NR_SCRIPT_TYPE: + goto done; + case TCL_NR_TAILCALL_TYPE: + Tcl_Panic("Tailcall called from a callback!"); + default: + Tcl_Panic("TEOV_NR2: invalid record type: %d", + recordPtr->type); + } + } } + TOP_RECORD(iPtr) = recordPtr->nextPtr; if (!CHECK_EXTRA(iPtr, recordPtr)) { Tcl_Panic("TclEvalObjv_NR2: wrong tosPtr?"); @@ -4257,6 +4264,8 @@ TclEvalObjv_NR2( * check at the end. */ + done: + if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); } @@ -7394,48 +7403,62 @@ NRPostProcess( int objc, Tcl_Obj *const objv[]) { - TEOV_record *recordPtr = TOP_RECORD(interp); - - if ((result == TCL_OK) && VALID_NEW_REQUEST(recordPtr)) { + TEOV_record *recordPtr, *rootPtr = TOP_RECORD(interp)->nextPtr; + + restart: + recordPtr = TOP_RECORD(interp); + if (result == TCL_OK) { switch (recordPtr->type) { - case TCL_NR_BC_TYPE: - result = TclExecuteByteCode(interp, recordPtr->data.codePtr); - break; - case TCL_NR_CMD_TYPE: { - Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; - int flags = recordPtr->data.obj.flags; - Tcl_Obj **objv; - int objc; - - Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); - result = Tcl_EvalObjv(interp, objc, objv, flags); - break; - } - case TCL_NR_SCRIPT_TYPE: { - Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; - int flags = recordPtr->data.obj.flags; - - result = TclEvalObjEx(interp, objPtr, flags, NULL, 0); - break; - } - case TCL_NR_OBJPROC_TYPE: { - Tcl_ObjCmdProc *objProc = recordPtr->data.objProc.objProc; - ClientData clientData = recordPtr->data.objProc.clientData; - - if (!objc) { - Tcl_Panic("NRPostProcess: something is very wrong!"); + case TCL_NR_NO_TYPE: + break; + case TCL_NR_BC_TYPE: + result = TclExecuteByteCode(interp, recordPtr->data.codePtr); + break; + case TCL_NR_TAILCALL_TYPE: + Tcl_SetResult(interp, + "impossible to tailcall from a non-NRE enabled command", + TCL_STATIC); + result = TCL_ERROR; + break; + case TCL_NR_CMD_TYPE: { + Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; + int flags = recordPtr->data.obj.flags; + Tcl_Obj **objv; + int objc; + + Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + result = Tcl_EvalObjv(interp, objc, objv, flags); + break; } - result = (*objProc)(clientData, interp, objc, objv); - break; - } - default: - Tcl_Panic("NRPostProcess: invalid record type: %d", - recordPtr->type); + case TCL_NR_SCRIPT_TYPE: { + Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; + int flags = recordPtr->data.obj.flags; + + result = TclNREvalObjEx(interp, objPtr, flags, NULL, 0); + break; + } + case TCL_NR_OBJPROC_TYPE: { + Tcl_ObjCmdProc *objProc = recordPtr->data.objProc.objProc; + ClientData clientData = recordPtr->data.objProc.clientData; + + if (!objc) { + Tcl_Panic("NRPostProcess: something is very wrong!"); + } + result = (*objProc)(clientData, interp, objc, objv); + break; + } + default: + Tcl_Panic("NRPostProcess: invalid record type: %d", + recordPtr->type); } } - - assert((TOP_RECORD(interp) == recordPtr)); - return TclEvalObjv_NR2(interp, result, recordPtr->nextPtr); + + result = TclEvalObjv_NR2(interp, result, rootPtr); + if (TOP_RECORD(interp) != rootPtr) { + assert((result == TCL_OK)); + goto restart; + } + return result; } /* @@ -7599,11 +7622,12 @@ Tcl_NRObjProc( * (b) 'a' is looked up in the returning frame's namespace, but the * command is run in the context to which we are returning * Current implementation does this if [tailcall] is called from within - * a proc, panics otherwise- + * a proc, errors otherwise. * (2) Should a tailcall bypass [catch] in the returning frame? Current - * implementation does not - it causes an error. + * implementation does not (or does it? Changed, test!) - it causes an + * error. * - * FIXME! + * FIXME NRE! */ int @@ -7614,25 +7638,122 @@ TclTailcallObjCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - TEOV_record *recordPtr = TOP_RECORD(interp); + TEOV_record *rootPtr = TOP_RECORD(interp); + TEOV_callback *headPtr, *tailPtr; + TEOV_record *tmpPtr; Tcl_Obj *listPtr; - - /* - * Do NOT allow tailcall to be called from a non-proc/lambda: tough to - * manage the proper semantics, especially for [uplevel $x tailcall foo] - */ + Command *cmdPtr; + Namespace *nsPtr = iPtr->varFramePtr->nsPtr; if (!iPtr->varFramePtr->isProcCallFrame) { + /* FIXME! Why error? Just look if we have a TEOV above! */ Tcl_SetResult(interp, "tailcall can only be called from a proc or lambda", TCL_STATIC); return TCL_ERROR; } - + + nsPtr->activationCount++; listPtr = Tcl_NewListObj(objc-1, objv+1); - Tcl_NREvalObj(interp, listPtr, 0); - recordPtr->type = TCL_NR_TAILCALL_TYPE; + rootPtr->type = TCL_NR_TAILCALL_TYPE; + + /* + * Add a callback to perform the tailcall as LAST item in the caller's + * callback stack. + * Find the first record for the caller: start at the one below the top + * (the top being this command's record), and go back until you find + * the one that contains the cmdPtr. + */ + + tmpPtr = rootPtr->nextPtr; + while (tmpPtr->cmdPtr == NULL) { + tmpPtr = tmpPtr->nextPtr; + } + + /* + * Now find the first and last callbacks in this record, and temporarily + * set the callback list to empty. + */ + + headPtr = tailPtr = tmpPtr->callbackPtr; + if (headPtr) { + while (tailPtr->nextPtr) { + tailPtr = tailPtr->nextPtr; + } + tmpPtr->callbackPtr = NULL; + } + + /* + * Temporarily put tmpPtr as the TOP_RECORD, register a callback, then + * replug things back the way they were. + */ + + TOP_RECORD(iPtr) = tmpPtr; + TclNRAddCallback(interp, TailcallCallback, listPtr, nsPtr, NULL, NULL); + TOP_RECORD(iPtr) = rootPtr; + + if (headPtr) { + tailPtr->nextPtr = tmpPtr->callbackPtr; + tmpPtr->callbackPtr = headPtr; + } + return TCL_OK; } + +static int +TailcallCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *listPtr = data[0], *namePtr; + Namespace *nsPtr = data[1]; + TEOV_record *recordPtr = TOP_RECORD(iPtr); + Command *cmdPtr; + + if (!recordPtr->cmdPtr || recordPtr->callbackPtr) { + Tcl_Panic("TailcallCallback: should not happen!"); + } + + result = Tcl_ListObjIndex(interp, listPtr, 0, &namePtr); + if (result == TCL_OK) { + cmdPtr = TEOV_LookupCmdFromObj(interp, namePtr, nsPtr); + } + + nsPtr->activationCount--; + if ((nsPtr->flags & NS_DYING) + && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { + /* + * FIXME NRE tailcall: is this the proper way to manage this? This is + * like what CallFrames do. + */ + + Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); + } + + if (!cmdPtr || (result != TCL_OK)) { + Tcl_DecrRefCount(listPtr); + Tcl_SetResult(interp, + "the command to be tailcalled does not exist", TCL_STATIC); + return TCL_ERROR; + } + + /* + * Take over the previous command's record. + */ + + TclCleanupCommandMacro(recordPtr->cmdPtr); + recordPtr->cmdPtr = cmdPtr; + cmdPtr->refCount++; + + /* + * Push a new record to signal that a new command was scheduled. + */ + + PUSH_RECORD(iPtr, recordPtr); + iPtr->lookupNsPtr = nsPtr; + return TclNREvalCmd(interp, listPtr, 0); +} void Tcl_NRAddCallback( diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7b9ae49..6243266 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.382 2008/07/18 23:29:43 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.383 2008/07/21 03:43:30 msofer Exp $ */ #include "tclInt.h" @@ -25,9 +25,6 @@ #include <math.h> #include <float.h> -static Tcl_NRPostProc TailcallFromTebc; - - /* * Hack to determine whether we may expect IEEE floating point. The hack is * formally incorrect in that non-IEEE platforms might have the same precision @@ -1757,10 +1754,6 @@ TclExecuteByteCode( BottomData *bottomPtr; #if USE_NR_TEBC BottomData *oldBottomPtr = NULL; - - /* for tailcall support */ - Namespace *lookupNsPtr = NULL; - Tcl_Obj *tailObjPtr = NULL; #endif /* @@ -1800,7 +1793,10 @@ TclExecuteByteCode( register int cleanup; Tcl_Obj *objResultPtr; - + int evalFlags = TCL_EVAL_NOERR; +#if (USE_NR_TEBC) + int tailcall = 0; +#endif /* * Result variable - needed only when going to checkForcatch or other * error handlers; also used as local in some opcodes. @@ -1880,24 +1876,9 @@ TclExecuteByteCode( bcFramePtr->data.tebc.pc = NULL; bcFramePtr->cmd.str.cmd = NULL; bcFramePtr->cmd.str.len = 0; -#if USE_NR_TEBC - } else if (tailObjPtr) { - /* - * A request to perform a tailcall; a frame has already been dropped, - * so we just have to ... - * (Note that we already have a refcount for tailObjPtr!) - */ - - *++tosPtr = tailObjPtr; - tailObjPtr = NULL; - iPtr->lookupNsPtr = lookupNsPtr; - lookupNsPtr = NULL; - - /* - * Fake pc, INST_EVAL STK will fix this and resume properly - */ - pc--; - goto tailCallEntryPoint; +#if (USE_NR_TEBC) + } else if (tailcall) { + goto tailcallEntry; #endif } else { /* @@ -2497,7 +2478,11 @@ TclExecuteByteCode( int objc, pcAdjustment; Tcl_Obj **objv; - +#if (USE_NR_TEBC) + TEOV_record *recordPtr; + ByteCode *newCodePtr; +#endif + case INST_EXPR_STK: { /* * Moved here to support transforming the eval of an expression to @@ -2505,13 +2490,12 @@ TclExecuteByteCode( */ #if (USE_NR_TEBC) - pcAdjustment = 1; cleanup = 1; bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; DECACHE_STACK_INFO(); - TEBC_DATA(iPtr) = CompileExprObj(interp, OBJ_AT_TOS); + newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); CACHE_STACK_INFO(); goto tebc_do_exec; #else @@ -2536,8 +2520,28 @@ TclExecuteByteCode( #endif } +#if (USE_NR_TEBC) + tailcallEntry: { + TEOV_record *recordPtr = TOP_RECORD(iPtr); - tailCallEntryPoint: + /* + * We take over the record's object, with its refCount. Clear the + * record type so that it is not freed again when popping the + * record. + */ + + recordPtr->type = TCL_NR_NO_TYPE; + *++tosPtr = recordPtr->data.obj.objPtr; + evalFlags = recordPtr->data.obj.flags; + recordPtr->type = TCL_NR_NO_TYPE; +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " Tailcall: pushing obj with refCount %i\n", + (OBJ_AT_TOS)->refCount); + } +#endif + } +#endif case INST_EVAL_STK: { /* * Moved here to support transforming the eval of objects to a @@ -2546,16 +2550,25 @@ TclExecuteByteCode( */ Tcl_Obj *objPtr = OBJ_AT_TOS; - ByteCode *newCodePtr; - pcAdjustment = 1; cleanup = 1; - + pcAdjustment = !tailcall; + tailcall = 0; + if (objPtr->typePtr == &tclListType) { /* is a list... */ List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *copyPtr; if (objPtr->bytes == NULL || /* ...without a string rep */ - listRepPtr->canonicalFlag) {/* ...or that is canonical */ + listRepPtr->canonicalFlag) {/* ...or that is canonical + * */ + if (Tcl_IsShared(objPtr)) { + copyPtr = TclListObjCopy(interp, objPtr); + Tcl_IncrRefCount(copyPtr); + OBJ_AT_TOS = copyPtr; + listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; + Tcl_DecrRefCount(objPtr); + } objc = listRepPtr->elemCount; objv = &listRepPtr->elements; goto doInvocationFromEval; @@ -2576,8 +2589,7 @@ TclExecuteByteCode( */ #if (USE_NR_TEBC) bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - TEBC_DATA(iPtr) = newCodePtr; + iPtr->cmdFramePtr = bcFramePtr; goto tebc_do_exec; #else result = TclExecuteByteCode(interp, newCodePtr); @@ -2692,49 +2704,50 @@ TclExecuteByteCode( DECACHE_STACK_INFO(); +#if (USE_NR_TEBC) TEBC_CALL(iPtr) = 1; - result = Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_NOERR); + recordPtr = TOP_RECORD(iPtr); +#endif + result = Tcl_EvalObjv(interp, objc, objv, evalFlags); CACHE_STACK_INFO(); #if (USE_NR_TEBC) - switch (TEBC_CALL(iPtr)) { - case TEBC_DO_EXEC: { + evalFlags = TCL_EVAL_NOERR; + if (TOP_RECORD(iPtr) != recordPtr) { + assert((result == TCL_OK)); + recordPtr = TOP_RECORD(iPtr); + switch(recordPtr->type) { + case TCL_NR_BC_TYPE: + newCodePtr = recordPtr->data.codePtr; tebc_do_exec: /* * A request to execute a bytecode came back. We save * the current state and restart at the top. */ - assert((result == TCL_OK)); - TEBC_CALL(iPtr) = 0; + pc += pcAdjustment; NR_DATA_BURY(); /* this level's state variables */ - codePtr = TEBC_DATA(iPtr); - result = TCL_OK; + codePtr = newCodePtr; goto nonRecursiveCallStart; - } - case TEBC_DO_TAILCALL: { + case TCL_NR_TAILCALL_TYPE: /* - * A request to perform a tailcall: save the current - * namespace, drop a frame and eval the passed listObj - * in the previous frame while looking up the command - * in the current namespace. Read it again. - * - * We take over tailObjPtr's refcount! + * A request to perform a tailcall: just drop this + * bytecode as it is; the tailCall has been scheduled in + * the callbacks. */ - - assert((result == TCL_OK)); - TEBC_CALL(iPtr) = 0; - tailObjPtr = TEBC_DATA(iPtr); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " Tailcall: request received\n"); + } +#endif if (catchTop != initCatchTop) { result = TCL_ERROR; Tcl_SetResult(interp,"Tailcall called from within a catch environment", TCL_STATIC); - Tcl_DecrRefCount(tailObjPtr); - tailObjPtr = NULL; goto checkForCatch; } - lookupNsPtr = iPtr->varFramePtr->nsPtr; - result = TCL_OK; goto abnormalReturn; /* drop a level */ + default: + Tcl_Panic("TEBC: TEOV sent us a record we cannot handle!"); } } #endif @@ -2742,7 +2755,6 @@ TclExecuteByteCode( if (result == TCL_OK) { Tcl_Obj *objPtr; - #ifndef TCL_COMPILE_DEBUG if (*(pc+pcAdjustment) == INST_POP) { NEXT_INST_V((pcAdjustment+1), cleanup, 0); @@ -7760,14 +7772,49 @@ TclExecuteByteCode( * * NR_TEBC */ - bottomPtr = oldBottomPtr; /* back to old bc */ /* Please free anything that might still be on my new stack */ - result = TclEvalObjv_NR2(interp, result, bottomPtr->recordPtr); - assert((TOP_RECORD(iPtr) == bottomPtr->recordPtr)); - - /* restore state variables */ + if (TOP_RECORD(iPtr) != bottomPtr->recordPtr) { + CACHE_STACK_INFO(); + result = TclEvalObjv_NR2(interp, result, bottomPtr->recordPtr); + if (TOP_RECORD(iPtr) != bottomPtr->recordPtr) { + TEOV_record *recordPtr = TOP_RECORD(iPtr); + + assert((result == TCL_OK)); + + /* + * A callback scheduled a new evaluation: process it. + */ + + switch(recordPtr->type) { + case TCL_NR_BC_TYPE: + codePtr = recordPtr->data.codePtr; + goto nonRecursiveCallStart; + case TCL_NR_TAILCALL_TYPE: + /* FIXME NRE tailcall*/ + Tcl_Panic("Tailcall called from a callback!"); + NR_DATA_DIG(); + esPtr = iPtr->execEnvPtr->execStackPtr; + goto abnormalReturn; /* drop a level */ + case TCL_NR_CMD_TYPE: + case TCL_NR_SCRIPT_TYPE: + /* + * FIXME NRE tailcall: error messages will be all wrong? + */ +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " Tailcall: eval request received from callback\n"); + } +#endif + tailcall = 1; + goto restoreStateVariables; + default: + Tcl_Panic("TEBC: TEOV_NR2 sent us a record we cannot handle!"); + } + } + } + restoreStateVariables: NR_DATA_DIG(); esPtr = iPtr->execEnvPtr->execStackPtr; tosPtr = esPtr->tosPtr; @@ -7778,69 +7825,9 @@ TclExecuteByteCode( CACHE_STACK_INFO(); goto nonRecursiveCallReturn; } - - if (tailObjPtr && result == TCL_OK) { - /* - * The best we can do here is to add the tailcall at the FRONT of the - * callback list. This will be a real tailcall if we're lucky to have - * been called from TEOV (or similar), and not-quite-but-almost if - * called from eg TclOO (I think). - * The simplest way to add to the front is: - * (a) push a new record - * (b) add the tailcall as callback to the newly-created 2nd record - * (c) swap the two top records: old top is still top, newly created - * record is second - */ - - TEOV_record *rootPtr, *recordPtr; - - rootPtr = TOP_RECORD(iPtr); - PUSH_RECORD(iPtr, recordPtr); - TclNRAddCallback(interp, TailcallFromTebc, tailObjPtr, lookupNsPtr, NULL, NULL); - - /* Now swap them! */ - recordPtr->nextPtr = rootPtr->nextPtr; - rootPtr->nextPtr = recordPtr; - TOP_RECORD(iPtr) = rootPtr; - } #endif return result; } - -static int -TailcallFromTebc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj *tailObjPtr = data[0]; - Namespace *lookupNsPtr = data[1]; - int objc; - Tcl_Obj **objv; - - Tcl_IncrRefCount(tailObjPtr); /* unshared per construction! */ - if (result != TCL_OK) { - goto done; - } - result = Tcl_ListObjGetElements(NULL, tailObjPtr, &objc, &objv); - if (result != TCL_OK) { - /* shouldn't happen */ - goto done; - } - - /* - * Note that by this time the proc's frame SHOULD BE ALREADY POPPED! We do - * as if it was (don't know what happens with eg TclOO), ie, assume that - * are already in [uplevel 1] from the proc's callFrame.. - */ - - iPtr->lookupNsPtr = lookupNsPtr; - result = Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_INVOKE); - - done: - Tcl_DecrRefCount(tailObjPtr); - return result; -} #undef iPtr #ifdef TCL_COMPILE_DEBUG diff --git a/generic/tclInt.h b/generic/tclInt.h index 202f5b8..93fa71b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.373 2008/07/13 16:07:19 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.374 2008/07/21 03:43:31 msofer Exp $ */ #ifndef _TCLINT @@ -1319,9 +1319,6 @@ typedef struct ExecEnv { int tebcCall; /* used to distinguish tebc calls from * other calls to TEOV, and other comms * between TEBC and TEOV */ - ClientData tebcData; /* used by TEOV to pass data to its - * calling TEBC */ - } ExecEnv; /* diff --git a/generic/tclNRE.h b/generic/tclNRE.h index 08ddcd5..4d44ab2 100644 --- a/generic/tclNRE.h +++ b/generic/tclNRE.h @@ -11,7 +11,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * // FIXME: RCS numbering? - * RCS: @(#) $Id: tclNRE.h,v 1.4 2008/07/18 23:29:44 msofer Exp $ + * RCS: @(#) $Id: tclNRE.h,v 1.5 2008/07/21 03:43:32 msofer Exp $ */ @@ -102,7 +102,7 @@ typedef struct TEOV_record { TEOV_callback *callbackPtr; struct TEOV_record *nextPtr; union { - struct ByteCode *codePtr; + struct ByteCode *codePtr; /* TCL_NR_BC_TYPE */ struct { Tcl_Obj *objPtr; int flags; @@ -111,10 +111,6 @@ typedef struct TEOV_record { Tcl_ObjCmdProc *objProc; ClientData clientData; } objProc; - struct { - int objc; - Tcl_Obj *const *objv; - } objv; } data; #if !USE_SMALL_ALLOC /* Extra checks: can disappear later */ @@ -165,12 +161,6 @@ typedef struct TEOV_record { #define TEBC_CALL(iPtr) \ (((Interp *)iPtr)->execEnvPtr->tebcCall) -#define TEBC_DATA(iPtr) \ - (((Interp *)iPtr)->execEnvPtr->tebcData) - -#define TEBC_DO_EXEC 1 /* MUST NOT be 0 */ -#define TEBC_DO_TAILCALL 2 - #define TclNRAddCallback(\ interp,\ postProcPtr,\ diff --git a/generic/tclProc.c b/generic/tclProc.c index 187c789..713ee18 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.149 2008/07/19 22:50:41 nijtmans Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.150 2008/07/21 03:43:32 msofer Exp $ */ #include "tclInt.h" @@ -1737,6 +1737,10 @@ TclObjInterpProcCore( if (result == TCL_OK) { result = TclExecuteByteCode(interp, record.data.codePtr); result = TclEvalObjv_NR2(interp, result, rootPtr); + if (TOP_RECORD(iPtr) != rootPtr) { + /* FIXME NRE & tailcalls */ + Tcl_Panic("TclObjInterpProcCore not yet prepared to deal with evals in callbacks!"); + } result = InterpProcNR2(record.callbackPtr->data, interp, result); TclSmallFree(record.callbackPtr); } diff --git a/tests/NRE.test b/tests/NRE.test index 19bb38f..a881675 100644 --- a/tests/NRE.test +++ b/tests/NRE.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: NRE.test,v 1.4 2008/07/20 23:57:27 das Exp $ +# RCS: @(#) $Id: NRE.test,v 1.5 2008/07/21 03:43:32 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -332,22 +332,33 @@ namespace import tcl::unsupported::tailcall test NRE-T.1 {tailcall} -constraints {tailcall} -body { namespace eval a { - unset -nocomplain x - proc aset args {uplevel 1 [list set {*}$args]} - proc foo {} {tailcall aset x 1} + variable x *::a + proc xset {} { + set tmp {} + set ns {[namespace current]} + set level [info level] + for {set i 0} {$i <= [info level]} {incr i} { + uplevel #$i "set x $i$ns" + lappend tmp "$i [info level $i]" + } + lrange $tmp 1 end + } + proc foo {} {tailcall xset; set x noreach} } namespace eval b { - unset -nocomplain x - proc aset args {error b::aset} - proc moo {} {set x 0; ::a::foo; set x} + variable x *::b + proc xset args {error b::xset} + proc moo {} {set x 0; variable y [::a::foo]; set x} } - unset -nocomplain x - proc aset args {error ::aset} - ::b::moo + variable x *:: + proc xset args {error ::xset} + list [::b::moo] | $x $a::x $b::x | $::b::y } -cleanup { - rename aset {} + unset x + rename xset {} namespace delete a b -} -result 1 +} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} + test NRE-T.2 {tailcall in non-proc} -constraints {tailcall} -body { list [catch {namespace eval a [list tailcall set x 1]} msg] $msg |