diff options
| -rw-r--r-- | generic/tcl.decls | 28 | ||||
| -rw-r--r-- | generic/tclBasic.c | 770 | ||||
| -rw-r--r-- | generic/tclCompile.h | 9 | ||||
| -rw-r--r-- | generic/tclDecls.h | 64 | ||||
| -rw-r--r-- | generic/tclExecute.c | 391 | ||||
| -rw-r--r-- | generic/tclInt.decls | 33 | ||||
| -rw-r--r-- | generic/tclInt.h | 24 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 85 | ||||
| -rw-r--r-- | generic/tclInterp.c | 19 | ||||
| -rw-r--r-- | generic/tclNRE.h | 215 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 12 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 7 | ||||
| -rw-r--r-- | generic/tclOOMethod.c | 19 | ||||
| -rw-r--r-- | generic/tclProc.c | 97 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 29 | ||||
| -rw-r--r-- | generic/tclTest.c | 38 |
16 files changed, 641 insertions, 1199 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 9700497..c67462e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.141 2008/07/28 21:31:15 nijtmans Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.142 2008/07/29 05:30:25 msofer Exp $ library tcl @@ -2108,25 +2108,31 @@ declare 581 generic { int Tcl_Canceled(Tcl_Interp *interp, int flags) } -# NRE public interface +# TIP#304 (chan pipe) + declare 582 generic { + int Tcl_CreatePipe (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags) +} + +# TIP #322 (NRE public interface) +declare 583 generic { Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, CONST char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } -declare 583 generic { +declare 584 generic { int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } -declare 584 generic { +declare 585 generic { int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) } -declare 585 generic { +declare 586 generic { int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, - Tcl_Obj *CONST objv[]) + Tcl_Obj *CONST objv[], int flags) } -declare 586 generic { +declare 587 generic { void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3) @@ -2134,18 +2140,12 @@ declare 586 generic { # For use by NR extenders, to have a simple way to also provide a (required!) # classic objProc -declare 587 generic { +declare 588 generic { int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *CONST objv[]) } -# TIP#304 (chan pipe) - -declare 588 generic { - int Tcl_CreatePipe (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags) -} - ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 87a36b3..cb96099 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.332 2008/07/28 21:06:09 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.333 2008/07/29 05:30:25 msofer Exp $ */ #include "tclInt.h" @@ -107,7 +107,7 @@ static int DTraceObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, MODULE_SCOPE const TclStubs * const tclConstStubsPtr; /* - * Block for Tcl_EvalObjv helpers + * Tcl_EvalObjv helpers */ static void TEOV_SwitchVarFrame(Tcl_Interp *interp); @@ -120,8 +120,6 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); -static int NRPostProcess(Tcl_Interp *interp, int result, - int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc TEOV_Exception; @@ -129,7 +127,26 @@ static Tcl_NRPostProc TEOV_Error; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOEx_ByteCodeCallback; -static Tcl_NRPostProc TailcallCallback; +static Tcl_NRPostProc NRCommand; +static Tcl_NRPostProc NRRunObjProc; + +static Tcl_NRPostProc EvalTailcall; + +#define NR_IS_COMMAND(callbackPtr) \ + (callbackPtr \ + && (callbackPtr->procPtr == NRCommand) \ + && (PTR2INT(callbackPtr->data[1]))) + +#define NR_CLEAR_COMMAND(interp) \ + TEOV_callback *callbackPtr = TOP_CB(interp); \ + \ + while (!NR_IS_COMMAND(callbackPtr)) { \ + callbackPtr = callbackPtr->nextPtr; \ + } \ + if (callbackPtr) { \ + callbackPtr->data[1] = INT2PTR(0); \ + } + /* * The following structure define the commands in the Tcl core. @@ -894,7 +911,7 @@ Tcl_CreateInterp(void) Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); } - TOP_RECORD(iPtr) = NULL; + TOP_CB(iPtr) = NULL; return interp; } @@ -3950,7 +3967,7 @@ Tcl_CancelEval( * TCL_ERROR. A result or error message is left in interp's result. * * Side effects: - * Depends on the command. + * Always pushes a callback. Other side effects depend on the command. * *---------------------------------------------------------------------- */ @@ -3967,11 +3984,15 @@ Tcl_EvalObjv( * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and * TCL_EVAL_NOERR are currently supported. */ { - return TclEvalObjv(interp, objc, objv, flags, NULL); + int result; + TEOV_callback *rootPtr = TOP_CB(interp); + + result = TclNREvalObjv(interp, objc, objv, flags, NULL); + return TclNRRunCallbacks(interp, result, rootPtr, 0); } int -TclEvalObjv( +TclNREvalObjv( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ int objc, /* Number of words in command. */ @@ -3987,40 +4008,38 @@ TclEvalObjv( { Interp *iPtr = (Interp *) interp; int result; - Namespace *lookupNsPtr = NULL; - TEOV_record *rootPtr = TOP_RECORD(iPtr); - TEOV_record *recordPtr; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; Tcl_ObjCmdProc *objProc; ClientData objClientData; - int tebcCall = TEBC_CALL(iPtr); - - TEBC_CALL(iPtr) = 0; - - if (cmdPtr) { - if (iPtr->lookupNsPtr) { - iPtr->lookupNsPtr = NULL; - } - PUSH_RECORD(interp, recordPtr); - goto commandFound; - } + Command **cmdPtrPtr; + + iPtr->lookupNsPtr = NULL; + + /* + * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] + * will be filled later when the command is found: save its address at + * objProcPtr. + * + * data[1] stores a marker for use by tailcalls; it will be reset to 0 by + * command redirectors (imports, alias, ensembles) so that tailcalls + * finishes the source command and not just the target. + */ - restartAtTop: + TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), + NULL, NULL); + cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]); + TclResetCancellation(interp, 0); iPtr->numLevels++; result = TclInterpReady(interp); if ((result != TCL_OK) || (objc == 0)) { - iPtr->lookupNsPtr = NULL; - iPtr->numLevels--; - goto done; + return result; } - /* - * Always push a record for the command (avoid queuing callbacks for an - * older command!) - */ - - PUSH_RECORD(interp, recordPtr); + if (cmdPtr) { + goto commandFound; + } /* * Push records for task to be done on return, in INVERSE order. First, if @@ -4035,12 +4054,9 @@ TclEvalObjv( * Configure evaluation context to match the requested flags. */ - lookupNsPtr = iPtr->lookupNsPtr; if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { if (!lookupNsPtr) { lookupNsPtr = iPtr->globalNsPtr; - } else { - iPtr->lookupNsPtr = NULL; } } else { if (flags & TCL_EVAL_GLOBAL) { @@ -4063,15 +4079,12 @@ TclEvalObjv( if (!cmdPtr) { notFound: result = TEOV_NotFound(interp, objc, objv, lookupNsPtr); - iPtr->numLevels--; - goto done; + return result; } iPtr->cmdCount++; if (TclLimitExceeded(iPtr->limit)) { - result = TCL_ERROR; - iPtr->numLevels--; - goto done; + return TCL_ERROR; } /* @@ -4090,8 +4103,7 @@ TclEvalObjv( goto notFound; } if (result != TCL_OK) { - iPtr->numLevels--; - goto done; + return result; } } @@ -4115,154 +4127,38 @@ TclEvalObjv( } /* - * Finally, invoke the command's Tcl_ObjCmdProc. - * - * Do the NR dance right here: - * - for non-NR enabled commands, just sigh and call the objProc - * - for NR-enabled commands call the part1, decide what to do with the - * continuation: - * . if it is a bytecode AND we were called by TEBC, pass it back. - * Otherwise just call a new TEBC on it. Don't register the - * callback, TEBC handles those. - * . if it is a command and it has a callback, push the callback - * into the TODO list, set the params as needed and restart at the - * top. - * - * Note that I removed the DTRACE thing: I have not really thought about - * where it really belongs, and do not really know what it does either. + * Fix the original callback to point to the now known cmdPtr. Insure that + * the Command struct lives until the command returns. */ - objProc = cmdPtr->nreProc; - if (!objProc) { - objProc = cmdPtr->objProc; - } - objClientData = cmdPtr->objClientData; - - COMPLETE_RECORD(recordPtr); + *cmdPtrPtr = cmdPtr; cmdPtr->refCount++; - - /* - * If this is an NR-enabled command, find the real objProc. - */ - - result = (*objProc)(objClientData, interp, objc, objv); - if (result != TCL_OK) { -#if 0 - TclStackPurge(interp, recordPtr->tosPtr); -#endif - goto done; - } - + /* - * We got a valid callback request: let us complete the corresponding - * record and proceed with the next call. + * Find the objProc to call: nreProc if available, objProc otherwise. Push + * a callback to do the actual running. */ - callbackReentryPoint: - switch(recordPtr->type) { - case TCL_NR_NO_TYPE: - break; - case TCL_NR_BC_TYPE: - tcl_nr_bc_type: - if (USE_NR_TEBC && tebcCall) { - return TCL_OK; - } - - /* - * No TEBC atop - we'll just have to instantiate a new one and do the - * callback on return. - */ - - result = TclExecuteByteCode(interp, recordPtr->data.codePtr); - goto done; - case TCL_NR_TAILCALL_TYPE: - /* - * Proceed to cleanup the current command, the tailcall will be run - * from the callbacks. - */ - - if (USE_NR_TEBC && tebcCall) { - return TCL_OK; - } - recordPtr->type = TCL_NR_NO_TYPE; - break; - case TCL_NR_CMD_TYPE: { - /* - * We got an unshared canonical list to eval , do it from here. - */ - - Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; - Tcl_Obj **elemPtr; - - flags = recordPtr->data.obj.flags; - Tcl_ListObjGetElements(NULL, objPtr, &objc, &elemPtr); - objv = elemPtr; - if (objc != 0) { - goto restartAtTop; - } - goto done; - } - case TCL_NR_SCRIPT_TYPE: { - Tcl_Obj *objPtr = recordPtr->data.obj.objPtr; - - flags = recordPtr->data.obj.flags; - if (USE_NR_TEBC && tebcCall) { - result = TclNREvalObjEx(interp, objPtr, flags, NULL, 0); - if (result == TCL_OK) { - switch (recordPtr->type) { - case TCL_NR_BC_TYPE: - goto tcl_nr_bc_type; - case TCL_NR_NO_TYPE: - goto done; - default: - Tcl_Panic("TEOEx called from TEOV returns unexpected record type: %d", - recordPtr->type); - } - } - } else { - result = TclEvalObjEx(interp, objPtr, flags, NULL, 0); - } - goto done; - } - case TCL_NR_CMDSWAP_TYPE: - /* - * This is a cmdPtr swap like ns-import does. - */ - - cmdPtr = recordPtr->cmdPtr; - objc = recordPtr->data.objcv.objc; - objv = recordPtr->data.objcv.objv; - recordPtr->type = TCL_NR_NO_TYPE; - goto commandFound; - default: - Tcl_Panic("TEOV: unknown NR-request type %i!", recordPtr->type); - } - - done: - result = TclEvalObjv_NR2(interp, result, rootPtr); - recordPtr = TOP_RECORD(iPtr); - if (recordPtr == rootPtr) { - return result; + objProc = cmdPtr->nreProc; + if (!objProc) { + objProc = cmdPtr->objProc; } + objClientData = cmdPtr->objClientData; - /* - * A callback scheduled a new evaluation! Deal with it. - * Note that recordPtr was already updated right above. - */ - - assert((result == TCL_OK)); - goto callbackReentryPoint; + TclNRAddCallback(interp, NRRunObjProc, objProc, objClientData, + INT2PTR(objc), (ClientData) objv); + return TCL_OK; } int -TclEvalObjv_NR2( +TclNRRunCallbacks( Tcl_Interp *interp, int result, - struct TEOV_record *rootPtr) + struct TEOV_callback *rootPtr, + int tebcCall) { Interp *iPtr = (Interp *) interp; - TEOV_record *recordPtr; - TEOV_callback *callbackPtr; + TEOV_callback *callbackPtr = TOP_CB(interp); /* * If the interpreter has a non-empty string result, the result object is @@ -4278,68 +4174,57 @@ TclEvalObjv_NR2( (void) Tcl_GetObjResult(interp); } - restart: - while ((recordPtr = TOP_RECORD(iPtr)) != rootPtr) { - while (recordPtr->callbackPtr) { - callbackPtr = recordPtr->callbackPtr; - recordPtr->callbackPtr = callbackPtr->nextPtr; - result = callbackPtr->procPtr(callbackPtr->data, interp, result); - TclSmallFree(callbackPtr); - - if (recordPtr != TOP_RECORD(iPtr)) { - - if (result != TCL_OK) { - goto restart; - } + while (TOP_CB(interp) != rootPtr) { + callbackPtr = TOP_CB(interp); + if (tebcCall) { + if ((callbackPtr->procPtr == NRRunBytecode) || + (callbackPtr->procPtr == NRDropCommand)) { /* - * A callback scheduled a new evaluation; return so that our - * caller can run it. + * TEBC pass thru: let the caller tebc handle and get rid of + * this callback. */ - 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: - case TCL_NR_CMDSWAP_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); - } + return TCL_OK; } } - TOP_RECORD(iPtr) = recordPtr->nextPtr; - - if (!CHECK_EXTRA(iPtr, recordPtr)) { - Tcl_Panic("TclEvalObjv_NR2: wrong tosPtr?"); - /* TclStackPurge(interp, recordPtr->tosPtr); */ - } /* - * Decrement the reference count of cmdPtr and deallocate it if it has - * dropped to zero. The level only needs fixing for records that - * pushed a cmdPtr. + * IMPLEMENTATION REMARKS (FIXME) + * + * Add here other direct handling possibilities for optimisation? + * One could handle the very frequent NRCommand and NRRunObjProc right + * here to save an indirect function call and improve icache + * management. Would it? Test it, time it ... */ - if (recordPtr->cmdPtr) { - TclCleanupCommandMacro(recordPtr->cmdPtr); - iPtr->numLevels--; - } - - FREE_RECORD(iPtr, recordPtr); + TOP_CB(interp) = callbackPtr->nextPtr; + result = callbackPtr->procPtr(callbackPtr->data, interp, result); + TCLNR_FREE(interp, callbackPtr); } + return result; +} - /* - * Do not interrupt a series of cleanups with async or limit checks: just - * check at the end. - */ +static int +NRCommand( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + Command *cmdPtr = data[0]; + /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - done: + + if (cmdPtr) { + TclCleanupCommandMacro(cmdPtr); + } + ((Interp *)interp)->numLevels--; + + /* OPT ?? + * Do not interrupt a series of cleanups with async or limit checks: + * just check at the end? + */ if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); @@ -4350,6 +4235,52 @@ TclEvalObjv_NR2( if (result == TCL_OK && TclLimitReady(iPtr->limit)) { result = Tcl_LimitCheck(interp); } + return result; +} + +static int +NRRunObjProc( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + /* OPT: do not call? */ + + Tcl_ObjCmdProc *objProc = data[0]; + ClientData objClientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + + if (result == TCL_OK) { + return (*objProc)(objClientData, interp, objc, objv); + } + return result; +} + +int +NRRunBytecode( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + ByteCode *codePtr = data[0]; + + if (result == TCL_OK) { + return TclExecuteByteCode(interp, codePtr); + } + return result; +} + +int +NRDropCommand( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + /* For tailcalls! + * drop all callbacks until the last command start: nothing to do here, + * just need this to be able to pass it up to tebc. + */ return result; } @@ -4670,7 +4601,7 @@ TEOV_RunLeaveTraces( Tcl_DecrRefCount(commandPtr); /* - * As cmdPtr is set, TclEvalObjv_NR2 is about to reduce the numlevels. + * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. * Prevent that by resetting the cmdPtr field and dealing right here with * cmdPtr->refCount. */ @@ -5110,7 +5041,7 @@ TclEvalEx( TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); iPtr->cmdFramePtr = eeFramePtr; - code = TclEvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR, NULL); + code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; TclArgumentRelease(interp, objv, objectsUsed); @@ -5706,17 +5637,10 @@ TclEvalObjEx( int word) /* Index of the word which is in objPtr. */ { int result = TCL_OK; - TEOV_record *recordPtr; - - /* - * Push an empty record. If this is an NR call, it will modify it - * accordingly. - */ + TEOV_callback *rootPtr = TOP_CB(interp); - PUSH_RECORD(interp, recordPtr); result = TclNREvalObjEx(interp, objPtr, flags, invoker, word); - assert((TOP_RECORD(interp) == recordPtr)); - return NRPostProcess(interp, result, 0, NULL); + return TclNRRunCallbacks(interp, result, rootPtr, 0); } int @@ -5759,28 +5683,15 @@ TclNREvalObjEx( if (objPtr->bytes == NULL || /* ...without a string rep */ listRepPtr->canonicalFlag) { /* ...or that is canonical */ + Tcl_Obj *listPtr = objPtr; + CmdFrame *eoFramePtr = NULL; + int objc; + Tcl_Obj **objv; + /* * TIP #280 Structures for tracking lines. As we know that this is * dynamic execution we ignore the invoker, even if known. - */ - - CmdFrame *eoFramePtr; - - eoFramePtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); - eoFramePtr->nline = 0; - eoFramePtr->line = NULL; - - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; - eoFramePtr->level = (iPtr->cmdFramePtr == NULL? - 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->numLevels = iPtr->numLevels; - eoFramePtr->framePtr = iPtr->framePtr; - eoFramePtr->nextPtr = iPtr->cmdFramePtr; - - eoFramePtr->cmd.listPtr = objPtr; - eoFramePtr->data.eval.path = NULL; - - /* + * * TIP #280. We do _not_ compute all the line numbers for the * words in the command. For the eval of a pure list the most * sensible choice is to put all words on line 1. Given that we @@ -5788,13 +5699,44 @@ TclNREvalObjEx( * left NULL. The two places using this information (TclInfoFrame, * and TclInitCompileEnv), are special-cased to use the proper * line number directly instead of accessing the 'line' array. + * + * Note that we use (word==INTMIN) to signal that no command frame + * should be pushed, as needed by alias and ensemble redirections. */ - iPtr->cmdFramePtr = eoFramePtr; + if (word != INT_MIN) { + eoFramePtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; + + eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? + 1 : iPtr->cmdFramePtr->level + 1); + eoFramePtr->numLevels = iPtr->numLevels; + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; + + eoFramePtr->cmd.listPtr = objPtr; + eoFramePtr->data.eval.path = NULL; + + iPtr->cmdFramePtr = eoFramePtr; + } + + /* + * Shimmer protection! Always pass an unshared obj. The caller could + * incr the refCount of objPtr AFTER calling us! To be completely safe + * we always make a copy. + * + * FIXME OPT: preserve just the internal rep? + */ + listPtr = TclListObjCopy(interp, objPtr); + Tcl_IncrRefCount(listPtr); TclNRAddCallback(interp, TEOEx_ListCallback, objPtr, eoFramePtr, - NULL, NULL); - return Tcl_NREvalObj(interp, objPtr, flags); + listPtr, NULL); + + ListObjGetElements(listPtr, objc, objv); + return TclNREvalObjv(interp, objc, objv, flags, NULL); } } @@ -5806,7 +5748,7 @@ TclNREvalObjEx( * We transfer this to the byte code compiler. */ - ByteCode *newCodePtr; + ByteCode *codePtr; CallFrame *savedVarFramePtr = NULL; /* Saves old copy of * iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ @@ -5815,18 +5757,12 @@ TclNREvalObjEx( savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; } + codePtr = TclCompileObj(interp, objPtr, invoker, word); + TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr, objPtr, INT2PTR(allowExceptions), NULL); - - newCodePtr = TclCompileObj(interp, objPtr, invoker, word); - if (newCodePtr) { - TEOV_record *recordPtr = TOP_RECORD(interp); - - recordPtr->type = TCL_NR_BC_TYPE; - recordPtr->data.codePtr = newCodePtr; - return TCL_OK; - } - return TCL_ERROR; + TclNRAddCallback(interp, NRRunBytecode, codePtr, NULL, NULL, NULL); + return TCL_OK; } /* @@ -5962,14 +5898,18 @@ TEOEx_ListCallback( Interp *iPtr = (Interp *) interp; Tcl_Obj *objPtr = data[0]; CmdFrame *eoFramePtr = data[1]; + Tcl_Obj *listPtr = data[2]; /* * Remove the cmdFrame */ - iPtr->cmdFramePtr = eoFramePtr->nextPtr; - TclStackFree(interp, eoFramePtr); + if (eoFramePtr) { + iPtr->cmdFramePtr = eoFramePtr->nextPtr; + TclStackFree(interp, eoFramePtr); + } TclDecrRefCount(objPtr); + TclDecrRefCount(listPtr); return result; } @@ -7764,76 +7704,10 @@ Tcl_NRCallObjProc( Tcl_Obj *const objv[]) { int result = TCL_OK; - TEOV_record *recordPtr; + TEOV_callback *rootPtr = TOP_CB(interp); - /* - * Push an empty record. If this is an NR call, it will modify it - * accordingly. - */ - - PUSH_RECORD(interp, recordPtr); result = (*objProc)(clientData, interp, objc, objv); - return NRPostProcess(interp, result, objc, objv); -} - -static int -NRPostProcess( - Tcl_Interp *interp, - int result, - int objc, - Tcl_Obj *const objv[]) -{ - TEOV_record *recordPtr, *rootPtr = TOP_RECORD(interp)->nextPtr; - - restart: - recordPtr = TOP_RECORD(interp); - if (result == TCL_OK) { - switch (recordPtr->type) { - 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 = TclEvalObjv(interp, objc, objv, flags, NULL); - break; - } - 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_CMDSWAP_TYPE: { - result = TclEvalObjv(interp, recordPtr->data.objcv.objc, - recordPtr->data.objcv.objv, 0, recordPtr->cmdPtr); - break; - } - default: - Tcl_Panic("NRPostProcess: invalid record type: %d", - recordPtr->type); - } - } - - result = TclEvalObjv_NR2(interp, result, rootPtr); - if (TOP_RECORD(interp) != rootPtr) { - assert((result == TCL_OK)); - goto restart; - } - return result; + return TclNRRunCallbacks(interp, result, rootPtr, 0); } /* @@ -7891,31 +7765,18 @@ Tcl_NRCreateCommand( return (Tcl_Command) cmdPtr; } -/* - * These are the previous contents of tclNRE.c, part of the NRE api. - * - * TclNREvalCmd should only be called as an optimisation: when objPtr is known - * to be a canonical list that is not (and will not!) be shared - */ +/**************************************************************************** + * Stuff for the public api + ****************************************************************************/ int -TclNREvalCmd( +Tcl_NREvalObj( Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) { - TEOV_record *recordPtr = TOP_RECORD(interp); - - Tcl_IncrRefCount(objPtr); - recordPtr->type = TCL_NR_CMD_TYPE; - recordPtr->data.obj.objPtr = objPtr; - recordPtr->data.obj.flags = flags; - return TCL_OK; + return TclNREvalObjEx(interp, objPtr, flags, NULL, INT_MIN); } - -/**************************************************************************** - * Stuff for the public api - ****************************************************************************/ int Tcl_NREvalObjv( @@ -7929,42 +7790,14 @@ Tcl_NREvalObjv( * TCL_EVAL_GLOBAL, TCL_EVAL_INVOKE and * TCL_EVAL_NOERR are currently supported. */ { - Tcl_Obj *listPtr = Tcl_NewListObj(objc, objv); - - return TclNREvalCmd(interp, listPtr, flags); + return TclNREvalObjv(interp, objc, objv, flags, NULL); } -int -Tcl_NREvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - int flags) +void +TclNRClearCommandFlag( + Tcl_Interp *interp) { - TEOV_record *recordPtr = TOP_RECORD(interp); - List *listRep = objPtr->internalRep.twoPtrValue.ptr1; - - Tcl_IncrRefCount(objPtr); - if ((objPtr->typePtr == &tclListType) - && (!objPtr->bytes || listRep->canonicalFlag)) { - /* - * Shimmer protection! Always pass an unshared obj. The caller could - * incr the refCount of objPtr AFTER calling us! To be completely safe - * we always make a copy. - */ - - Tcl_Obj *origPtr = objPtr; - - objPtr = TclListObjCopy(NULL, origPtr); - Tcl_IncrRefCount(objPtr); - TclDecrRefCount(origPtr); - - recordPtr->type = TCL_NR_CMD_TYPE; - } else { - recordPtr->type = TCL_NR_SCRIPT_TYPE; - } - recordPtr->data.obj.objPtr = objPtr; - recordPtr->data.obj.flags = flags; - return TCL_OK; + NR_CLEAR_COMMAND(interp); } int @@ -7972,16 +7805,14 @@ Tcl_NRCmdSwap( Tcl_Interp *interp, Tcl_Command cmd, int objc, - Tcl_Obj *const objv[]) + Tcl_Obj *const objv[], + int flags) { - TEOV_record *recordPtr = TOP_RECORD(interp); - - recordPtr->type = TCL_NR_CMDSWAP_TYPE; - recordPtr->cmdPtr = (Command *) cmd; - recordPtr->data.objcv.objc = objc; - recordPtr->data.objcv.objv = (Tcl_Obj **) objv; + int result; - return TCL_OK; + result = TclNREvalObjv(interp, objc, objv, flags, (Command *)cmd); + NR_CLEAR_COMMAND(interp); + return result; } /***************************************************************************** @@ -8016,85 +7847,82 @@ TclTailcallObjCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - TEOV_record *rootPtr = TOP_RECORD(interp); - TEOV_callback *headPtr, *tailPtr; - TEOV_record *tmpPtr; - Tcl_Obj *listPtr; + TEOV_callback *rootPtr = TOP_CB(interp); + TEOV_callback *tailPtr; + Tcl_Obj *scriptPtr; 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; + int count; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); } - nsPtr->activationCount++; - listPtr = Tcl_NewListObj(objc-1, objv+1); - rootPtr->type = TCL_NR_TAILCALL_TYPE; - /* - * Add a callback to perform the tailcall as LAST item in the caller's + * 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. + * Find the first record for the caller: + * 1. find the SECOND callback that contains a cmdPtr below the top (note + * that the FIRST one correspond to this TclTailcallObjCmd call) + * 2. set the callback for the tailcalled command below that */ - tmpPtr = rootPtr->nextPtr; - while (tmpPtr->cmdPtr == NULL) { - tmpPtr = tmpPtr->nextPtr; + tailPtr = rootPtr; + count = NR_IS_COMMAND(tailPtr); + while (tailPtr && tailPtr->nextPtr && (count < 2)) { + tailPtr = tailPtr->nextPtr; + count += NR_IS_COMMAND(tailPtr); } - /* - * 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; +#if 1 + 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; + } +#else + if (!tailPtr->nextPtr) { + /* FIXME! Is this the behaviour we want? */ + Tcl_SetResult(interp, + "cannot tailcall: not running a command", TCL_STATIC); + return TCL_ERROR; } +#endif /* - * Temporarily put tmpPtr as the TOP_RECORD, register a callback, then + * Temporarily put NULL as the TOP_BC, 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; + nsPtr->activationCount++; + if (objc == 2) { + scriptPtr = objv[1]; + } else { + scriptPtr = Tcl_NewListObj(objc-1, objv+1); } + TOP_CB(iPtr) = tailPtr->nextPtr; + TclNRAddCallback(interp, EvalTailcall, scriptPtr, nsPtr, NULL, NULL); + tailPtr->nextPtr = TOP_CB(iPtr); + TOP_CB(iPtr) = rootPtr; + + TclNRAddCallback(interp, NRDropCommand, NULL, NULL, NULL, NULL); return TCL_OK; } static int -TailcallCallback( +EvalTailcall( ClientData data[], Tcl_Interp *interp, int result) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = data[0], *namePtr; + Tcl_Obj *scriptPtr = data[0]; Namespace *nsPtr = data[1]; - TEOV_record *recordPtr = TOP_RECORD(iPtr); - Command *cmdPtr = NULL; - 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); + iPtr->lookupNsPtr = nsPtr; + result = TclNREvalObjEx(interp, scriptPtr, 0, NULL, 0); } nsPtr->activationCount--; @@ -8107,29 +7935,7 @@ TailcallCallback( 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); + return result; } void @@ -8142,31 +7948,11 @@ Tcl_NRAddCallback( ClientData data3) { if (!(postProcPtr)) { - Tcl_Panic("Adding a callback without and objProc?!"); + Tcl_Panic("Adding a callback without an objProc?!"); } TclNRAddCallback(interp, postProcPtr, data0, data1, data2, data3); } -TEOV_record * -TclNRPushRecord( - Tcl_Interp *interp) -{ - TEOV_record *recordPtr; - - PUSH_RECORD(interp, recordPtr); - return recordPtr; -} - -void -TclNRPopAndFreeRecord( - Tcl_Interp *interp) -{ - TEOV_record *recordPtr; - - POP_RECORD(interp, recordPtr); - FREE_RECORD(interp, recordPtr); -} - /* * Local Variables: * mode: c diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 63df8ce..c5ab71d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.96 2008/07/22 22:24:21 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.97 2008/07/29 05:30:25 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -830,15 +830,16 @@ typedef struct { } i; } TclOpCmdClientData; + /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ -MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[], - const char *command, int length, int flags); +MODULE_SCOPE Tcl_NRPostProc NRRunBytecode; +MODULE_SCOPE Tcl_NRPostProc NRDropCommand; + /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 138911f..1417bf9 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -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: tclDecls.h,v 1.143 2008/07/28 21:31:21 nijtmans Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.144 2008/07/29 05:30:25 msofer Exp $ */ #ifndef _TCLDECLS @@ -3517,9 +3517,16 @@ EXTERN int Tcl_CancelEval (Tcl_Interp * interp, /* 581 */ EXTERN int Tcl_Canceled (Tcl_Interp * interp, int flags); #endif +#ifndef Tcl_CreatePipe_TCL_DECLARED +#define Tcl_CreatePipe_TCL_DECLARED +/* 582 */ +EXTERN int Tcl_CreatePipe (Tcl_Interp * interp, + Tcl_Channel * rchan, Tcl_Channel * wchan, + int flags); +#endif #ifndef Tcl_NRCreateCommand_TCL_DECLARED #define Tcl_NRCreateCommand_TCL_DECLARED -/* 582 */ +/* 583 */ EXTERN Tcl_Command Tcl_NRCreateCommand (Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, Tcl_ObjCmdProc * nreProc, @@ -3528,25 +3535,25 @@ EXTERN Tcl_Command Tcl_NRCreateCommand (Tcl_Interp * interp, #endif #ifndef Tcl_NREvalObj_TCL_DECLARED #define Tcl_NREvalObj_TCL_DECLARED -/* 583 */ +/* 584 */ EXTERN int Tcl_NREvalObj (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); #endif #ifndef Tcl_NREvalObjv_TCL_DECLARED #define Tcl_NREvalObjv_TCL_DECLARED -/* 584 */ +/* 585 */ EXTERN int Tcl_NREvalObjv (Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags); #endif #ifndef Tcl_NRCmdSwap_TCL_DECLARED #define Tcl_NRCmdSwap_TCL_DECLARED -/* 585 */ +/* 586 */ EXTERN int Tcl_NRCmdSwap (Tcl_Interp * interp, Tcl_Command cmd, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *CONST objv[], int flags); #endif #ifndef Tcl_NRAddCallback_TCL_DECLARED #define Tcl_NRAddCallback_TCL_DECLARED -/* 586 */ +/* 587 */ EXTERN void Tcl_NRAddCallback (Tcl_Interp * interp, Tcl_NRPostProc * postProcPtr, ClientData data0, ClientData data1, @@ -3554,19 +3561,12 @@ EXTERN void Tcl_NRAddCallback (Tcl_Interp * interp, #endif #ifndef Tcl_NRCallObjProc_TCL_DECLARED #define Tcl_NRCallObjProc_TCL_DECLARED -/* 587 */ +/* 588 */ EXTERN int Tcl_NRCallObjProc (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData, int objc, Tcl_Obj *CONST objv[]); #endif -#ifndef Tcl_CreatePipe_TCL_DECLARED -#define Tcl_CreatePipe_TCL_DECLARED -/* 588 */ -EXTERN int Tcl_CreatePipe (Tcl_Interp * interp, - Tcl_Channel * rchan, Tcl_Channel * wchan, - int flags); -#endif typedef struct TclStubHooks { CONST struct TclPlatStubs *tclPlatStubs; @@ -4208,13 +4208,13 @@ typedef struct TclStubs { void (*tcl_AppendPrintfToObj) (Tcl_Obj * objPtr, CONST char * format, ...); /* 579 */ int (*tcl_CancelEval) (Tcl_Interp * interp, Tcl_Obj * resultObjPtr, ClientData clientData, int flags); /* 580 */ int (*tcl_Canceled) (Tcl_Interp * interp, int flags); /* 581 */ - Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, Tcl_ObjCmdProc * nreProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc); /* 582 */ - int (*tcl_NREvalObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); /* 583 */ - int (*tcl_NREvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 584 */ - int (*tcl_NRCmdSwap) (Tcl_Interp * interp, Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[]); /* 585 */ - void (*tcl_NRAddCallback) (Tcl_Interp * interp, Tcl_NRPostProc * postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 586 */ - int (*tcl_NRCallObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData, int objc, Tcl_Obj *CONST objv[]); /* 587 */ - int (*tcl_CreatePipe) (Tcl_Interp * interp, Tcl_Channel * rchan, Tcl_Channel * wchan, int flags); /* 588 */ + int (*tcl_CreatePipe) (Tcl_Interp * interp, Tcl_Channel * rchan, Tcl_Channel * wchan, int flags); /* 582 */ + Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, Tcl_ObjCmdProc * nreProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc); /* 583 */ + int (*tcl_NREvalObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); /* 584 */ + int (*tcl_NREvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags); /* 585 */ + int (*tcl_NRCmdSwap) (Tcl_Interp * interp, Tcl_Command cmd, int objc, Tcl_Obj *CONST objv[], int flags); /* 586 */ + void (*tcl_NRAddCallback) (Tcl_Interp * interp, Tcl_NRPostProc * postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 587 */ + int (*tcl_NRCallObjProc) (Tcl_Interp * interp, Tcl_ObjCmdProc * objProc, ClientData clientData, int objc, Tcl_Obj *CONST objv[]); /* 588 */ } TclStubs; #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) @@ -6615,33 +6615,33 @@ extern CONST TclStubs *tclStubsPtr; #define Tcl_Canceled \ (tclStubsPtr->tcl_Canceled) /* 581 */ #endif +#ifndef Tcl_CreatePipe +#define Tcl_CreatePipe \ + (tclStubsPtr->tcl_CreatePipe) /* 582 */ +#endif #ifndef Tcl_NRCreateCommand #define Tcl_NRCreateCommand \ - (tclStubsPtr->tcl_NRCreateCommand) /* 582 */ + (tclStubsPtr->tcl_NRCreateCommand) /* 583 */ #endif #ifndef Tcl_NREvalObj #define Tcl_NREvalObj \ - (tclStubsPtr->tcl_NREvalObj) /* 583 */ + (tclStubsPtr->tcl_NREvalObj) /* 584 */ #endif #ifndef Tcl_NREvalObjv #define Tcl_NREvalObjv \ - (tclStubsPtr->tcl_NREvalObjv) /* 584 */ + (tclStubsPtr->tcl_NREvalObjv) /* 585 */ #endif #ifndef Tcl_NRCmdSwap #define Tcl_NRCmdSwap \ - (tclStubsPtr->tcl_NRCmdSwap) /* 585 */ + (tclStubsPtr->tcl_NRCmdSwap) /* 586 */ #endif #ifndef Tcl_NRAddCallback #define Tcl_NRAddCallback \ - (tclStubsPtr->tcl_NRAddCallback) /* 586 */ + (tclStubsPtr->tcl_NRAddCallback) /* 587 */ #endif #ifndef Tcl_NRCallObjProc #define Tcl_NRCallObjProc \ - (tclStubsPtr->tcl_NRCallObjProc) /* 587 */ -#endif -#ifndef Tcl_CreatePipe -#define Tcl_CreatePipe \ - (tclStubsPtr->tcl_CreatePipe) /* 588 */ + (tclStubsPtr->tcl_NRCallObjProc) /* 588 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0102f5a..0aee386 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.387 2008/07/22 21:41:55 andreas_kupries Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.388 2008/07/29 05:30:26 msofer Exp $ */ #include "tclInt.h" @@ -166,27 +166,26 @@ static BuiltinFunc tclBuiltinFuncTable[] = { /* * NR_TEBC * Helpers for NR - non-recursive calls to TEBC + * Minimal data required to fully reconstruct the execution state. */ typedef struct BottomData { -#if USE_NR_TEBC struct BottomData *prevBottomPtr; - TEOV_record *recordPtr; /* Top record on TEOVI's cleanup stack when - * this level was entered. */ - ByteCode *codePtr; /* The following data is used on return */ - unsigned char *pc; /* TO this level: they record the state when */ - ptrdiff_t *catchTop; /* a new codePtr was received for NR */ - int cleanup; /* execution. */ + TEOV_callback *rootPtr; /* State when this bytecode execution began. */ + ByteCode *codePtr; /* These fields remain constant until it */ + CmdFrame *cmdFramePtr; /* returns. */ + /* ------------------------------------------*/ + unsigned char *pc; /* These fields are used on return TO this */ + ptrdiff_t *catchTop; /* this level: they record the state when a */ + int cleanup; /* new codePtr was received for NR execution */ Tcl_Obj *auxObjList; -#endif } BottomData; -#if USE_NR_TEBC - -#define NR_DATA_INIT() \ +#define NR_DATA_INIT() \ bottomPtr->prevBottomPtr = oldBottomPtr; \ - bottomPtr->recordPtr = TOP_RECORD(iPtr); \ - bottomPtr->codePtr = codePtr + bottomPtr->rootPtr = TOP_CB(iPtr); \ + bottomPtr->codePtr = codePtr; \ + bottomPtr->cmdFramePtr = iPtr->cmdFramePtr #define NR_DATA_BURY() \ bottomPtr->pc = pc; \ @@ -201,12 +200,13 @@ typedef struct BottomData { catchTop = bottomPtr->catchTop; \ cleanup = bottomPtr->cleanup; \ auxObjList = bottomPtr->auxObjList; \ - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr -#endif + esPtr = iPtr->execEnvPtr->execStackPtr; \ + tosPtr = esPtr->tosPtr; \ + iPtr->cmdFramePtr = bottomPtr->cmdFramePtr; #define PUSH_AUX_OBJ(objPtr) \ objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \ - auxObjList = objPtr + auxObjList = objPtr #define POP_AUX_OBJ() \ { \ @@ -799,8 +799,7 @@ TclCreateExecEnv( Tcl_IncrRefCount(eePtr->constants[0]); TclNewBooleanObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); - eePtr->recordPtr = NULL; - eePtr->tebcCall = 0; + eePtr->callbackPtr = NULL; esPtr->prevPtr = NULL; esPtr->nextPtr = NULL; @@ -875,7 +874,7 @@ TclDeleteExecEnv( TclDecrRefCount(eePtr->constants[0]); TclDecrRefCount(eePtr->constants[1]); - if (eePtr->recordPtr) { + if (eePtr->callbackPtr) { Tcl_Panic("Deleting execEnv with pending TEOV callbacks!"); } ckfree((char *) eePtr); @@ -1473,7 +1472,7 @@ FreeExprCodeInternalRep( * This procedure compiles the script contained in a Tcl_Obj * * Results: - * A pointer to the corresponding ByteCode + * A pointer to the corresponding ByteCode, never NULL. * * Side effects: * The object is shimmered to bytecode type @@ -1752,9 +1751,7 @@ TclExecuteByteCode( /* NR_TEBC */ BottomData *bottomPtr; -#if USE_NR_TEBC BottomData *oldBottomPtr = NULL; -#endif /* * Constants: variables that do not change during the execution, used @@ -1793,10 +1790,7 @@ 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. @@ -1826,13 +1820,47 @@ TclExecuteByteCode( * execution stack is large enough to execute this ByteCode. */ - /* - * NR_TEBC - */ + int nested = 0; -#if USE_NR_TEBC nonRecursiveCallStart: + if (nested) { + TEOV_callback *callbackPtr = TOP_CB(interp); + Tcl_NRPostProc *procPtr = callbackPtr->procPtr; + ByteCode *newCodePtr = callbackPtr->data[0]; + + assert((result==TCL_OK)); + assert((callbackPtr != bottomPtr->rootPtr)); + + TOP_CB(interp) = callbackPtr->nextPtr; + TCLNR_FREE(interp, callbackPtr); + + if (procPtr == NRRunBytecode) { + NR_DATA_BURY(); /* this level's state variables */ + codePtr = newCodePtr; + } else if (procPtr == NRDropCommand) { + /* + * A request to perform a tailcall: just drop this + * bytecode as it is; the tailCall has been scheduled in + * the callbacks. + */ +#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); + goto checkForCatch; + } + goto abnormalReturn; /* drop a level */ + } else { + Tcl_Panic("TEBC: TRCB sent us a record we cannot handle! (1)"); + } + } + nested = 1; + codePtr->refCount++; bottomPtr = (BottomData *) GrowEvaluationStack(iPtr->execEnvPtr, sizeof(BottomData) + codePtr->maxExceptDepth + sizeof(CmdFrame) @@ -1840,12 +1868,9 @@ TclExecuteByteCode( curInstName = NULL; auxObjList = NULL; initLevel = 1; - -#if USE_NR_TEBC NR_DATA_INIT(); /* record this level's data */ - + nonRecursiveCallReturn: -#endif bcFramePtr = (CmdFrame *) (bottomPtr + 1); initCatchTop = ((ptrdiff_t *) (bcFramePtr + 1)) - 1; initTosPtr = (Tcl_Obj **) (initCatchTop + codePtr->maxExceptDepth); @@ -1880,10 +1905,6 @@ TclExecuteByteCode( TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,bcFramePtr); -#if (USE_NR_TEBC) - } else if (tailcall) { - goto tailcallEntry; -#endif } else { /* * Returning from a non-recursive call. State is already completely @@ -2475,6 +2496,25 @@ TclExecuteByteCode( NEXT_INST_F(5, 0, 0); } + case INST_EXPR_STK: { + /* + * Moved here to support transforming the eval of an expression to + * a non-recursive TEBC call. + */ + + ByteCode *newCodePtr; + + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + DECACHE_STACK_INFO(); + newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); + CACHE_STACK_INFO(); + cleanup = 1; + pc++; + Tcl_NRAddCallback(interp, NRRunBytecode, newCodePtr, NULL, NULL, NULL); + goto nonRecursiveCallStart; + } + { /* * INVOCATION BLOCK @@ -2482,70 +2522,7 @@ 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 - * a non-recursive TEBC call. - */ - -#if (USE_NR_TEBC) - pcAdjustment = 1; - cleanup = 1; - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - DECACHE_STACK_INFO(); - newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); - CACHE_STACK_INFO(); - goto tebc_do_exec; -#else - Tcl_Obj *objPtr, *valuePtr; - - objPtr = OBJ_AT_TOS; - - DECACHE_STACK_INFO(); - /*Tcl_ResetResult(interp);*/ - result = Tcl_ExprObj(interp, objPtr, &valuePtr); - CACHE_STACK_INFO(); - if (result == TCL_OK) { - objResultPtr = valuePtr; - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); - NEXT_INST_F(1, 1, -1); /* Already has right refct. */ - } else { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - cleanup = 1; - goto checkForCatch; - } -#endif - } - -#if (USE_NR_TEBC) - tailcallEntry: { - TEOV_record *recordPtr = TOP_RECORD(iPtr); - - /* - * 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 @@ -2554,10 +2531,10 @@ TclExecuteByteCode( */ Tcl_Obj *objPtr = OBJ_AT_TOS; + ByteCode *newCodePtr; cleanup = 1; - pcAdjustment = !tailcall; - tailcall = 0; + pcAdjustment = 1; if (objPtr->typePtr == &tclListType) { /* is a list... */ List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; @@ -2580,59 +2557,20 @@ TclExecuteByteCode( } /* + * Run the bytecode in this same TEBC instance! + * * TIP #280: The invoking context is left NULL for a dynamically * constructed command. We cannot match its lines to the outer * context. - */ + */ DECACHE_STACK_INFO(); newCodePtr = TclCompileObj(interp, objPtr, NULL, 0); - if (newCodePtr) { - /* - * Run the bytecode in this same TEBC instance! - */ -#if (USE_NR_TEBC) - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; - goto tebc_do_exec; -#else - result = TclExecuteByteCode(interp, newCodePtr); - CACHE_STACK_INFO(); - - if (result == TCL_OK) { - /* - * Normal return; push the eval's object result. - */ - - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - - /* - * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult to - * avoid any side effects caused by the resetting of errorInfo and - * errorCode [Bug 804681], which are not needed here. We chose - * instead to manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps - * the refCount it had in its role of iPtr->objResultPtr. - */ - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_F(1, 1, -1); - } -#endif - } - - /* - * Compilation failed, error - */ - - result = TCL_ERROR; - goto processExceptionReturn; + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + pc++; + Tcl_NRAddCallback(interp, NRRunBytecode, newCodePtr, NULL, NULL, NULL); + goto nonRecursiveCallStart; } case INST_INVOKE_EXPANDED: @@ -2708,55 +2646,17 @@ TclExecuteByteCode( DECACHE_STACK_INFO(); -#if (USE_NR_TEBC) - TEBC_CALL(iPtr) = 1; - recordPtr = TOP_RECORD(iPtr); -#endif - result = TclEvalObjv(interp, objc, objv, evalFlags, NULL); + result = TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, NULL); + result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1); CACHE_STACK_INFO(); -#if (USE_NR_TEBC) - 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. - */ - pc += pcAdjustment; - NR_DATA_BURY(); /* this level's state variables */ - codePtr = newCodePtr; - goto nonRecursiveCallStart; - case TCL_NR_TAILCALL_TYPE: - /* - * A request to perform a tailcall: just drop this - * bytecode as it is; the tailCall has been scheduled in - * the callbacks. - */ -#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); - goto checkForCatch; - } - goto abnormalReturn; /* drop a level */ - default: - Tcl_Panic("TEBC: TEOV sent us a record we cannot handle!"); - } + if (TOP_CB(interp) != bottomPtr->rootPtr) { + assert ((result == TCL_OK)); + pc += pcAdjustment; + goto nonRecursiveCallStart; } -#endif iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - + if (result == TCL_OK) { Tcl_Obj *objPtr; #ifndef TCL_COMPILE_DEBUG @@ -7762,81 +7662,64 @@ TclExecuteByteCode( TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr); -#if USE_NR_TEBC oldBottomPtr = bottomPtr->prevBottomPtr; -#endif TclStackFree(interp, bottomPtr); /* free my stack */ if (--codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } -#if USE_NR_TEBC if (oldBottomPtr) { /* * Restore the state to what it was previous to this bytecode. - * - * NR_TEBC */ - bottomPtr = oldBottomPtr; /* back to old bc */ + + bottomPtr = oldBottomPtr; /* back to old bc */ + result = TclNRRunCallbacks(interp, result, bottomPtr->rootPtr, 1); - /* Please free anything that might still be on my new stack */ - resumeCleanup: - 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); + NR_DATA_DIG(); + DECACHE_STACK_INFO(); + if (TOP_CB(interp) == bottomPtr->rootPtr) { + /* + * The bytecode is returning, remove the caller's arguments and + * keep processing the caller. + */ + + while (cleanup--) { + Tcl_Obj *objPtr = POP_OBJECT(); + Tcl_DecrRefCount(objPtr); + } + goto nonRecursiveCallReturn; + } else { + /* + * A request for a new execution: a tailcall. Remove the caller's + * arguments and start the new bytecode. + * + * FIXME KNOWNBUG: we get a pointer smash if we do remove the + * arguments, a leak otherwise: tailcalls are not yet quite + * there. Chose to leave the leak for now. + */ - 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; - case TCL_NR_CMDSWAP_TYPE: - result = TclEvalObjv(interp, recordPtr->data.objcv.objc, - recordPtr->data.objcv.objv, 0, recordPtr->cmdPtr); - goto resumeCleanup; - default: - Tcl_Panic("TEBC: TEOV_NR2 sent us a record we cannot handle!"); + TEOV_callback *callbackPtr = TOP_CB(interp); + Tcl_NRPostProc *procPtr = callbackPtr->procPtr; + + if (procPtr == NRRunBytecode) { + goto nonRecursiveCallStart; + } else if (procPtr == NRDropCommand) { + /* FIXME: 'tailcall tailcall' not yet working */ + Tcl_Panic("Tailcalls from within tailcalls are not yet implemented"); + if (catchTop != initCatchTop) { + result = TCL_ERROR; + Tcl_SetResult(interp,"Tailcall called from within a catch environment", + TCL_STATIC); + goto checkForCatch; } + goto abnormalReturn; /* drop a level */ + } else { + Tcl_Panic("TEBC: TEOV sent us a record we cannot handle! (2)"); } } - restoreStateVariables: - NR_DATA_DIG(); - esPtr = iPtr->execEnvPtr->execStackPtr; - tosPtr = esPtr->tosPtr; - while (cleanup--) { - Tcl_Obj *objPtr = POP_OBJECT(); - Tcl_DecrRefCount(objPtr); - } - CACHE_STACK_INFO(); - goto nonRecursiveCallReturn; } -#endif return result; } #undef iPtr diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e1e46d0..8213109 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -13,7 +13,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.decls,v 1.126 2008/07/24 22:57:57 nijtmans Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.127 2008/07/29 05:30:32 msofer Exp $ library tcl @@ -894,10 +894,12 @@ declare 227 generic { void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]) } -declare 228 generic { - int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj, - int skip, ProcErrorProc errorProc) -} +# Used to be needed for TclOO-extension; unneeded now that TclOO is in the +# core and NRE-enabled +# declare 228 generic { +# int TclObjInterpProcCore(register Tcl_Interp *interp, Tcl_Obj *procNameObj, +# int skip, ProcErrorProc errorProc) +# } declare 229 generic { int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, CONST char *myName, int myFlags, int index) @@ -943,28 +945,25 @@ declare 237 generic { # NRE functions for "rogue" extensions to exploit NRE; they will need to # include NRE.h too. declare 238 generic { - int TclEvalObjv_NR2(Tcl_Interp *interp, int result, - struct TEOV_record *rootPtr) -} -declare 239 generic { int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } -declare 240 generic { +declare 239 generic { int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc errorProc) } -declare 241 generic { - struct TEOV_record * TclNRPushRecord(Tcl_Interp *interp) -} -declare 242 generic { - void TclNRPopAndFreeRecord(Tcl_Interp *interp) +declare 240 generic { + int TclNRRunCallbacks(Tcl_Interp * interp, int result, + struct TEOV_callback * rootPtr, int tebcCall) } - -declare 243 generic { +declare 241 generic { int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, CONST CmdFrame *invoker, int word) } +declare 242 generic { + int TclNREvalObjv(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int flags, Command *cmdPtr) +} ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclInt.h b/generic/tclInt.h index 0587ecf..1b10fc6 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.379 2008/07/24 22:57:55 nijtmans Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.380 2008/07/29 05:30:32 msofer Exp $ */ #ifndef _TCLINT @@ -1329,17 +1329,13 @@ typedef struct ExecStack { * currently active execution stack. */ -struct TEOV_record; - typedef struct ExecEnv { ExecStack *execStackPtr; /* Points to the first item in the * evaluation stack on the heap. */ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" - * objs. */ - struct TEOV_record *recordPtr; /* Top record in TEOV's stack */ - int tebcCall; /* used to distinguish tebc calls from - * other calls to TEOV, and other comms - * between TEBC and TEOV */ + * objs. */ + struct TEOV_callback *callbackPtr; + /* Top callback in TEOV's stack */ } ExecEnv; /* @@ -2516,10 +2512,12 @@ MODULE_SCOPE char tclEmptyString; /* Introduced by/for NRE */ MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE int TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr, int flags); -MODULE_SCOPE int TclEvalObjv(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int flags, Command *cmdPtr); + +MODULE_SCOPE void TclNRClearCommandFlag(Tcl_Interp *interp); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); @@ -2789,8 +2787,8 @@ MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); -MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); - +MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); + /* *---------------------------------------------------------------- * Command procedures in the generic core: @@ -4011,7 +4009,7 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, #include "tclTomMathDecls.h" #endif /* _TCLINT */ - + /* * Local Variables: * mode: c diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 0ef9eef..2148ab6 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.122 2008/07/24 22:57:54 nijtmans Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.123 2008/07/29 05:30:34 msofer Exp $ */ #ifndef _TCLINTDECLS @@ -1012,13 +1012,7 @@ EXTERN int TclObjBeingDeleted (Tcl_Obj * objPtr); EXTERN void TclSetNsPath (Namespace * nsPtr, int pathLength, Tcl_Namespace * pathAry[]); #endif -#ifndef TclObjInterpProcCore_TCL_DECLARED -#define TclObjInterpProcCore_TCL_DECLARED -/* 228 */ -EXTERN int TclObjInterpProcCore (register Tcl_Interp * interp, - Tcl_Obj * procNameObj, int skip, - ProcErrorProc errorProc); -#endif +/* Slot 228 is reserved */ #ifndef TclPtrMakeUpvar_TCL_DECLARED #define TclPtrMakeUpvar_TCL_DECLARED /* 229 */ @@ -1076,43 +1070,40 @@ EXTERN void TclBackgroundException (Tcl_Interp * interp, /* 237 */ EXTERN int TclResetCancellation (Tcl_Interp * interp, int force); #endif -#ifndef TclEvalObjv_NR2_TCL_DECLARED -#define TclEvalObjv_NR2_TCL_DECLARED -/* 238 */ -EXTERN int TclEvalObjv_NR2 (Tcl_Interp * interp, int result, - struct TEOV_record * rootPtr); -#endif #ifndef TclNRInterpProc_TCL_DECLARED #define TclNRInterpProc_TCL_DECLARED -/* 239 */ +/* 238 */ EXTERN int TclNRInterpProc (ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[]); #endif #ifndef TclNRInterpProcCore_TCL_DECLARED #define TclNRInterpProcCore_TCL_DECLARED -/* 240 */ +/* 239 */ EXTERN int TclNRInterpProcCore (Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); #endif -#ifndef TclNRPushRecord_TCL_DECLARED -#define TclNRPushRecord_TCL_DECLARED -/* 241 */ -EXTERN struct TEOV_record * TclNRPushRecord (Tcl_Interp * interp); -#endif -#ifndef TclNRPopAndFreeRecord_TCL_DECLARED -#define TclNRPopAndFreeRecord_TCL_DECLARED -/* 242 */ -EXTERN void TclNRPopAndFreeRecord (Tcl_Interp * interp); +#ifndef TclNRRunCallbacks_TCL_DECLARED +#define TclNRRunCallbacks_TCL_DECLARED +/* 240 */ +EXTERN int TclNRRunCallbacks (Tcl_Interp * interp, int result, + struct TEOV_callback * rootPtr, int tebcCall); #endif #ifndef TclNREvalObjEx_TCL_DECLARED #define TclNREvalObjEx_TCL_DECLARED -/* 243 */ +/* 241 */ EXTERN int TclNREvalObjEx (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, CONST CmdFrame * invoker, int word); #endif +#ifndef TclNREvalObjv_TCL_DECLARED +#define TclNREvalObjv_TCL_DECLARED +/* 242 */ +EXTERN int TclNREvalObjv (Tcl_Interp * interp, int objc, + Tcl_Obj *const objv[], int flags, + Command * cmdPtr); +#endif typedef struct TclIntStubs { int magic; @@ -1370,7 +1361,7 @@ typedef struct TclIntStubs { Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp * interp, Tcl_Obj * rootPtr, int keyc, Tcl_Obj *CONST keyv[], int flags); /* 225 */ int (*tclObjBeingDeleted) (Tcl_Obj * objPtr); /* 226 */ void (*tclSetNsPath) (Namespace * nsPtr, int pathLength, Tcl_Namespace * pathAry[]); /* 227 */ - int (*tclObjInterpProcCore) (register Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 228 */ + void *reserved228; int (*tclPtrMakeUpvar) (Tcl_Interp * interp, Var * otherP1Ptr, CONST char * myName, int myFlags, int index); /* 229 */ Var * (*tclObjLookupVar) (Tcl_Interp * interp, Tcl_Obj * part1Ptr, CONST char * part2, int flags, CONST char * msg, CONST int createPart1, CONST int createPart2, Var ** arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Namespace ** nsPtrPtr); /* 231 */ @@ -1380,12 +1371,11 @@ typedef struct TclIntStubs { void (*tclInitVarHashTable) (TclVarHashTable * tablePtr, Namespace * nsPtr); /* 235 */ void (*tclBackgroundException) (Tcl_Interp * interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp * interp, int force); /* 237 */ - int (*tclEvalObjv_NR2) (Tcl_Interp * interp, int result, struct TEOV_record * rootPtr); /* 238 */ - int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[]); /* 239 */ - int (*tclNRInterpProcCore) (Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 240 */ - struct TEOV_record * (*tclNRPushRecord) (Tcl_Interp * interp); /* 241 */ - void (*tclNRPopAndFreeRecord) (Tcl_Interp * interp); /* 242 */ - int (*tclNREvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, CONST CmdFrame * invoker, int word); /* 243 */ + int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[]); /* 238 */ + int (*tclNRInterpProcCore) (Tcl_Interp * interp, Tcl_Obj * procNameObj, int skip, ProcErrorProc errorProc); /* 239 */ + int (*tclNRRunCallbacks) (Tcl_Interp * interp, int result, struct TEOV_callback * rootPtr, int tebcCall); /* 240 */ + int (*tclNREvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, CONST CmdFrame * invoker, int word); /* 241 */ + int (*tclNREvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *const objv[], int flags, Command * cmdPtr); /* 242 */ } TclIntStubs; #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) @@ -2091,10 +2081,7 @@ extern CONST TclIntStubs *tclIntStubsPtr; #define TclSetNsPath \ (tclIntStubsPtr->tclSetNsPath) /* 227 */ #endif -#ifndef TclObjInterpProcCore -#define TclObjInterpProcCore \ - (tclIntStubsPtr->tclObjInterpProcCore) /* 228 */ -#endif +/* Slot 228 is reserved */ #ifndef TclPtrMakeUpvar #define TclPtrMakeUpvar \ (tclIntStubsPtr->tclPtrMakeUpvar) /* 229 */ @@ -2131,29 +2118,25 @@ extern CONST TclIntStubs *tclIntStubsPtr; #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #endif -#ifndef TclEvalObjv_NR2 -#define TclEvalObjv_NR2 \ - (tclIntStubsPtr->tclEvalObjv_NR2) /* 238 */ -#endif #ifndef TclNRInterpProc #define TclNRInterpProc \ - (tclIntStubsPtr->tclNRInterpProc) /* 239 */ + (tclIntStubsPtr->tclNRInterpProc) /* 238 */ #endif #ifndef TclNRInterpProcCore #define TclNRInterpProcCore \ - (tclIntStubsPtr->tclNRInterpProcCore) /* 240 */ + (tclIntStubsPtr->tclNRInterpProcCore) /* 239 */ #endif -#ifndef TclNRPushRecord -#define TclNRPushRecord \ - (tclIntStubsPtr->tclNRPushRecord) /* 241 */ -#endif -#ifndef TclNRPopAndFreeRecord -#define TclNRPopAndFreeRecord \ - (tclIntStubsPtr->tclNRPopAndFreeRecord) /* 242 */ +#ifndef TclNRRunCallbacks +#define TclNRRunCallbacks \ + (tclIntStubsPtr->tclNRRunCallbacks) /* 240 */ #endif #ifndef TclNREvalObjEx #define TclNREvalObjEx \ - (tclIntStubsPtr->tclNREvalObjEx) /* 243 */ + (tclIntStubsPtr->tclNREvalObjEx) /* 241 */ +#endif +#ifndef TclNREvalObjv +#define TclNREvalObjv \ + (tclIntStubsPtr->tclNREvalObjv) /* 242 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 025109d..d5736c3 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.93 2008/07/24 22:57:56 nijtmans Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.94 2008/07/29 05:30:35 msofer Exp $ */ #include "tclInt.h" @@ -687,7 +687,7 @@ Tcl_InterpObjCmd( /* * Did they specify a slave interp to cancel the script in - * progress in? If not, use the current interp. + * progress in? If not, use the current interp. */ if (i < objc) { @@ -1488,7 +1488,7 @@ AliasCreate( if (slaveInterp == masterInterp) { aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, - TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, + TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, AliasObjCmdDeleteProc); } else { aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, @@ -1763,7 +1763,8 @@ AliasNRCmd( Tcl_Obj *listPtr; List *listRep; int flags = TCL_EVAL_INVOKE; - + int result; + /* * Append the arguments to the command prefix and invoke the command in * the target interp's global namespace. @@ -1777,7 +1778,7 @@ AliasNRCmd( listRep = listPtr->internalRep.twoPtrValue.ptr1; listRep->elemCount = cmdc; cmdv = &listRep->elements; - + prefv = &aliasPtr->objPtr; memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); @@ -1808,7 +1809,9 @@ AliasNRCmd( if (isRootEnsemble) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } - return TclNREvalCmd(interp, listPtr, flags); + result = Tcl_NREvalObj(interp, listPtr, flags); + TclNRClearCommandFlag(interp); + return result; } static int @@ -2618,7 +2621,7 @@ SlaveEval( * * Do not let any intReps accross, with the exception of * bytecodes. The intrep spoiling is due to happen anyway when - * compiling. + * compiling. */ Interp *iPtr = (Interp *) interp; @@ -2635,7 +2638,7 @@ SlaveEval( } TclArgumentGet (interp, objPtr, &invoker, &word); - + result = TclEvalObjEx(slaveInterp, objPtr, 0, invoker, word); } else { objPtr = Tcl_ConcatObj(objc, objv); diff --git a/generic/tclNRE.h b/generic/tclNRE.h index e0d692d..15f0e54 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.6 2008/07/21 16:26:08 msofer Exp $ + * RCS: @(#) $Id: tclNRE.h,v 1.7 2008/07/29 05:30:36 msofer Exp $ */ @@ -23,60 +23,8 @@ *****************************************************************************/ #define USE_SMALL_ALLOC 1 /* perf is important for some of these things! */ -#define USE_STACK_ALLOC 1 /* good mainly for debugging, crashes at - * smallest timing error */ #define ENABLE_ASSERTS 1 -/* - * IMPLEMENTED IN THIS VERSION - flags for partial enabling of the different - * parts, useful for debugging. May not work - meant to be used at "all ones" - */ - -#define USE_NR_PROC 1 /* are procs defined as NR functions or not? - * Used for testing that the old interfaces - * still work, as they are used by TclOO and - * iTcl */ -#define USE_NR_TEBC 1 /* does TEBC know about his special powers? - * with 1 TEBC remains on stack, TEOV gets - * evicted. */ -#define USE_NR_ALIAS 1 /* First examples: my job */ - -#define USE_NR_IMPORTS 1 /* First examples: my job */ - -#define USE_NR_TAILCALLS 1 /* Incomplete implementation as - * tcl::unsupported::tailcall; best semantics - * are yet not 100% clear to me. */ - -#define USE_NR_NS_ENSEMBLE 1 /* snit!! */ - -/* Here to remind me of what's still missing: none of these do anything today */ - -#define USE_NR_EVAL 0 /* Tcl_EvalObj should be easy; the others may - * require some adapting of the parser. dgp? */ -#define USE_NR_UPLEVEL 0 /* piece of cake, I think */ -#define USE_NR_VAR_TRACES 0 /* require major redesign, I fear. About time - * for it too! */ - -#define USE_NR_CONTINUATIONS 0 - -#define MAKE_3X_FASTER 0 -#define RULE_THE_WORLD 0 - -#define USE_NR_CMD_TRACES /* NEVER?? Maybe ... enter traces on the way in, - * leave traces done in the callback? So a trace - * just needs to replace the procPtr and - * clientData, and TEOV needn't know about the - * whole s**t! Mmhhh */ - -/***************************************************************************** - * Stuff for the public api: gone to the stubs table! - * - * Question: should we allow more callback requests during the callback - * itself? Easy enough to either handle or block, nothing done yet. We could - * also "lock" the Tcl stack during postProc, but it doesn't sound - * reasonable. I think. - *****************************************************************************/ - /***************************************************************************** * Private api fo NRE *****************************************************************************/ @@ -94,162 +42,38 @@ typedef struct TEOV_callback { struct TEOV_callback *nextPtr; } TEOV_callback; - -/* Try to keep within SmallAlloc sizes! */ -typedef struct TEOV_record { - int type; - Command *cmdPtr; - TEOV_callback *callbackPtr; - struct TEOV_record *nextPtr; - union { - struct ByteCode *codePtr; /* TCL_NR_BC_TYPE */ - struct { - Tcl_Obj *objPtr; - int flags; - } obj; - struct { - int objc; - Tcl_Obj **objv; - } objcv; - } data; -#if !USE_SMALL_ALLOC - /* Extra checks: can disappear later */ - Tcl_Obj **tosPtr; -#endif -} TEOV_record; - -/* - * The types for records; we save the first bit to indicate that it stores an - * obj, to indicate the necessary refCount management. That is, odd numbers - * only for obj-carrying types - */ - -#define TCL_NR_NO_TYPE 0 /* for internal (cleanup) use only */ -#define TCL_NR_BC_TYPE 2 /* procs, lambdas, TclOO+Itcl sometime ... */ -#define TCL_NR_CMDSWAP_TYPE 4 /* ns-imports (cmdd redirect) */ -#define TCL_NR_TAILCALL_TYPE 6 -#define TCL_NR_TEBC_SWAPENV_TYPE 8 /* continuations, micro-threads !? */ - -#define TCL_NR_CMD_TYPE 1 /* i-alias, ns-ens use this */ -#define TCL_NR_SCRIPT_TYPE 3 /* ns-eval, uplevel use this */ - -#define TCL_NR_HAS_OBJ(TYPE) ((TYPE) & 1) - -#define TOP_RECORD(iPtr) (((Interp *)(iPtr))->execEnvPtr->recordPtr) +#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr) #define GET_TOSPTR(iPtr) \ (((Interp *)iPtr)->execEnvPtr->execStackPtr->tosPtr) -#if !USE_SMALL_ALLOC -#define STORE_EXTRA(iPtr, recordPtr) \ - recordPtr->tosPtr = GET_TOSPTR(iPtr) -#else -#define STORE_EXTRA(iPtr, recordPtr) -#endif - -/* A SINGLE record being pushed is what is detected as an NRE request by TEOV */ - -#define PUSH_RECORD(iPtr, recordPtr) \ - TCLNR_ALLOC(interp, recordPtr); \ - recordPtr->nextPtr = TOP_RECORD(iPtr); \ - STORE_EXTRA(iPtr, recordPtr); \ - TOP_RECORD(iPtr) = recordPtr; \ - recordPtr->type = TCL_NR_NO_TYPE; \ - recordPtr->cmdPtr = NULL; \ - recordPtr->callbackPtr = NULL - -#define TEBC_CALL(iPtr) \ - (((Interp *)iPtr)->execEnvPtr->tebcCall) +/* + * Inline version of Tcl_NRAddCallback + */ -#define TclNRAddCallback(\ - interp,\ - postProcPtr,\ - data0,\ - data1,\ - data2,\ - data3) \ - { \ - TEOV_record *recordPtr; \ - TEOV_callback *callbackPtr; \ - \ - recordPtr = TOP_RECORD(interp); \ +#define TclNRAddCallback( \ + interp, \ + postProcPtr, \ + data0, \ + data1, \ + data2, \ + data3) \ + { \ + TEOV_callback *callbackPtr; \ TclSmallAlloc(sizeof(TEOV_callback), callbackPtr); \ - \ callbackPtr->procPtr = (postProcPtr); \ callbackPtr->data[0] = (data0); \ callbackPtr->data[1] = (data1); \ callbackPtr->data[2] = (data2); \ callbackPtr->data[3] = (data3); \ - \ - callbackPtr->nextPtr = recordPtr->callbackPtr; \ - recordPtr->callbackPtr = callbackPtr; \ + callbackPtr->nextPtr = TOP_CB(interp); \ + TOP_CB(interp) = callbackPtr; \ } - - - -/* - * These are only used by TEOV; here for ease of ref. They should move to - * tclBasic.c later on. - */ - -#define COMPLETE_RECORD(recordPtr) \ - /* accesses variables by name, careful */ \ - recordPtr->cmdPtr = cmdPtr; \ - -#if !USE_SMALL_ALLOC -#define CHECK_EXTRA(iPtr, recordPtr) \ - (recordPtr->tosPtr == GET_TOSPTR(iPtr)) -#else -#define CHECK_EXTRA(iPtr, recordPtr) 1 -#endif - -#define POP_RECORD(iPtr, recordPtr) \ - { \ - recordPtr = TOP_RECORD(iPtr); \ - TOP_RECORD(iPtr) = recordPtr->nextPtr; \ - } - - -#define FREE_RECORD(iPtr, recordPtr) \ - { \ - TEOV_callback *callbackPtr = recordPtr->callbackPtr; \ - if (TCL_NR_HAS_OBJ(recordPtr->type)) { \ - Tcl_DecrRefCount(recordPtr->data.obj.objPtr); \ - } \ - while (callbackPtr) { \ - callbackPtr = callbackPtr->nextPtr; \ - TclSmallFree(recordPtr->callbackPtr); \ - } \ - TCLNR_FREE(((Tcl_Interp *)iPtr), recordPtr); \ - } - -#define CHECK_VALID_RETURN(iPtr, recordPtr) \ - ((TOP_RECORD(iPtr) == recordPtr) && \ - CHECK_EXTRA(iPtr, recordPtr)) - -#define READ_OBJV_RECORD(recordPtr) /* TBD? Or read by hand (braille?) */ - - -/* - * functions - */ - -#if 0 -/* built as static inline in tclProc.c. Do TclOO/Itcl need this? */ -MODULE_SCOPE int Tcl_NRBC (Tcl_Interp * interp, ByteCode *codePtr, - Tcl_NRPostProc *postProcPtr, ClientData clientData); -#endif - -/* The following starts purges the stack popping TclStackAllocs down to where - * tosPtr has the requested value. Panics on failure.*/ -MODULE_SCOPE void TclStackPurge(Tcl_Interp *interp, Tcl_Obj **tosPtr); /* * Tailcalls! */ -MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd; @@ -258,13 +82,10 @@ MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd; *****************************************************************************/ #if USE_SMALL_ALLOC -#define TCLNR_ALLOC(interp, ptr) TclSmallAlloc(sizeof(TEOV_record), ptr) +#define TCLNR_ALLOC(interp, ptr) TclSmallAlloc(sizeof(TEOV_callback), ptr) #define TCLNR_FREE(interp, ptr) TclSmallFree((ptr)) -#elif USE_STACK_ALLOC -#define TCLNR_ALLOC(interp, ptr) (ptr = TclStackAlloc(interp, sizeof(TEOV_record))) -#define TCLNR_FREE(interp, ptr) TclStackFree(interp, (ptr)) #else -#define TCLNR_ALLOC(interp, size, ptr) (ptr = ((ClientData) ckalloc(sizeof(TEOV_record)))) +#define TCLNR_ALLOC(interp, size, ptr) (ptr = ((ClientData) ckalloc(sizeof(TEOV_callback)))) #define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) #endif diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3eda959..ff56db7 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -23,7 +23,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.171 2008/07/21 22:50:36 andreas_kupries Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.172 2008/07/29 05:30:36 msofer Exp $ */ #include "tclInt.h" @@ -1897,7 +1897,7 @@ InvokeImportedNRCmd( ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; - return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv); + return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); } static int @@ -6225,7 +6225,7 @@ NsEnsembleImplementationCmdNR( * target command prefix. */ Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. * Will be freed by the dispatch engine. */ - int prefixObjc, copyObjc; + int prefixObjc, copyObjc, result; Interp *iPtr = (Interp *) interp; /* @@ -6285,8 +6285,10 @@ NsEnsembleImplementationCmdNR( /* * Hand off to the target command. */ - - return TclNREvalCmd(interp, copyPtr, TCL_EVAL_INVOKE); + + result = Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE); + TclNRClearCommandFlag(interp); + return result; } unknownOrAmbiguousSubcommand: diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 2adf547..1e9bd11 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOOBasic.c,v 1.7 2008/07/18 23:29:44 msofer Exp $ + * RCS: @(#) $Id: tclOOBasic.c,v 1.8 2008/07/29 05:30:37 msofer Exp $ */ #ifdef HAVE_CONFIG_H @@ -49,11 +49,8 @@ static inline Tcl_Object * AddConstructionFinalizer( Tcl_Interp *interp) { - TEOV_record *recordPtr; - TclNRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL); - recordPtr = TOP_RECORD(interp); - return (Tcl_Object *) &recordPtr->callbackPtr->data[0]; + return (Tcl_Object *) &(TOP_CB(interp)->data[0]); } static int diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 8ce3c34..9cd2678 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -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: tclOOMethod.c,v 1.10 2008/07/27 22:28:54 dkf Exp $ + * RCS: @(#) $Id: tclOOMethod.c,v 1.11 2008/07/29 05:30:37 msofer Exp $ */ #ifdef HAVE_CONFIG_H @@ -55,6 +55,8 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, static int InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); +static int FinalizeForwardCall(ClientData data[], Tcl_Interp *interp, + int result); static int FinalizePMCall(ClientData data[], Tcl_Interp *interp, int result); static int PushMethodCallFrame(Tcl_Interp *interp, @@ -1131,7 +1133,7 @@ InvokeForwardMethod( CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; - int numPrefixes, result, len, skip = contextPtr->skip; + int numPrefixes, len, skip = contextPtr->skip; /* * Build the real list of arguments to use. Note that we know that the @@ -1144,7 +1146,18 @@ InvokeForwardMethod( argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); - result = Tcl_NREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE); + Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); + return Tcl_NREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE); +} + +static int +FinalizeForwardCall( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj **argObjs = data[0]; + TclStackFree(interp, argObjs); return result; } diff --git a/generic/tclProc.c b/generic/tclProc.c index 63aa7d5..ea5f617 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.152 2008/07/25 22:11:21 andreas_kupries Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.153 2008/07/29 05:30:37 msofer Exp $ */ #include "tclInt.h" @@ -1618,23 +1618,6 @@ PushProcCallFrame( return TCL_OK; } -static int -Tcl_NRBC( - Tcl_Interp *interp, - ByteCode *codePtr, - Tcl_NRPostProc *postProcPtr, - Tcl_Obj *procNameObj, - ProcErrorProc errorProc) -{ - TEOV_record *recordPtr = TOP_RECORD(interp); - - recordPtr->type = TCL_NR_BC_TYPE; - recordPtr->data.codePtr = codePtr; - TclNRAddCallback(interp, postProcPtr, procNameObj, errorProc, NULL, - NULL); - return TCL_OK; -} - /* *---------------------------------------------------------------------- * @@ -1663,16 +1646,10 @@ TclObjInterpProc( Tcl_Obj *const objv[]) /* Argument value objects. */ { /* - * Not used in the core; external interface for iTcl and XOTcl + * Not used much in the core; external interface for iTcl */ - int result = PushProcCallFrame(clientData, interp, objc, objv, - /*isLambda*/ 0); - - if (result != TCL_OK) { - return TCL_ERROR; - } - return TclObjInterpProcCore(interp, objv[0], 1, &MakeProcError); + return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv); } int @@ -1697,7 +1674,7 @@ TclNRInterpProc( /* *---------------------------------------------------------------------- * - * TclObjInterpProcCore -- + * TclNRInterpProcCore -- * * When a Tcl procedure, lambda term or anything else that works like a * procedure gets invoked during bytecode evaluation, this object-based @@ -1713,49 +1690,6 @@ TclNRInterpProc( */ int -TclObjInterpProcCore( - register Tcl_Interp *interp,/* Interpreter in which procedure was - * invoked. */ - Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ - int skip, /* Number of initial arguments to be skipped, - * i.e., words in the "command name". */ - ProcErrorProc errorProc) /* How to convert results from the script into - * results of the overall procedure. */ -{ - /* - * Not used in the core; external interface for TclOO - */ - - Interp *iPtr = (Interp *) interp; - TEOV_record record, *rootPtr; - int result; - - /* - * Put a top record NOT ON THE TCL STACK! Note that TclNRInterpProcCore - * assumes it can free the CallFrame in the error case, there cannot be - * anything else on top of that. We use a C-stack record, it could also be - * ckalloc'ed or anything else, just NOT TclStackAlloc. - */ - - rootPtr = TOP_RECORD(iPtr); - TOP_RECORD(iPtr) = &record; - result = TclNRInterpProcCore(interp, procNameObj, skip, errorProc); - TOP_RECORD(iPtr) = rootPtr; - - 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); - } - return result; -} - -int TclNRInterpProcCore( register Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1837,7 +1771,9 @@ TclNRInterpProcCore( (Tcl_Obj **)(iPtr->varFramePtr->objv + l)); } - Tcl_NRBC(interp, codePtr, InterpProcNR2, procNameObj, errorProc); + TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, + NULL, NULL); + TclNRAddCallback(interp, NRRunBytecode, codePtr, NULL, NULL, NULL); return TCL_OK; } @@ -2825,21 +2761,8 @@ TclNRApplyObjCmd( result = PushProcCallFrame((ClientData) procPtr, interp, objc, objv, 1); if (result == TCL_OK) { + TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); - if (result == TCL_OK) { - /* Fix the recordPtr! */ - - TEOV_record *recordPtr = TOP_RECORD(iPtr); - - recordPtr->callbackPtr->procPtr = ApplyNR2; - recordPtr->callbackPtr->data[2] = extraPtr; - } - } - if (result != TCL_OK) { - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = NULL; - } - TclStackFree(interp, extraPtr); } return result; } @@ -2850,10 +2773,8 @@ ApplyNR2( Tcl_Interp *interp, int result) { - ApplyExtraData *extraPtr = data[2]; + ApplyExtraData *extraPtr = data[0]; - result = InterpProcNR2(data, interp, result); - if (extraPtr->isRootEnsemble) { ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 76c0e15..49f5029 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -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: tclStubInit.c,v 1.161 2008/07/22 23:06:25 das Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.162 2008/07/29 05:30:38 msofer Exp $ */ #include "tclInt.h" @@ -297,7 +297,7 @@ static const TclIntStubs tclIntStubs = { TclTraceDictPath, /* 225 */ TclObjBeingDeleted, /* 226 */ TclSetNsPath, /* 227 */ - TclObjInterpProcCore, /* 228 */ + NULL, /* 228 */ TclPtrMakeUpvar, /* 229 */ TclObjLookupVar, /* 230 */ TclGetNamespaceFromObj, /* 231 */ @@ -307,12 +307,11 @@ static const TclIntStubs tclIntStubs = { TclInitVarHashTable, /* 235 */ TclBackgroundException, /* 236 */ TclResetCancellation, /* 237 */ - TclEvalObjv_NR2, /* 238 */ - TclNRInterpProc, /* 239 */ - TclNRInterpProcCore, /* 240 */ - TclNRPushRecord, /* 241 */ - TclNRPopAndFreeRecord, /* 242 */ - TclNREvalObjEx, /* 243 */ + TclNRInterpProc, /* 238 */ + TclNRInterpProcCore, /* 239 */ + TclNRRunCallbacks, /* 240 */ + TclNREvalObjEx, /* 241 */ + TclNREvalObjv, /* 242 */ }; static const TclIntPlatStubs tclIntPlatStubs = { @@ -1108,13 +1107,13 @@ static const TclStubs tclStubs = { Tcl_AppendPrintfToObj, /* 579 */ Tcl_CancelEval, /* 580 */ Tcl_Canceled, /* 581 */ - Tcl_NRCreateCommand, /* 582 */ - Tcl_NREvalObj, /* 583 */ - Tcl_NREvalObjv, /* 584 */ - Tcl_NRCmdSwap, /* 585 */ - Tcl_NRAddCallback, /* 586 */ - Tcl_NRCallObjProc, /* 587 */ - Tcl_CreatePipe, /* 588 */ + Tcl_CreatePipe, /* 582 */ + Tcl_NRCreateCommand, /* 583 */ + Tcl_NREvalObj, /* 584 */ + Tcl_NREvalObjv, /* 585 */ + Tcl_NRCmdSwap, /* 586 */ + Tcl_NRAddCallback, /* 587 */ + Tcl_NRCallObjProc, /* 588 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 3052cc9..4ce4277 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.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: tclTest.c,v 1.118 2008/07/28 21:31:19 nijtmans Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.119 2008/07/29 05:30:38 msofer Exp $ */ #define TCL_TEST @@ -402,6 +402,9 @@ static int TestNumUtfCharsCmd(ClientData clientData, static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestNRELevels(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static const Tcl_Filesystem testReportingFilesystem = { "reporting", @@ -658,6 +661,10 @@ Tcltest_Init( Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, (ClientData) 0); + Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, + (ClientData) NULL, NULL); + + #ifdef TCL_THREADS if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; @@ -6527,6 +6534,35 @@ TestgetintCmd( } } +static int +TestNRELevels( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + static ptrdiff_t *refDepth = NULL; + ptrdiff_t depth; + Tcl_Obj *levels[5]; + + if (refDepth == NULL) { + refDepth = &depth; + } + + depth = (refDepth - &depth); + + levels[0] = Tcl_NewIntObj(depth); + levels[1] = Tcl_NewIntObj(((Interp *)interp)->numLevels); + levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level); + levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); + levels[4] = Tcl_NewIntObj((iPtr->execEnvPtr->execStackPtr->tosPtr + - iPtr->execEnvPtr->execStackPtr->stackWords)); + + Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels)); + return TCL_OK; +} + /* * Local Variables: * mode: c |