This is [Patch 3168398], Joe Mistachkin's optimisation of Tip #285

10 files changed, 159 insertions, 55 deletions

diff --git a/ChangeLog b/ChangeLog
index c091aab..4a3a224 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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