[Bugs 2835313, 3614226]: Complete the construction of break/continue compilers

that get the stack cleanup right, even when there's expansion going on.

7 files changed, 254 insertions, 90 deletions

diff --git a/ChangeLog b/ChangeLog
index 53bcb80..15bab6e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,17 @@
+2013-06-05  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclExecute.c (INST_EXPAND_DROP): [Bugs 2835313, 3614226]:
+	New opcode to allow resetting the stack to get rid of an expansion,
+	restoring the stack to a known state in the process.
+	* generic/tclCompile.c, generic/tclCompCmds.c: Adjusted the compilers
+	for [break] and [continue] to get stack cleanup right in the majority
+	of cases.
+	* tests/for.test (for-7.*): Set of tests for these evil cases.
+
 2013-06-04  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* unix/tcl.m4: Eliminate NO_VIZ macro as current
-	zlib uses HAVE_HIDDEN in stead. One more last-moment
-	fix for FreeBSD by Pietro Cerutti
+	* unix/tcl.m4: Eliminate NO_VIZ macro as current zlib uses HAVE_HIDDEN
+	instead. One more last-moment fix for FreeBSD by Pietro Cerutti
 
 2013-06-03  Miguel Sofer  <msofer@users.sf.net>
 
@@ -10,7 +19,7 @@
 	(https://groups.google.com/forum/?fromgroups#!topic/comp.lang.tcl/vfpI3bc-DkQ),
 	diagnosed by dgp to be a close relative of [Bug 781585], which was
 	fixed by commit	[f46fb50cb3]. This bug was introduced by myself in
-	commit [cbfe055d8c]. 
+	commit [cbfe055d8c].
 
 2013-06-03  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -24,14 +33,14 @@
 2013-05-27 Harald Oehlmann  <oehhar@users.sf.net>
 
 	* library/msgcat/msgcat.tcl: [Bug 3036566]: Also get locale from
-	registry key HCU\Control Panel\Desktop : PreferredUILanguages to
-	honor installed language packs on Vista+.
+	registry key HCU\Control Panel\Desktop : PreferredUILanguages to honor
+	installed language packs on Vista+.
 	Bumped msgcat version to 1.5.2
 
 2013-05-22  Andreas Kupries  <andreask@activestate.com>
 
 	* tclCompile.c: Removed duplicate const qualifier causing the HP
-	  native cc to error out.
+	native cc to error out.
 
 2013-05-22  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -93,10 +102,9 @@
 2013-04-30  Andreas Kupries  <andreask@activestate.com>
 
 	* library/platform/platform.tcl (::platform::LibcVersion):
-	* library/platform/pkgIndex.tcl: Followup to the 2013-01-30
-	  change. The RE become too restrictive again. SuSe added a
-	  timestamp after the version. Loosened up a bit. Bumped package
-	  to version 1.0.12.
+	* library/platform/pkgIndex.tcl: Followup to the 2013-01-30 change.
+	The RE become too restrictive again. SuSe added a timestamp after the
+	version. Loosened up a bit. Bumped package to version 1.0.12.
 
 2013-04-29  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -115,8 +123,8 @@
 2013-04-19  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclDecls.h: Implement many Tcl_*Var* functions and
-	Tcl_GetIndexFromObj as (faster/stack-saving) macros around resp
-	their Tcl_*Var*2 equivalent and Tcl_GetIndexFromObjStruct.
+	Tcl_GetIndexFromObj as (faster/stack-saving) macros around resp their
+	Tcl_*Var*2 equivalent and Tcl_GetIndexFromObjStruct.
 
 2013-04-12  Jan Nijtmans  <nijtmans@users.sf.net>
 
@@ -125,16 +133,16 @@
 
 2013-04-08  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/regc_color.c:	[Bug 3610026] Stop crash when the number of
-	* generic/regerrs.h:	"colors" in a regular expression overflows
-	* generic/regex.h:	a short int.  Thanks to Heikki Linnakangas
-	* generic/regguts.h:	for the report and the patch.
+	* generic/regc_color.c:	[Bug 3610026]: Stop crash when the number of
+	* generic/regerrs.h:	"colors" in a regular expression overflows a
+	* generic/regex.h:	short int.  Thanks to Heikki Linnakangas for
+	* generic/regguts.h:	the report and the patch.
 	* tests/regexp.test:
 
 2013-04-04  Reinhard Max  <max@suse.de>
 
-	* library/http/http.tcl (http::geturl): Allow URLs that don't have
-	a path, but a query query, e.g. http://example.com?foo=bar .
+	* library/http/http.tcl (http::geturl): Allow URLs that don't have a
+	path, but a query query, e.g. http://example.com?foo=bar
 	* Bump the http package to 2.8.7.
 
 2013-03-22  Venkat Iyer <venkat@comit.com>
@@ -166,12 +174,12 @@
 
 2013-03-21  Don Porter  <dgp@users.sourceforge.net>
 
-	* library/auto.tcl: [Bug 2102614] Add ensemble indexing support
-	* tests/autoMkindex.test: to [auto_mkindex].  Thanks Brian Griffin.
+	* library/auto.tcl: [Bug 2102614]: Add ensemble indexing support to
+	* tests/autoMkindex.test: [auto_mkindex].  Thanks Brian Griffin.
 
 2013-03-19  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclFCmd.c: [Bug 3597000] Consistent [file copy] result.
+	* generic/tclFCmd.c: [Bug 3597000]: Consistent [file copy] result.
 	* tests/fileSystem.test:
 
 2013-03-19  Jan Nijtmans  <nijtmans@users.sf.net>
@@ -191,20 +199,20 @@
 
 2013-03-11  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCompile.c:	[Bugs 3607246,3607372] Unbalanced refcounts
+	* generic/tclCompile.c:	[Bugs 3607246,3607372]: Unbalanced refcounts
 	* generic/tclLiteral.c:	of literals in the global literal table.
 
 2013-03-06  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/regc_nfa.c:	[Bugs 3604074,3606683] Rewrite of the
-	* generic/regcomp.c:	fixempties() routine (and supporting
-	routines) to completely eliminate the infinite loop hazard.
-	Thanks to Tom Lane for the much improved solution.
+	* generic/regc_nfa.c:	[Bugs 3604074,3606683]: Rewrite of the
+	* generic/regcomp.c:	fixempties() routine (and supporting routines)
+	to completely eliminate the infinite loop hazard. Thanks to Tom Lane
+	for the much improved solution.
 
 2013-02-28  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclLiteral.c:	Revise TclReleaseLiteral() to tolerate a
-	NULL interp argument.
+	* generic/tclLiteral.c:	Revise TclReleaseLiteral() to tolerate a NULL
+	interp argument.
 
 	* generic/tclCompile.c:	Update callers and revise mistaken comments.
 	* generic/tclProc.c:
@@ -4899,8 +4907,7 @@
 2010-05-19  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	* tests/dict.test: Add missing tests for [Bug 3004007], fixed under
-	                   the radar on 2010-02-24 (dkf): EIAS violation in
-	                   list-dict conversions.
+	the radar on 2010-02-24 (dkf): EIAS violation in list-dict conversions
 
 2010-05-19  Jan Nijtmans  <nijtmans@users.sf.net>
 
@@ -6754,10 +6761,9 @@
 
 2009-11-11  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
-	* generic/tclIO.c: Fix [Bug 2888099] (close discards ENOSPC error)
-	                   by saving the errno from the first of two
-	                   FlushChannel()s. Uneasy to test; might need
-	                   specific channel drivers. Four-hands with aku.
+	* generic/tclIO.c: Fix [Bug 2888099] (close discards ENOSPC error) by
+	saving the errno from the first of two FlushChannel()s. Uneasy to
+	test; might need specific channel drivers. Four-hands with aku.
 
 2009-11-10  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index d1af8c6..62641e6 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -20,7 +20,7 @@
  *-   break and continue - if exception ranges can be sorted out.
  *-   foreach_start4, foreach_step4
  *-   returnImm, returnStk
- *-   expandStart, expandStkTop, invokeExpanded
+ *-   expandStart, expandStkTop, invokeExpanded, expandDrop
  *-   dictFirst, dictNext, dictDone
  *-   dictUpdateStart, dictUpdateEnd
  *-   jumpTable testing
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 3046841..365e647 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -493,37 +493,24 @@ TclCompileBreakCmd(
 
     rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	int toPop = envPtr->currStackDepth - auxPtr->stackDepth;
-
 	/*
-	 * Pop off the extra stack frames.
+	 * Found the target! No need for a nasty INST_BREAK here.
 	 */
 
-	while (toPop > 0) {
-	    TclEmitOpcode(INST_POP, envPtr);
-	    TclAdjustStackDepth(1, envPtr);
-	    toPop--;
-	}
-
-	if (envPtr->expandCount == auxPtr->expandTarget) {
-	    /*
-	     * Found the target! Also, no built-up expansion stack. No need
-	     * for a nasty INST_BREAK here.
-	     */
+	TclCleanupStackForBreakContinue(envPtr, auxPtr);
+	TclAddLoopBreakFixup(envPtr, auxPtr);
+    } else {
+	/*
+	 * Emit a real break.
+	 */
 
-	    TclAddLoopBreakFixup(envPtr, auxPtr);
-	    goto done;
-	}
+	PushStringLiteral(envPtr, "");
+	TclEmitOpcode(INST_DUP, envPtr);
+	TclEmitInstInt4(INST_RETURN_IMM, TCL_BREAK, envPtr);
+	TclEmitInt4(0, envPtr);
     }
 
     /*
-     * Emit a break instruction.
-     */
-
-    TclEmitOpcode(INST_BREAK, envPtr);
-
-  done:
-    /*
      * Instructions that raise exceptions don't really have to follow the
      * usual stack management rules, but the cleanup code does.
      */
@@ -840,37 +827,24 @@ TclCompileContinueCmd(
 
     rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	int toPop = envPtr->currStackDepth - auxPtr->stackDepth;
-
 	/*
-	 * Pop off the extra stack frames.
+	 * Found the target! No need for a nasty INST_CONTINUE here.
 	 */
 
-	while (toPop > 0) {
-	    TclEmitOpcode(INST_POP, envPtr);
-	    TclAdjustStackDepth(1, envPtr);
-	    toPop--;
-	}
-
-	if (envPtr->expandCount == auxPtr->expandTarget) {
-	    /*
-	     * Found the target! Also, no built-up expansion stack. No need
-	     * for a nasty INST_CONTINUE here.
-	     */
+	TclCleanupStackForBreakContinue(envPtr, auxPtr);
+	TclAddLoopContinueFixup(envPtr, auxPtr);
+    } else {
+	/*
+	 * Emit a real continue.
+	 */
 
-	    TclAddLoopContinueFixup(envPtr, auxPtr);
-	    goto done;
-	}
+	PushStringLiteral(envPtr, "");
+	TclEmitOpcode(INST_DUP, envPtr);
+	TclEmitInstInt4(INST_RETURN_IMM, TCL_CONTINUE, envPtr);
+	TclEmitInt4(0, envPtr);
     }
 
     /*
-     * Emit a continue instruction.
-     */
-
-    TclEmitOpcode(INST_CONTINUE, envPtr);
-
-  done:
-    /*
      * Instructions that raise exceptions don't really have to follow the
      * usual stack management rules, but the cleanup code does.
      */
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index f2e9329..69517bc 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -540,6 +540,10 @@ InstructionDesc const tclInstructionTable[] = {
 	 * list and pushes that resulting list onto the stack.
 	 * Stack: ... list1 list2 => ... [lconcat list1 list2] */
 
+    {"expandDrop",       1,    0,          0,	{OPERAND_NONE}},
+	/* Drops an element from the auxiliary stack, popping stack elements
+	 * until the matching stack depth is reached. */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
@@ -571,6 +575,7 @@ static void		RecordByteCodeStats(ByteCode *codePtr);
 static void		RegisterAuxDataType(const AuxDataType *typePtr);
 static int		SetByteCodeFromAny(Tcl_Interp *interp,
 			    Tcl_Obj *objPtr);
+static void		StartExpanding(CompileEnv *envPtr);
 static int		FormatInstruction(ByteCode *codePtr,
 			    const unsigned char *pc, Tcl_Obj *bufferObj);
 static void		PrintSourceToObj(Tcl_Obj *appendObj,
@@ -2060,8 +2065,7 @@ TclCompileScript(
 	     */
 
 	    if (expand) {
-		TclEmitOpcode(INST_EXPAND_START, envPtr);
-		envPtr->expandCount++;
+		StartExpanding(envPtr);
 	    }
 
 	    /*
@@ -3466,6 +3470,7 @@ TclCreateExceptRange(
     auxPtr->supportsContinue = 1;
     auxPtr->stackDepth = envPtr->currStackDepth;
     auxPtr->expandTarget = envPtr->expandCount;
+    auxPtr->expandTargetDepth = -1;
     auxPtr->numBreakTargets = 0;
     auxPtr->breakTargets = NULL;
     auxPtr->allocBreakTargets = 0;
@@ -3586,6 +3591,103 @@ TclAddLoopContinueFixup(
 /*
  * ---------------------------------------------------------------------
  *
+ * TclCleanupStackForBreakContinue --
+ *
+ *	Ditch the extra elements from the auxiliary stack and the main
+ *	stack. How to do this exactly depends on whether there are any
+ *	elements on the auxiliary stack to pop.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclCleanupStackForBreakContinue(
+    CompileEnv *envPtr,
+    ExceptionAux *auxPtr)
+{
+    int toPop = envPtr->expandCount - auxPtr->expandTarget;
+
+    if (toPop > 0) {
+	while (toPop > 0) {
+	    TclEmitOpcode(INST_EXPAND_DROP, envPtr);
+	    toPop--;
+	}
+	toPop = auxPtr->expandTargetDepth - auxPtr->stackDepth;
+	while (toPop > 0) {
+	    TclEmitOpcode(INST_POP, envPtr);
+	    TclAdjustStackDepth(1, envPtr);
+	    toPop--;
+	}
+    } else {
+	toPop = envPtr->currStackDepth - auxPtr->stackDepth;
+	while (toPop > 0) {
+	    TclEmitOpcode(INST_POP, envPtr);
+	    TclAdjustStackDepth(1, envPtr);
+	    toPop--;
+	}
+    }
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * StartExpanding --
+ *
+ *	Pushes an INST_EXPAND_START and does some additional housekeeping so
+ *	that the [break] and [continue] compilers can use an exception-free
+ *	issue to discard it.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static void
+StartExpanding(
+    CompileEnv *envPtr)
+{
+    int i;
+
+    TclEmitOpcode(INST_EXPAND_START, envPtr);
+
+    /*
+     * Update inner exception ranges with information about the environment
+     * where this expansion started.
+     */
+
+    for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+	ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+	ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i];
+
+	/*
+	 * Ignore loops unless they're still being built.
+	 */
+
+	if (rangePtr->codeOffset > CurrentOffset(envPtr)) {
+	    continue;
+	}
+	if (rangePtr->numCodeBytes != -1) {
+	    continue;
+	}
+
+	/*
+	 * Adequate condition: further out loops and further in exceptions
+	 * don't actually need this information.
+	 */
+
+	if (auxPtr->expandTarget == envPtr->expandCount) {
+	    auxPtr->expandTargetDepth = envPtr->currStackDepth;
+	}
+    }
+
+    /*
+     * There's now one more expansion being processed on the auxiliary stack.
+     */
+
+    envPtr->expandCount++;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
  * TclFinalizeLoopExceptionRange --
  *
  *	Finalizes a loop exception range, binding the registered [break] and
@@ -3626,7 +3728,8 @@ TclFinalizeLoopExceptionRange(
 	    int j;
 
 	    /*
-	     * WTF? Can't bind, so revert to an INST_CONTINUE.
+	     * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough
+	     * space to do anything else.
 	     */
 
 	    *site = INST_CONTINUE;
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 957c724..15b5477 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -120,6 +120,11 @@ typedef struct ExceptionAux {
 				 * we can't currently discard them except by
 				 * doing INST_INVOKE_EXPANDED; this is a known
 				 * problem. */
+    int expandTargetDepth;	/* The stack depth expected at the outermost
+				 * expansion within the loop. Not meaningful
+				 * if there have are no open expansions
+				 * between the looping level and the point of
+				 * jump issue. */
     int numBreakTargets;	/* The number of [break]s that want to be
 				 * targeted to the place where this loop
 				 * exception will be bound to. */
@@ -772,8 +777,10 @@ typedef struct ByteCode {
 
 #define INST_LIST_CONCAT		164
 
+#define INST_EXPAND_DROP		165
+
 /* The last opcode */
-#define LAST_INST_OPCODE		164
+#define LAST_INST_OPCODE		165
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
@@ -985,6 +992,8 @@ MODULE_SCOPE ByteCode *	TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
  */
 
 MODULE_SCOPE void	TclCleanupByteCode(ByteCode *codePtr);
+MODULE_SCOPE void	TclCleanupStackForBreakContinue(CompileEnv *envPtr,
+			    ExceptionAux *auxPtr);
 MODULE_SCOPE void	TclCompileCmdWord(Tcl_Interp *interp,
 			    Tcl_Token *tokenPtr, int count,
 			    CompileEnv *envPtr);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 8c87364..98ce51e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2718,6 +2718,18 @@ TEBCresume(
 	PUSH_TAUX_OBJ(objPtr);
 	NEXT_INST_F(1, 0, 0);
 
+    case INST_EXPAND_DROP:
+	/*
+	 * Drops an element of the auxObjList, popping stack elements to
+	 * restore the stack to the state before the point where the aux
+	 * element was created.
+	 */
+
+	CLANG_ASSERT(auxObjList);
+	objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
+	POP_TAUX_OBJ();
+	NEXT_INST_V(1, objc, 0);
+
     case INST_EXPAND_STKTOP: {
 	int i;
 	ptrdiff_t moved;
diff --git a/tests/for.test b/tests/for.test
index 3f4d2b7..8936682 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -854,7 +854,7 @@ test for-7.2 {Bug 3614226: ensure that continue cleans up the stack} memory {
 	expr {$end - $tmp}
     }}
 } 0
-test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} {memory knownBug} {
+test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} memory {
     apply {{} {
 	# Can't use [memtest]; must be careful when we change stack frames
 	set end [meminfo]
@@ -868,7 +868,7 @@ test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} {mem
 	expr {$end - $tmp}
     }}
 } 0
-test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} {memory knownBug} {
+test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} memory {
     apply {{} {
 	# Can't use [memtest]; must be careful when we change stack frames
 	set end [meminfo]
@@ -882,6 +882,66 @@ test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} {
 	expr {$end - $tmp}
     }}
 } 0
+test for-7.5 {Bug 3614226: ensure that break cleans up the combination of main and expansion stack} memory {
+    apply {{} {
+	set l [lrepeat 50 p q r]
+	# Can't use [memtest]; must be careful when we change stack frames
+	set end [meminfo]
+	for {set i 0} {$i < 5} {incr i} {
+	    for {set x 0} {[incr x]<50} {} {
+		puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]]
+	    }
+	    set tmp $end
+	    set end [meminfo]
+	}
+	expr {$end - $tmp}
+    }}
+} 0
+test for-7.6 {Bug 3614226: ensure that continue cleans up the combination of main and expansion stack} memory {
+    apply {{} {
+	set l [lrepeat 50 p q r]
+	# Can't use [memtest]; must be careful when we change stack frames
+	set end [meminfo]
+	for {set i 0} {$i < 5} {incr i} {
+	    for {set x 0} {[incr x]<50} {} {
+		puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]]
+	    }
+	    set tmp $end
+	    set end [meminfo]
+	}
+	expr {$end - $tmp}
+    }}
+} 0
+test for-7.7 {Bug 3614226: ensure that break only cleans up the right amount} memory {
+    apply {{} {
+	set l [lrepeat 50 p q r]
+	# Can't use [memtest]; must be careful when we change stack frames
+	set end [meminfo]
+	for {set i 0} {$i < 5} {incr i} {
+	    unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+		puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]]
+	    }]
+	    set tmp $end
+	    set end [meminfo]
+	}
+	expr {$end - $tmp}
+    }}
+} 0
+test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount} memory {
+    apply {{} {
+	set l [lrepeat 50 p q r]
+	# Can't use [memtest]; must be careful when we change stack frames
+	set end [meminfo]
+	for {set i 0} {$i < 5} {incr i} {
+	    unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+		puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]]
+	    }]
+	    set tmp $end
+	    set end [meminfo]
+	}
+	expr {$end - $tmp}
+    }}
+} 0
 
 # cleanup
 ::tcltest::cleanupTests