Attachment "TIP285-rev2.diff" to
ticket [3168398fff]
added by
mistachkin
2011-01-31 05:28:51.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 02856bc..ec35429 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;
@@ -4358,7 +4344,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)) {
@@ -4487,7 +4473,7 @@ TEOV_Exception(
* here directly.
*/
- iPtr->flags &= (~(CANCELED | TCL_CANCEL_UNWIND));
+ TclUnsetCancelFlags(iPtr);
return result;
}
@@ -6190,7 +6176,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 88e56d7..6c61a69 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2077,10 +2077,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.
@@ -2097,12 +2093,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
@@ -2277,10 +2278,12 @@ TEBCresume(
}
}
+ if (TclCanceled(iPtr)) {
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
CACHE_STACK_INFO();
goto gotError;
}
+ }
if (TclLimitReady(iPtr->limit)) {
if (Tcl_LimitCheck(interp) == TCL_ERROR) {
@@ -6300,7 +6303,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 adaac48..3cafe23 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 b77d870..d3ee1fe 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 e791ed5..0dc9d4a 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 07d6520..88ed5fc 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 7a904d4..4f08c9d 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 146c9ee..d3023ff 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 460caa1..7287881 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
