diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclBasic.c | 70 | ||||
| -rw-r--r-- | generic/tclExecute.c | 21 | ||||
| -rw-r--r-- | generic/tclInt.decls | 5 | ||||
| -rw-r--r-- | generic/tclInt.h | 16 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 6 | ||||
| -rw-r--r-- | generic/tclInterp.c | 76 | ||||
| -rw-r--r-- | generic/tclOODecls.h | 2 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 1 | ||||
| -rw-r--r-- | win/makefile.vc | 6 |
10 files changed, 159 insertions, 55 deletions
@@ -1,5 +1,16 @@ 2011-03-01 Miguel Sofer <msofer@users.sf.net> + * generic/tclBasic.c: This is [Patch 3168398], + * generic/tclCompCmdsSZ.c: Joe Mistachkin's optimisation + * generic/tclExecute.c: of Tip #285 + * generic/tclInt.decls: + * generic/tclInt.h: + * generic/tclIntDecls.h: + * generic/tclInterp.c: + * generic/tclOODecls.h: + * generic/tclStubInit.c: + * win/makefile.vc: + * generic/tclExecute.c (ExprObjCallback): fix object leak * generic/tclExecute.c (TEBCresume): store local var array and diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d2c506d..e16dc86 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3235,28 +3235,29 @@ CancelEvalProc( if (iPtr != NULL) { /* - * Setting this flag will cause the script in progress to be - * canceled as soon as possible. The core honors this flag at all - * the necessary places to ensure script cancellation is + * Setting the CANCELED flag will cause the script in progress to + * be canceled as soon as possible. The core honors this flag at + * all the necessary places to ensure script cancellation is * responsive. Extensions can check for this flag by calling * Tcl_Canceled and checking if TCL_ERROR is returned or they can * choose to ignore the script cancellation flag and the - * associated functionality altogether. + * associated functionality altogether. Currently, the only other + * flag we care about here is the TCL_CANCEL_UNWIND flag (from + * Tcl_CancelEval). We do not want to simply combine all the flags + * from original Tcl_CancelEval call with the interp flags here + * just in case the caller passed flags that might cause behaviour + * unrelated to script cancellation. */ - iPtr->flags |= CANCELED; + TclSetCancelFlags(iPtr, cancelInfo->flags | CANCELED); /* - * Currently, we only care about the TCL_CANCEL_UNWIND flag from - * Tcl_CancelEval. We do not want to simply combine all the flags - * from original Tcl_CancelEval call with the interp flags here - * just in case the caller passed flags that might cause behaviour - * unrelated to script cancellation. + * Now, we must set the script cancellation flags on all the slave + * interpreters belonging to this one. */ - if (cancelInfo->flags & TCL_CANCEL_UNWIND) { - iPtr->flags |= TCL_CANCEL_UNWIND; - } + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, + cancelInfo->flags | CANCELED, 0); /* * Create the result object now so that Tcl_Canceled can avoid @@ -3785,7 +3786,15 @@ TclInterpReady( return TCL_ERROR; } - if (iPtr->execEnvPtr->rewind || + if (iPtr->execEnvPtr->rewind) { + return TCL_ERROR; + } + + /* + * Make sure the script being evaluated (if any) has not been canceled. + */ + + if (TclCanceled(iPtr) && (TCL_OK != Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } @@ -3835,7 +3844,7 @@ TclResetCancellation( } if (force || (iPtr->numLevels == 0)) { - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } return TCL_OK; } @@ -3873,21 +3882,12 @@ Tcl_Canceled( register Interp *iPtr = (Interp *) interp; /* - * Traverse up the to the top-level interp, checking for the CANCELED flag - * along the way. If any of the intervening interps have the CANCELED flag - * set, the current script in progress is considered to be canceled and we - * stop checking. Otherwise, if any interp has the DELETED flag set we - * stop checking. - */ - - for (; iPtr!=NULL; iPtr = (Interp *) Tcl_GetMaster((Tcl_Interp *) iPtr)) { - /* * Has the current script in progress for this interpreter been * canceled or is the stack being unwound due to the previous script * cancellation? */ - if ((iPtr->flags & CANCELED) || (iPtr->flags & TCL_CANCEL_UNWIND)) { + if (TclCanceled(iPtr)) { /* * The CANCELED flag is a one-shot flag that is reset immediately * upon being detected; however, if the TCL_CANCEL_UNWIND flag is @@ -3955,20 +3955,6 @@ Tcl_Canceled( return TCL_ERROR; } - } else { - /* - * FIXME: If this interpreter is being deleted we cannot continue - * to traverse up the interp chain due to an issue with - * Tcl_GetMaster (really the slave interp bookkeeping) that causes - * us to run off into a freed interp struct. Ideally, this check - * would not be necessary because Tcl_GetMaster would return NULL - * instead of a pointer to invalid (freed) memory. - */ - - if (iPtr->flags & DELETED) { - break; - } - } } return TCL_OK; @@ -4365,7 +4351,7 @@ NRCommand( if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); } - if (result == TCL_OK) { + if ((result == TCL_OK) && TclCanceled(iPtr)) { result = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG); } if (result == TCL_OK && TclLimitReady(iPtr->limit)) { @@ -4494,7 +4480,7 @@ TEOV_Exception( * here directly. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); return result; } @@ -6197,7 +6183,7 @@ TEOEx_ByteCodeCallback( * Let us just unset the flags inline. */ - iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)); + TclUnsetCancelFlags(iPtr); } iPtr->evalFlags = 0; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index aa0c8b7..d34b364 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2080,10 +2080,6 @@ TEBCresume( * stack. */ const unsigned char *pc; /* The current program counter. */ -#ifdef TCL_COMPILE_DEBUG - traceInstructions = (tclTraceExec == 3); -#endif - /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. @@ -2100,12 +2096,17 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv; - int opnd, objc, length, pcAdjustment; + int objc = 0; + int opnd, length, pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; #endif +#ifdef TCL_COMPILE_DEBUG + traceInstructions = (tclTraceExec == 3); +#endif + NR_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG @@ -2280,9 +2281,11 @@ TEBCresume( } } - if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { - CACHE_STACK_INFO(); - goto gotError; + if (TclCanceled(iPtr)) { + if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { + CACHE_STACK_INFO(); + goto gotError; + } } if (TclLimitReady(iPtr->limit)) { @@ -6303,7 +6306,7 @@ TEBCresume( * already be set prior to vectoring down to this point in the code. */ - if (Tcl_Canceled(interp, 0) == TCL_ERROR) { + if (TclCanceled(iPtr) && (Tcl_Canceled(interp, 0) == TCL_ERROR)) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " ... cancel with unwind, returning %s\n", diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 61f25d8..d39634e 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1002,6 +1002,11 @@ declare 249 { int* decpt, int* signum, char** endPtr) } +# TIP #285: Script cancellation support. +declare 250 { + void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) +} + ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclInt.h b/generic/tclInt.h index f759593..cbb5600 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2184,6 +2184,22 @@ typedef struct Interp { *((iPtr)->asyncReadyPtr) /* + * Macros for script cancellation support (TIP #285). + */ + +#define TclCanceled(iPtr) \ + (((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND)) + +#define TclSetCancelFlags(iPtr, cancelFlags) \ + (iPtr)->flags |= CANCELED; \ + if ((cancelFlags) & TCL_CANCEL_UNWIND) { \ + (iPtr)->flags |= TCL_CANCEL_UNWIND; \ + } + +#define TclUnsetCancelFlags(iPtr) \ + (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)) + +/* * General list of interpreters. Doubly linked for easier removal of items * deep in the list. */ diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index cae5e4e..23f500f 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -600,6 +600,9 @@ EXTERN int TclCopyChannel(Tcl_Interp *interp, /* 249 */ EXTERN char* TclDoubleDigits(double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); +/* 250 */ +EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, + int force); typedef struct TclIntStubs { int magic; @@ -855,6 +858,7 @@ typedef struct TclIntStubs { void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char* (*tclDoubleDigits) (double dv, int ndigits, int flags, int*decpt, int*signum, char**endPtr); /* 249 */ + void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ } TclIntStubs; #ifdef __cplusplus @@ -1277,6 +1281,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCopyChannel) /* 248 */ #define TclDoubleDigits \ (tclIntStubsPtr->tclDoubleDigits) /* 249 */ +#define TclSetSlaveCancelFlags \ + (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 6ccde87..bfcc383 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2096,6 +2096,72 @@ Tcl_GetMaster( /* *---------------------------------------------------------------------- * + * TclSetSlaveCancelFlags -- + * + * This function marks all slave interpreters belonging to a given + * interpreter as being canceled or not canceled, depending on the + * provided flags. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclSetSlaveCancelFlags( + Tcl_Interp *interp, /* Set cancel flags of this interpreter. */ + int flags, /* Collection of OR-ed bits that control + * the cancellation of the script. Only + * TCL_CANCEL_UNWIND is currently + * supported. */ + int force) /* Non-zero to ignore numLevels for the purpose + * of resetting the cancellation flags. */ +{ + Master *masterPtr; /* Master record of given interpreter. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hashSearch; /* Search variable. */ + Slave *slavePtr; /* Slave record of interpreter. */ + Interp *iPtr; + + if (interp == NULL) { + return; + } + + flags &= (CANCELED | TCL_CANCEL_UNWIND); + + masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master; + + hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + slavePtr = Tcl_GetHashValue(hPtr); + iPtr = (Interp *) slavePtr->slaveInterp; + + if (iPtr == NULL) { + continue; + } + + if (flags == 0) { + TclResetCancellation((Tcl_Interp *) iPtr, force); + } else { + TclSetCancelFlags(iPtr, flags); + } + + /* + * Now, recursively handle this for the slaves of this slave + * interpreter. + */ + + TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force); + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list @@ -2717,6 +2783,16 @@ SlaveEval( { int result; + /* + * TIP #285: If necessary, reset the cancellation flags for the slave + * interpreter now; otherwise, canceling a script in a master interpreter + * can result in a situation where a slave interpreter can no longer + * evaluate any scripts unless somebody calls the TclResetCancellation + * function for that particular Tcl_Interp. + */ + + TclSetSlaveCancelFlags(slaveInterp, 0, 0); + Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 697570d..161be09 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -24,7 +24,7 @@ * in the generic/tclOO.decls script. */ -#if defined(USE_TCLOO_STUBS) +#if defined(USE_TCL_STUBS) extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version); #define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp),TCLOO_VERSION) #else diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 98ef9b7..542e604 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -306,6 +306,7 @@ static const TclIntStubs tclIntStubs = { TclResetRewriteEnsemble, /* 247 */ TclCopyChannel, /* 248 */ TclDoubleDigits, /* 249 */ + TclSetSlaveCancelFlags, /* 250 */ }; static const TclIntPlatStubs tclIntPlatStubs = { diff --git a/win/makefile.vc b/win/makefile.vc index 988d823..cbba5f5 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -494,11 +494,11 @@ STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) #--------------------------------------------------------------------- !if $(DEBUG) -ldebug = -debug:full -debugtype:cv +ldebug = -debug -debugtype:cv !else ldebug = -release -opt:ref -opt:icf,3 !if $(SYMBOLS) -ldebug = $(ldebug) -debug:full -debugtype:cv +ldebug = $(ldebug) -debug -debugtype:cv !endif !endif @@ -831,7 +831,7 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @DEFS@ $(TCL_CFLAGS) @CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd @CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD -@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug:full -debugtype:cv +@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv @LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3 @TCL_DBGX@ $(SUFX) @TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib |