From b3b9cb8d35e3aecf7c1121fef25a76d592102eab Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 28 May 2013 14:04:02 +0000
Subject: Missed bits of dup code elimination.

---
 generic/tclAssembly.c | 23 -----------------------
 1 file changed, 23 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index fff7b43..a84467f 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -324,29 +324,6 @@ static const Tcl_ObjType assembleCodeType = {
 };
 
 /*
- * TIP #280: Remember the per-word line information of the current command. An
- * index is used instead of a pointer as recursive compilation may reallocate,
- * i.e. move, the array. This is also the reason to save the nuloc now, it may
- * change during the course of the function.
- *
- * Macro to encapsulate the variable definition and setup.
- */
-
-#define DefineLineInformation \
-    ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr;				\
-    int eclIndex = mapPtr->nuloc - 1
-
-#define SetLineInformation(word) \
-    envPtr->line = mapPtr->loc[eclIndex].line[(word)];			\
-    envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
-
-/*
- * Flags bits used by PushVarName.
- */
-
-#define TCL_NO_LARGE_INDEX 1	/* Do not return localIndex value > 255 */
-
-/*
  * Source instructions recognized in the Tcl Assembly Language (TAL)
  */
 
-- 
cgit v0.12


From fb728f1f539e25112b06a14ba6382e001f36e21c Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 28 May 2013 14:29:01 +0000
Subject: Plug the memory leak.  Greater ambitions to improve this routine are
 proving more difficult than expected.

---
 generic/tclCompCmds.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 8c88649..a325954 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -285,6 +285,7 @@ TclCompileArraySetCmd(
     PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
 	    &localIndex, &simpleVarName, &isScalar, 1);
     if (!isScalar) {
+	Tcl_DecrRefCount(literalObj);
 	return TCL_ERROR;
     }
     /*
-- 
cgit v0.12


From b1a3a83b3d7b4e494dbb3b893b6ca7e4398e8800 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 28 May 2013 19:21:22 +0000
Subject: Use the routines that provide "basic compile" instead of reinventing
 them.

---
 generic/tclCompCmds.c | 50 ++++++++++++++++----------------------------------
 1 file changed, 16 insertions(+), 34 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index a325954..a966715 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -251,7 +251,7 @@ TclCompileArraySetCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *varTokenPtr, *dataTokenPtr;
-    int simpleVarName, isScalar, localIndex;
+    int simpleVarName, isScalar, localIndex, code = TCL_OK;
     int isDataLiteral, isDataValid, isDataEven, len;
     int dataVar, iterVar, keyVar, valVar, infoIndex;
     int back, fwd, offsetBack, offsetFwd, savedStackDepth;
@@ -282,11 +282,21 @@ TclCompileArraySetCmd(
 	goto done;
     }
 
+    /*
+     * Except for the special "ensure array" case below, when we're not in
+     * a proc, we cannot do a better compile than generic.
+     */
+
+    if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) {
+	code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+	goto done;
+    }
+
     PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
 	    &localIndex, &simpleVarName, &isScalar, 1);
     if (!isScalar) {
-	Tcl_DecrRefCount(literalObj);
-	return TCL_ERROR;
+	code = TCL_ERROR;
+	goto done;
     }
     /*
      * Special case: literal empty value argument is just an "ensure array"
@@ -302,10 +312,10 @@ TclCompileArraySetCmd(
 	    TclEmitOpcode(  INST_DUP,				envPtr);
 	    TclEmitOpcode(  INST_ARRAY_EXISTS_STK,		envPtr);
 	    TclEmitInstInt1(INST_JUMP_TRUE1, 5,			envPtr);
-	    savedStackDepth = envPtr->currStackDepth;
 	    TclEmitOpcode(  INST_ARRAY_MAKE_STK,		envPtr);
 	    TclEmitInstInt1(INST_JUMP1, 3,			envPtr);
-	    envPtr->currStackDepth = savedStackDepth;
+	    /* Each branch decrements stack depth, but we only take one. */
+	    TclAdjustStackDepth(1, envPtr);
 	    TclEmitOpcode(  INST_POP,				envPtr);
 	}
 	PushStringLiteral(envPtr, "");
@@ -321,32 +331,6 @@ TclCompileArraySetCmd(
     keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
     valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
 
-    if (dataVar < 0) {
-	/*
-	 * Right number of arguments, but not compilable as we can't allocate
-	 * (unnamed) local variables to manage the internal iteration.
-	 */
-
-	Tcl_Obj *objPtr = Tcl_NewObj();
-	char *bytes;
-	int length, cmdLit;
-
-	Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
-	bytes = Tcl_GetStringFromObj(objPtr, &length);
-	cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
-	TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
-	TclEmitPush(cmdLit, envPtr);
-	TclDecrRefCount(objPtr);
-	if (localIndex >= 0) {
-	    CompileWord(envPtr, varTokenPtr, interp, 1);
-	} else {
-	    TclEmitInstInt4(INST_REVERSE, 2,			envPtr);
-	}
-	CompileWord(envPtr, dataTokenPtr, interp, 2);
-	TclEmitInstInt1(INST_INVOKE_STK1, 3,			envPtr);
-	goto done;
-    }
-
     infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
     infoPtr->numLists = 1;
     infoPtr->firstValueTemp = dataVar;
@@ -418,7 +402,6 @@ TclCompileArraySetCmd(
 	TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex,		envPtr);
 	offsetFwd = CurrentOffset(envPtr);
 	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
-	savedStackDepth = envPtr->currStackDepth;
 	TclEmitOpcode(	INST_DUP,				envPtr);
 	Emit14Inst(	INST_LOAD_SCALAR, keyVar,		envPtr);
 	Emit14Inst(	INST_LOAD_SCALAR, valVar,		envPtr);
@@ -428,7 +411,6 @@ TclCompileArraySetCmd(
 	TclEmitInstInt1(INST_JUMP1, back,			envPtr);
 	fwd = CurrentOffset(envPtr) - offsetFwd;
 	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
-	envPtr->currStackDepth = savedStackDepth;
 	TclEmitOpcode(	INST_POP,				envPtr);
     }
     if (!isDataLiteral) {
@@ -438,7 +420,7 @@ TclCompileArraySetCmd(
     PushStringLiteral(envPtr,	"");
   done:
     Tcl_DecrRefCount(literalObj);
-    return TCL_OK;
+    return code;
 }
 
 int
-- 
cgit v0.12


From c929650e2f079e196a96f2984cd24820bcc56d3e Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 29 May 2013 14:37:58 +0000
Subject: Stop emitting the instructions INST_*_SCALAR_STK*.  They are
 identical to their INST_*_STK* counterparts. Having done that, it is clear
 the "simpleVarName" return from TclPushVarName provides nothing of use to any
 of its callers.  Eliminate that.  Also make TPVN return void, instead of int.
 Bring the TPVN header comments up to date; they were quite rotten.

---
 generic/tclAssembly.c   |  9 +++---
 generic/tclCompCmds.c   | 45 +++++++++++++++--------------
 generic/tclCompCmdsGR.c | 77 ++++++++++++++++++-------------------------------
 generic/tclCompCmdsSZ.c | 19 ++++--------
 generic/tclCompile.c    |  2 +-
 generic/tclCompile.h    |  9 +++---
 6 files changed, 67 insertions(+), 94 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index a84467f..0fe50b3a 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -387,9 +387,8 @@ static const TalInstDesc TalInstructionTable[] = {
     {"incrArrayStkImm", ASSEM_SINT1,	INST_INCR_ARRAY_STK_IMM,2,	1},
     {"incrImm",		ASSEM_LVT1_SINT1,
 					INST_INCR_SCALAR1_IMM,	0,	1},
-    {"incrStk",		ASSEM_1BYTE,	INST_INCR_SCALAR_STK,	2,	1},
-    {"incrStkImm",	ASSEM_SINT1,	INST_INCR_SCALAR_STK_IMM,
-								1,	1},
+    {"incrStk",		ASSEM_1BYTE,	INST_INCR_STK,		2,	1},
+    {"incrStkImm",	ASSEM_SINT1,	INST_INCR_STK_IMM,	1,	1},
     {"infoLevelArgs",	ASSEM_1BYTE,	INST_INFO_LEVEL_ARGS,	1,	1},
     {"infoLevelNumber",	ASSEM_1BYTE,	INST_INFO_LEVEL_NUM,	0,	1},
     {"invokeStk",	ASSEM_INVOKE,	(INST_INVOKE_STK1 << 8
@@ -425,7 +424,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"loadArray",	ASSEM_LVT,	(INST_LOAD_ARRAY1<<8
 					 | INST_LOAD_ARRAY4),	1,	1},
     {"loadArrayStk",	ASSEM_1BYTE,	INST_LOAD_ARRAY_STK,	2,	1},
-    {"loadStk",		ASSEM_1BYTE,	INST_LOAD_SCALAR_STK,	1,	1},
+    {"loadStk",		ASSEM_1BYTE,	INST_LOAD_STK,		1,	1},
     {"lor",		ASSEM_1BYTE,	INST_LOR,		2,	1},
     {"lsetFlat",	ASSEM_LSET_FLAT,INST_LSET_FLAT,		INT_MIN,1},
     {"lsetList",	ASSEM_1BYTE,	INST_LSET_LIST,		3,	1},
@@ -452,7 +451,7 @@ static const TalInstDesc TalInstructionTable[] = {
     {"storeArray",	ASSEM_LVT,	(INST_STORE_ARRAY1<<8
 					 | INST_STORE_ARRAY4),	2,	1},
     {"storeArrayStk",	ASSEM_1BYTE,	INST_STORE_ARRAY_STK,	3,	1},
-    {"storeStk",	ASSEM_1BYTE,	INST_STORE_SCALAR_STK,	2,	1},
+    {"storeStk",	ASSEM_1BYTE,	INST_STORE_STK,		2,	1},
     {"strcmp",		ASSEM_1BYTE,	INST_STR_CMP,		2,	1},
     {"streq",		ASSEM_1BYTE,	INST_STR_EQ,		2,	1},
     {"strfind",		ASSEM_1BYTE,	INST_STR_FIND,		2,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index a966715..53b7b32 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -84,7 +84,7 @@ TclCompileAppendCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *varTokenPtr, *valueTokenPtr;
-    int simpleVarName, isScalar, localIndex, numWords, i;
+    int isScalar, localIndex, numWords, i;
     DefineLineInformation;	/* TIP #280 */
 
     numWords = parsePtr->numWords;
@@ -116,7 +116,7 @@ TclCompileAppendCmd(
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
 
     PushVarNameWord(interp, varTokenPtr, envPtr, 0,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
 
     /*
      * We are doing an assignment, otherwise TclCompileSetCmd was called, so
@@ -133,7 +133,6 @@ TclCompileAppendCmd(
      * Emit instructions to set/get the variable.
      */
 
-    if (simpleVarName) {
 	if (isScalar) {
 	    if (localIndex < 0) {
 		TclEmitOpcode(INST_APPEND_STK, envPtr);
@@ -147,9 +146,6 @@ TclCompileAppendCmd(
 		Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr);
 	    }
 	}
-    } else {
-	TclEmitOpcode(INST_APPEND_STK, envPtr);
-    }
 
     return TCL_OK;
 
@@ -164,7 +160,7 @@ TclCompileAppendCmd(
     }
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
     PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
     if (!isScalar || localIndex < 0) {
 	return TCL_ERROR;
     }
@@ -219,7 +215,7 @@ TclCompileArrayExistsCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *tokenPtr;
-    int simpleVarName, isScalar, localIndex;
+    int isScalar, localIndex;
 
     if (parsePtr->numWords != 2) {
 	return TCL_ERROR;
@@ -227,7 +223,7 @@ TclCompileArrayExistsCmd(
 
     tokenPtr = TokenAfter(parsePtr->tokenPtr);
     PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
     if (!isScalar) {
 	return TCL_ERROR;
     }
@@ -251,7 +247,7 @@ TclCompileArraySetCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *varTokenPtr, *dataTokenPtr;
-    int simpleVarName, isScalar, localIndex, code = TCL_OK;
+    int isScalar, localIndex, code = TCL_OK;
     int isDataLiteral, isDataValid, isDataEven, len;
     int dataVar, iterVar, keyVar, valVar, infoIndex;
     int back, fwd, offsetBack, offsetFwd, savedStackDepth;
@@ -293,7 +289,7 @@ TclCompileArraySetCmd(
     }
 
     PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
     if (!isScalar) {
 	code = TCL_ERROR;
 	goto done;
@@ -434,14 +430,14 @@ TclCompileArrayUnsetCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-    int simpleVarName, isScalar, localIndex, savedStackDepth;
+    int isScalar, localIndex, savedStackDepth;
 
     if (parsePtr->numWords != 2) {
 	return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
     }
 
     PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
     if (!isScalar) {
 	return TCL_ERROR;
     }
@@ -3246,24 +3242,33 @@ TclCompileFormatCmd(
  *	necessary (append, lappend, set).
  *
  * Results:
- *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- *	evaluation to runtime.
+ *	The values written to *localIndexPtr and *isScalarPtr signal to
+ *	the caller what the instructions emitted by this routine will do:
+ *
+ *	*isScalarPtr	(*localIndexPtr < 0)
+ *	1		1	Push the varname on the stack. (Stack +1)
+ *	1		0	*localIndexPtr is the index of the compiled
+ *				local for this varname.  No instructions
+ *				emitted.	(Stack +0)
+ *	0		1	Push part1 and part2 names of array element
+ *				on the stack.	(Stack +2)
+ *	0		0	*localIndexPtr is the index of the compiled
+ *				local for this array.  Element name is pushed
+ *				on the stack.	(Stack +1)
  *
  * Side effects:
- *	Instructions are added to envPtr to execute the "set" command at
- *	runtime.
+ *	Instructions are added to envPtr.
  *
  *----------------------------------------------------------------------
  */
 
-int
+void
 TclPushVarName(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Token *varTokenPtr,	/* Points to a variable token. */
     CompileEnv *envPtr,		/* Holds resulting instructions. */
     int flags,			/* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
     int *localIndexPtr,		/* Must not be NULL. */
-    int *simpleVarNamePtr,	/* Must not be NULL. */
     int *isScalarPtr,		/* Must not be NULL. */
     int line,			/* Line the token starts on. */
     int *clNext)		/* Reference to offset of next hidden cont.
@@ -3473,9 +3478,7 @@ TclPushVarName(
 	TclStackFree(interp, elemTokenPtr);
     }
     *localIndexPtr = localIndex;
-    *simpleVarNamePtr = simpleVarName;
     *isScalarPtr = (elName == NULL);
-    return TCL_OK;
 }
 
 /*
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index c6a01e7..d101d82 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -450,7 +450,7 @@ TclCompileIncrCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *varTokenPtr, *incrTokenPtr;
-    int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
+    int isScalar, localIndex, haveImmValue, immValue;
     DefineLineInformation;	/* TIP #280 */
 
     if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
@@ -460,7 +460,7 @@ TclCompileIncrCmd(
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
 
     PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
 
     /*
      * If an increment is given, push it, but see first if it's a small
@@ -498,13 +498,7 @@ TclCompileIncrCmd(
      * Emit the instruction to increment the variable.
      */
 
-    if (!simpleVarName) {
-	if (haveImmValue) {
-	    TclEmitInstInt1(	INST_INCR_STK_IMM, immValue,	envPtr);
-	} else {
-	    TclEmitOpcode(	INST_INCR_STK,			envPtr);
-	}
-    } else if (isScalar) {	/* Simple scalar variable. */
+    if (isScalar) {	/* Simple scalar variable. */
 	if (localIndex >= 0) {
 	    if (haveImmValue) {
 		TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
@@ -514,9 +508,9 @@ TclCompileIncrCmd(
 	    }
 	} else {
 	    if (haveImmValue) {
-		TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
+		TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
 	    } else {
-		TclEmitOpcode(	INST_INCR_SCALAR_STK,		envPtr);
+		TclEmitOpcode(	INST_INCR_STK,		envPtr);
 	    }
 	}
     } else {			/* Simple array variable. */
@@ -652,7 +646,7 @@ TclCompileInfoExistsCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *tokenPtr;
-    int isScalar, simpleVarName, localIndex;
+    int isScalar, localIndex;
     DefineLineInformation;	/* TIP #280 */
 
     if (parsePtr->numWords != 2) {
@@ -668,16 +662,13 @@ TclCompileInfoExistsCmd(
      */
 
     tokenPtr = TokenAfter(parsePtr->tokenPtr);
-    PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
-	    &simpleVarName, &isScalar, 1);
+    PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1);
 
     /*
      * Emit instruction to check the variable for existence.
      */
 
-    if (!simpleVarName) {
-	TclEmitOpcode(		INST_EXIST_STK,			envPtr);
-    } else if (isScalar) {
+    if (isScalar) {
 	if (localIndex < 0) {
 	    TclEmitOpcode(	INST_EXIST_STK,			envPtr);
 	} else {
@@ -834,7 +825,7 @@ TclCompileLappendCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *varTokenPtr, *valueTokenPtr;
-    int simpleVarName, isScalar, localIndex, numWords, i, fwd, offsetFwd;
+    int isScalar, localIndex, numWords, i, fwd, offsetFwd;
     DefineLineInformation;	/* TIP #280 */
 
     /*
@@ -869,7 +860,7 @@ TclCompileLappendCmd(
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
 
     PushVarNameWord(interp, varTokenPtr, envPtr, 0,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
 
     /*
      * If we are doing an assignment, push the new value. In the no values
@@ -891,9 +882,7 @@ TclCompileLappendCmd(
      * LOAD/STORE instructions.
      */
 
-    if (!simpleVarName) {
-	TclEmitOpcode(		INST_LAPPEND_STK,		envPtr);
-    } else if (isScalar) {
+    if (isScalar) {
 	if (localIndex < 0) {
 	    TclEmitOpcode(	INST_LAPPEND_STK,		envPtr);
 	} else {
@@ -920,7 +909,7 @@ TclCompileLappendCmd(
     }
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
     PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
     if (!isScalar || localIndex < 0) {
 	return TCL_ERROR;
     }
@@ -977,7 +966,7 @@ TclCompileLassignCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *tokenPtr;
-    int simpleVarName, isScalar, localIndex, numWords, idx;
+    int isScalar, localIndex, numWords, idx;
     DefineLineInformation;	/* TIP #280 */
 
     numWords = parsePtr->numWords;
@@ -1009,19 +998,14 @@ TclCompileLassignCmd(
 	 */
 
 	PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
-		&simpleVarName, &isScalar, idx+2);
+		&isScalar, idx+2);
 
 	/*
 	 * Emit instructions to get the idx'th item out of the list value on
 	 * the stack and assign it to the variable.
 	 */
 
-	if (!simpleVarName) {
-	    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
-	    TclEmitInstInt4(	INST_LIST_INDEX_IMM, idx,	envPtr);
-	    TclEmitOpcode(	INST_STORE_STK,			envPtr);
-	    TclEmitOpcode(	INST_POP,			envPtr);
-	} else if (isScalar) {
+	if (isScalar) {
 	    if (localIndex >= 0) {
 		TclEmitOpcode(	INST_DUP,			envPtr);
 		TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,	envPtr);
@@ -1030,7 +1014,7 @@ TclCompileLassignCmd(
 	    } else {
 		TclEmitInstInt4(INST_OVER, 1,			envPtr);
 		TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,	envPtr);
-		TclEmitOpcode(	INST_STORE_SCALAR_STK,		envPtr);
+		TclEmitOpcode(	INST_STORE_STK,			envPtr);
 		TclEmitOpcode(	INST_POP,			envPtr);
 	    }
 	} else {
@@ -1607,7 +1591,6 @@ TclCompileLsetCmd(
     Tcl_Token *varTokenPtr;	/* Pointer to the Tcl_Token representing the
 				 * parse of the variable name. */
     int localIndex;		/* Index of var in local var table. */
-    int simpleVarName;		/* Flag == 1 if var name is simple. */
     int isScalar;		/* Flag == 1 if scalar, 0 if array. */
     int i;
     DefineLineInformation;	/* TIP #280 */
@@ -1634,7 +1617,7 @@ TclCompileLsetCmd(
 
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
     PushVarNameWord(interp, varTokenPtr, envPtr, 0,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
 
     /*
      * Push the "index" args and the new element value.
@@ -1649,8 +1632,8 @@ TclCompileLsetCmd(
      * Duplicate the variable name if it's been pushed.
      */
 
-    if (!simpleVarName || localIndex < 0) {
-	if (!simpleVarName || isScalar) {
+    if (localIndex < 0) {
+	if (isScalar) {
 	    tempDepth = parsePtr->numWords - 2;
 	} else {
 	    tempDepth = parsePtr->numWords - 1;
@@ -1662,7 +1645,7 @@ TclCompileLsetCmd(
      * Duplicate an array index if one's been pushed.
      */
 
-    if (simpleVarName && !isScalar) {
+    if (!isScalar) {
 	if (localIndex < 0) {
 	    tempDepth = parsePtr->numWords - 1;
 	} else {
@@ -1675,11 +1658,9 @@ TclCompileLsetCmd(
      * Emit code to load the variable's value.
      */
 
-    if (!simpleVarName) {
-	TclEmitOpcode(		INST_LOAD_STK,			envPtr);
-    } else if (isScalar) {
+    if (isScalar) {
 	if (localIndex < 0) {
-	    TclEmitOpcode(	INST_LOAD_SCALAR_STK,		envPtr);
+	    TclEmitOpcode(	INST_LOAD_STK,			envPtr);
 	} else {
 	    Emit14Inst(		INST_LOAD_SCALAR, localIndex,	envPtr);
 	}
@@ -1705,11 +1686,9 @@ TclCompileLsetCmd(
      * Emit code to put the value back in the variable.
      */
 
-    if (!simpleVarName) {
-	TclEmitOpcode(		INST_STORE_STK,			envPtr);
-    } else if (isScalar) {
+    if (isScalar) {
 	if (localIndex < 0) {
-	    TclEmitOpcode(	INST_STORE_SCALAR_STK,		envPtr);
+	    TclEmitOpcode(	INST_STORE_STK,			envPtr);
 	} else {
 	    Emit14Inst(		INST_STORE_SCALAR, localIndex,	envPtr);
 	}
@@ -1902,7 +1881,7 @@ TclCompileNamespaceUpvarCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
-    int simpleVarName, isScalar, localIndex, numWords, i;
+    int isScalar, localIndex, numWords, i;
     DefineLineInformation;	/* TIP #280 */
 
     if (envPtr->procPtr == NULL) {
@@ -1938,7 +1917,7 @@ TclCompileNamespaceUpvarCmd(
 
 	CompileWord(envPtr, otherTokenPtr, interp, 1);
 	PushVarNameWord(interp, localTokenPtr, envPtr, 0,
-		&localIndex, &simpleVarName, &isScalar, 1);
+		&localIndex, &isScalar, 1);
 
 	if ((localIndex < 0) || !isScalar) {
 	    return TCL_ERROR;
@@ -2597,7 +2576,7 @@ TclCompileUpvarCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
-    int simpleVarName, isScalar, localIndex, numWords, i;
+    int isScalar, localIndex, numWords, i;
     DefineLineInformation;	/* TIP #280 */
     Tcl_Obj *objPtr = Tcl_NewObj();
 
@@ -2661,7 +2640,7 @@ TclCompileUpvarCmd(
 
 	CompileWord(envPtr, otherTokenPtr, interp, 1);
 	PushVarNameWord(interp, localTokenPtr, envPtr, 0,
-		&localIndex, &simpleVarName, &isScalar, 1);
+		&localIndex, &isScalar, 1);
 
 	if ((localIndex < 0) || !isScalar) {
 	    return TCL_ERROR;
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index f2017f0..3fb8712 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -126,7 +126,7 @@ TclCompileSetCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *varTokenPtr, *valueTokenPtr;
-    int isAssignment, isScalar, simpleVarName, localIndex, numWords;
+    int isAssignment, isScalar, localIndex, numWords;
     DefineLineInformation;	/* TIP #280 */
 
     numWords = parsePtr->numWords;
@@ -145,7 +145,7 @@ TclCompileSetCmd(
 
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
     PushVarNameWord(interp, varTokenPtr, envPtr, 0,
-	    &localIndex, &simpleVarName, &isScalar, 1);
+	    &localIndex, &isScalar, 1);
 
     /*
      * If we are doing an assignment, push the new value.
@@ -160,12 +160,10 @@ TclCompileSetCmd(
      * Emit instructions to set/get the variable.
      */
 
-    if (simpleVarName) {
 	if (isScalar) {
 	    if (localIndex < 0) {
 		TclEmitOpcode((isAssignment?
-			INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
-			envPtr);
+			INST_STORE_STK : INST_LOAD_STK), envPtr);
 	    } else if (localIndex <= 255) {
 		TclEmitInstInt1((isAssignment?
 			INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
@@ -189,9 +187,6 @@ TclCompileSetCmd(
 			localIndex, envPtr);
 	    }
 	}
-    } else {
-	TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
-    }
 
     return TCL_OK;
 }
@@ -2683,7 +2678,7 @@ TclCompileUnsetCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *varTokenPtr;
-    int isScalar, simpleVarName, localIndex, numWords, flags, i;
+    int isScalar, localIndex, numWords, flags, i;
     Tcl_Obj *leadingWord;
     DefineLineInformation;	/* TIP #280 */
 
@@ -2724,15 +2719,13 @@ TclCompileUnsetCmd(
 	 */
 
 	PushVarNameWord(interp, varTokenPtr, envPtr, 0,
-		&localIndex, &simpleVarName, &isScalar, 1);
+		&localIndex, &isScalar, 1);
 
 	/*
 	 * Emit instructions to unset the variable.
 	 */
 
-	if (!simpleVarName) {
-	    OP1(	UNSET_STK, flags);
-	} else if (isScalar) {
+	if (isScalar) {
 	    if (localIndex < 0) {
 		OP1(	UNSET_STK, flags);
 	    } else {
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 87e620c..dd179ea 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2376,7 +2376,7 @@ TclCompileVarSubst(
 
     if (tokenPtr->numComponents == 1) {
 	if (localVar < 0) {
-	    TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+	    TclEmitOpcode(INST_LOAD_STK, envPtr);
 	} else if (localVar <= 255) {
 	    TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
 	} else {
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 3909fa9..0be5d1d 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -998,11 +998,10 @@ MODULE_SCOPE void	TclPrintObject(FILE *outFile,
 			    Tcl_Obj *objPtr, int maxChars);
 MODULE_SCOPE void	TclPrintSource(FILE *outFile,
 			    const char *string, int maxChars);
-MODULE_SCOPE int	TclPushVarName(Tcl_Interp *interp,
+MODULE_SCOPE void	TclPushVarName(Tcl_Interp *interp,
 			    Tcl_Token *varTokenPtr, CompileEnv *envPtr,
 			    int flags, int *localIndexPtr,
-			    int *simpleVarNamePtr, int *isScalarPtr,
-			    int line, int *clNext);
+			    int *isScalarPtr, int line, int *clNext);
 MODULE_SCOPE int	TclRegisterLiteral(CompileEnv *envPtr,
 			    char *bytes, int length, int flags);
 MODULE_SCOPE void	TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -1472,8 +1471,8 @@ MODULE_SCOPE Tcl_Obj	*TclNewInstNameObj(unsigned char inst);
     envPtr->line = mapPtr->loc[eclIndex].line[(word)];			\
     envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
 
-#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
-    TclPushVarName(i,v,e,f,l,s,sc,						\
+#define PushVarNameWord(i,v,e,f,l,sc,word) \
+    TclPushVarName(i,v,e,f,l,sc,						\
 	    mapPtr->loc[eclIndex].line[(word)],				\
 	    mapPtr->loc[eclIndex].next[(word)])
 
-- 
cgit v0.12


From 2a26edf602ceae0ddf8b308e3915c78e38b977f4 Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Wed, 29 May 2013 16:24:34 +0000
Subject: Fix C99 comment-ism breaking the native AIX compiler. HPUX likely as
 well.

---
 generic/tclIO.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclIO.c b/generic/tclIO.c
index 1b301e2..f1d8909 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -6738,8 +6738,8 @@ Tcl_Tell(
     outputBuffered = Tcl_OutputBuffered(chan);
 
     if ((inputBuffered != 0) && (outputBuffered != 0)) {
-	//Tcl_SetErrno(EFAULT);
-	//return Tcl_LongAsWide(-1);
+	/*Tcl_SetErrno(EFAULT);*/
+	/*return Tcl_LongAsWide(-1);*/
     }
 
     /*
-- 
cgit v0.12


From e7da373e0c6ede5c428aba9f55cd0ecc9317f5ec Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 29 May 2013 17:20:29 +0000
Subject: 3614102 - Reset stack housekeeping when compileProc fails.

---
 generic/tclCompile.c | 8 ++++++--
 tests/compile.test   | 6 ++++++
 2 files changed, 12 insertions(+), 2 deletions(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index dd179ea..039a694 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2069,9 +2069,7 @@ TclCompileScript(
 			unsigned savedCodeNext =
 				envPtr->codeNext - envPtr->codeStart;
 			int update = 0;
-#ifdef TCL_COMPILE_DEBUG
 			int startStackDepth = envPtr->currStackDepth;
-#endif
 
 			/*
 			 * Mark the start of the command; the proper bytecode
@@ -2164,6 +2162,12 @@ TclCompileScript(
 
 			envPtr->numCommands = savedNumCmds;
 			envPtr->codeNext = envPtr->codeStart + savedCodeNext;
+
+			/*
+			 * And the stack depth too!!  [Bug 3614102].
+			 */
+
+			envPtr->currStackDepth = startStackDepth;
 		    }
 
 		    /*
diff --git a/tests/compile.test b/tests/compile.test
index 4d91940..51db0a2 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -707,6 +707,12 @@ test compile-18.19 {disassembler - basics} -setup {
 } -cleanup {
     foo destroy
 } -match glob -result *
+
+test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
+    # This will panic in a --enable-symbols=compile build, unless bug is fixed.
+    apply {{} {list [if 1]}}
+} -returnCodes error -match glob -result *
+
 # TODO sometime - check that bytecode from tbcload is *not* disassembled.
 
 # cleanup
-- 
cgit v0.12


From 82c027f092937aee7ba474c52faf0d727a7da8a0 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 29 May 2013 20:36:05 +0000
Subject: Simplifications and tidying up of stack management issues.  Work in
 progress.

---
 generic/tclCompCmds.c | 27 +++++++++++++--------------
 1 file changed, 13 insertions(+), 14 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 53b7b32..7046e54 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -124,10 +124,8 @@ TclCompileAppendCmd(
      * each argument.
      */
 
-    if (numWords > 2) {
 	valueTokenPtr = TokenAfter(varTokenPtr);
 	CompileWord(envPtr, valueTokenPtr, interp, 2);
-    }
 
     /*
      * Emit instructions to set/get the variable.
@@ -155,9 +153,6 @@ TclCompileAppendCmd(
      * there are multiple values to append.  Fortunately, this is common.
      */
 
-    if (envPtr->procPtr == NULL) {
-	return TCL_ERROR;
-    }
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
     PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
 	    &localIndex, &isScalar, 1);
@@ -250,7 +245,7 @@ TclCompileArraySetCmd(
     int isScalar, localIndex, code = TCL_OK;
     int isDataLiteral, isDataValid, isDataEven, len;
     int dataVar, iterVar, keyVar, valVar, infoIndex;
-    int back, fwd, offsetBack, offsetFwd, savedStackDepth;
+    int back, fwd, offsetBack, offsetFwd;
     Tcl_Obj *literalObj;
     ForeachInfo *infoPtr;
 
@@ -356,12 +351,11 @@ TclCompileArraySetCmd(
 	TclEmitOpcode(	INST_BITAND,				envPtr);
 	offsetFwd = CurrentOffset(envPtr);
 	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
-	savedStackDepth = envPtr->currStackDepth;
 	PushStringLiteral(envPtr, "list must have an even number of elements");
 	PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
 	TclEmitInstInt4(INST_RETURN_IMM, 1,			envPtr);
 	TclEmitInt4(		0,				envPtr);
-	envPtr->currStackDepth = savedStackDepth;
+	TclAdjustStackDepth(-1, envPtr);
 	fwd = CurrentOffset(envPtr) - offsetFwd;
 	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
     }
@@ -377,7 +371,6 @@ TclCompileArraySetCmd(
 	TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex,		envPtr);
 	offsetFwd = CurrentOffset(envPtr);
 	TclEmitInstInt1(INST_JUMP_FALSE1, 0,			envPtr);
-	savedStackDepth = envPtr->currStackDepth;
 	Emit14Inst(	INST_LOAD_SCALAR, keyVar,		envPtr);
 	Emit14Inst(	INST_LOAD_SCALAR, valVar,		envPtr);
 	Emit14Inst(	INST_STORE_ARRAY, localIndex,		envPtr);
@@ -386,7 +379,6 @@ TclCompileArraySetCmd(
 	TclEmitInstInt1(INST_JUMP1, back,			envPtr);
 	fwd = CurrentOffset(envPtr) - offsetFwd;
 	TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
-	envPtr->currStackDepth = savedStackDepth;
     } else {
 	TclEmitOpcode(	INST_DUP,				envPtr);
 	TclEmitOpcode(	INST_ARRAY_EXISTS_STK,			envPtr);
@@ -430,7 +422,7 @@ TclCompileArrayUnsetCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-    int isScalar, localIndex, savedStackDepth;
+    int isScalar, localIndex;
 
     if (parsePtr->numWords != 2) {
 	return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
@@ -451,10 +443,10 @@ TclCompileArrayUnsetCmd(
 	TclEmitOpcode(	INST_DUP,				envPtr);
 	TclEmitOpcode(	INST_ARRAY_EXISTS_STK,			envPtr);
 	TclEmitInstInt1(INST_JUMP_FALSE1, 6,			envPtr);
-	savedStackDepth = envPtr->currStackDepth;
 	TclEmitInstInt1(INST_UNSET_STK, 1,			envPtr);
 	TclEmitInstInt1(INST_JUMP1, 3,				envPtr);
-	envPtr->currStackDepth = savedStackDepth;
+	/* Each branch decrements stack depth, but we only take one. */
+	TclAdjustStackDepth(1, envPtr);
 	TclEmitOpcode(	INST_POP,				envPtr);
     }
     PushStringLiteral(envPtr,	"");
@@ -497,7 +489,14 @@ TclCompileBreakCmd(
      */
 
     TclEmitOpcode(INST_BREAK, envPtr);
-    PushStringLiteral(envPtr, "");	/* Evil hack! */
+#ifdef TCL_COMPILE_DEBUG
+    /*
+     * Instructions that raise exceptions don't really have to follow
+     * the usual stack management rules.  But the checker wants them
+     * followed, so lie about stack usage to make it happy.
+     */
+    TclAdjustStackDepth(1, envPtr);
+#endif
     return TCL_OK;
 }
 
-- 
cgit v0.12


From db5a66dd2c12c66e83843f772ef35bba03514696 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 30 May 2013 10:29:41 +0000
Subject: Corrected code generation when doing the second run with an
 'infinite' loop.

---
 generic/tclCompCmdsSZ.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 3fb8712..ed4d962 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -2859,7 +2859,7 @@ TclCompileWhileCmd(
 	 * INST_START_CMD, and hence counted properly. [Bug 1752146]
 	 */
 
-	envPtr->atCmdStart = 0;
+	envPtr->atCmdStart &= ~1;
 	testCodeOffset = CurrentOffset(envPtr);
     }
 
-- 
cgit v0.12


From 90dba8327c15efdcf5eacc00f89ce8b9b100e5ba Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 30 May 2013 10:55:39 +0000
Subject: Working towards the next batch of optimizations.

---
 generic/tclCompCmds.c   | 81 +++++++++++++++++++++++++++++++++++++++++
 generic/tclCompCmdsSZ.c |  4 +++
 generic/tclCompile.c    | 96 +++++++++++++++++++++++++++++++++++++++----------
 generic/tclCompile.h    |  6 ++++
 4 files changed, 168 insertions(+), 19 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 7046e54..1f99a22 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -480,11 +480,45 @@ TclCompileBreakCmd(
 				 * compiled. */
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
+    int i, exnIdx;
+    ExceptionRange *rangePtr;
+
     if (parsePtr->numWords != 1) {
 	return TCL_ERROR;
     }
 
     /*
+     * Find the innermost exception range that contains this command. Relies
+     * on the fact that the range has a numCodeBytes = -1 when it is being
+     * populated and that inner ranges come after outer ranges.
+     */
+
+    exnIdx = -1;
+    for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+	rangePtr = &envPtr->exceptArrayPtr[i];
+	if (envPtr->codeStart+rangePtr->codeOffset <= envPtr->codeNext
+		&& rangePtr->numCodeBytes == -1) {
+	    exnIdx = i;
+	}
+    }
+    if (exnIdx != -1) {
+	rangePtr = &envPtr->exceptArrayPtr[exnIdx];
+	if (rangePtr->type == LOOP_EXCEPTION_RANGE) {
+	    int toPop = envPtr->currStackDepth -
+		    envPtr->exnStackDepthArrayPtr[exnIdx];
+
+	    /*
+	     * Pop off the extra stack frames.
+	     */
+
+	    while (toPop > 0) {
+		TclEmitOpcode(INST_POP, envPtr);
+		toPop--;
+	    }
+	}
+    }
+
+    /*
      * Emit a break instruction.
      */
 
@@ -790,6 +824,9 @@ TclCompileContinueCmd(
 				 * compiled. */
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
+    int i, exnIdx;
+    ExceptionRange *rangePtr;
+
     /*
      * There should be no argument after the "continue".
      */
@@ -799,6 +836,50 @@ TclCompileContinueCmd(
     }
 
     /*
+     * See if we can find a valid continueOffset (i.e., not -1) in the
+     * innermost containing exception range. Relies on the fact that the range
+     * has a numCodeBytes = -1 when it is being populated and that inner
+     * ranges come after outer ranges.
+     */
+
+    exnIdx = -1;
+    for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+	rangePtr = &envPtr->exceptArrayPtr[i];
+	if (envPtr->codeStart+rangePtr->codeOffset <= envPtr->codeNext
+		&& rangePtr->numCodeBytes == -1) {
+	    exnIdx = i;
+	}
+    }
+    if (exnIdx >= 0) {
+	rangePtr = &envPtr->exceptArrayPtr[exnIdx];
+	if (rangePtr->type == LOOP_EXCEPTION_RANGE) {
+	    int toPop = envPtr->currStackDepth -
+		    envPtr->exnStackDepthArrayPtr[exnIdx];
+
+	    /*
+	     * Pop off the extra stack frames.
+	     */
+
+	    while (toPop > 0) {
+		TclEmitOpcode(INST_POP, envPtr);
+		toPop--;
+	    }
+	}
+	if (rangePtr->type == LOOP_EXCEPTION_RANGE
+		&& rangePtr->continueOffset != -1) {
+	    int offset = (rangePtr->continueOffset - CurrentOffset(envPtr));
+
+	    /*
+	     * Found the target! No need for a nasty INST_CONTINUE here.
+	     */
+
+	    TclEmitInstInt4(INST_JUMP4, offset, envPtr);
+	    PushStringLiteral(envPtr, "");	/* Evil hack! */
+	    return TCL_OK;
+	}
+    }
+
+    /*
      * Emit a continue instruction.
      */
 
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index ed4d962..4f4286e 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -2869,6 +2869,10 @@ TclCompileWhileCmd(
 
     SetLineInformation(2);
     bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
+    if (!loopMayEnd) {
+	envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
+	envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
+    }
     CompileBody(envPtr, bodyTokenPtr, interp);
     ExceptionRangeEnds(envPtr, range);
     envPtr->currStackDepth = savedStackDepth + 1;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 039a694..631ff58 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -562,7 +562,7 @@ static Command *	FindCompiledCommandFromToken(Tcl_Interp *interp,
 static void		FreeByteCodeInternalRep(Tcl_Obj *objPtr);
 static void		FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
 static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
-static int		IsCompactibleCompileEnv(Tcl_Interp *interp,
+/* static */ int		IsCompactibleCompileEnv(Tcl_Interp *interp,
 			    CompileEnv *envPtr);
 static void		PeepholeOptimize(CompileEnv *envPtr);
 #ifdef TCL_COMPILE_STATS
@@ -745,7 +745,9 @@ TclSetByteCodeFromAny(
 	}
 	compEnv.atCmdStart = 2;		/* The disabling magic. */
 	TclCompileScript(interp, stringPtr, length, &compEnv);
+	assert (compEnv.atCmdStart > 1);
 	TclEmitOpcode(INST_DONE, &compEnv);
+	assert (compEnv.atCmdStart > 1);
     }
 
     /*
@@ -1034,7 +1036,7 @@ TclCleanupByteCode(
  * ---------------------------------------------------------------------
  */
 
-static int
+/* static */ int
 IsCompactibleCompileEnv(
     Tcl_Interp *interp,
     CompileEnv *envPtr)
@@ -1084,9 +1086,11 @@ IsCompactibleCompileEnv(
 	case INST_NSUPVAR:
 	case INST_VARIABLE:
 	    return 0;
+	default:
+	    size = tclInstructionTable[*pc].numBytes;
+	    assert (size > 0);
+	    break;
 	}
-	size = tclInstructionTable[*pc].numBytes;
-	assert (size > 0);
     }
 
     return 1;
@@ -1145,31 +1149,39 @@ PeepholeOptimize(
 		(void) Tcl_CreateHashEntry(&targets, (void *) target, &isNew);
 	    }
 	    break;
+	case INST_START_CMD:
+	    assert (envPtr->atCmdStart < 2);
 	}
     }
 
     /*
-     * Replace PUSH/POP sequences (when non-hazardous) with NOPs.
+     * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also replace
+     * PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an operation
+     * that guarantees the check for arithmeticity).
      */
 
     (void) Tcl_CreateHashEntry(&targets, (void *) pc, &isNew);
     for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
-	int blank = 0, i;
+	int blank = 0, i, inst;
 
 	size = tclInstructionTable[*pc].numBytes;
 	prev2 = prev1;
 	prev1 = pc;
+	while (*(pc+size) == INST_NOP) {
+	    if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) {
+		break;
+	    }
+	    size += tclInstructionTable[INST_NOP].numBytes;
+	}
 	if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) {
 	    continue;
 	}
+	inst = *(pc + size);
 	switch (*pc) {
 	case INST_PUSH1:
-	    while (*(pc+size) == INST_NOP) {
-		size++;
-	    }
-	    if (*(pc+size) == INST_POP) {
-		blank = size + 1;
-	    } else if (*(pc+size) == INST_CONCAT1
+	    if (inst == INST_POP) {
+		blank = size + tclInstructionTable[inst].numBytes;
+	    } else if (inst == INST_CONCAT1
 		    && TclGetUInt1AtPtr(pc + size + 1) == 2) {
 		Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
 			TclGetUInt1AtPtr(pc + 1));
@@ -1177,17 +1189,14 @@ PeepholeOptimize(
 
 		(void) Tcl_GetStringFromObj(litPtr, &numBytes);
 		if (numBytes == 0) {
-		    blank = size + 2;
+		    blank = size + tclInstructionTable[inst].numBytes;
 		}
 	    }
 	    break;
 	case INST_PUSH4:
-	    while (*(pc+size) == INST_NOP) {
-		size++;
-	    }
-	    if (*(pc+size) == INST_POP) {
+	    if (inst == INST_POP) {
 		blank = size + 1;
-	    } else if (*(pc+size) == INST_CONCAT1
+	    } else if (inst == INST_CONCAT1
 		    && TclGetUInt1AtPtr(pc + size + 1) == 2) {
 		Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
 			TclGetUInt4AtPtr(pc + 1));
@@ -1195,10 +1204,49 @@ PeepholeOptimize(
 
 		(void) Tcl_GetStringFromObj(litPtr, &numBytes);
 		if (numBytes == 0) {
-		    blank = size + 2;
+		    blank = size + tclInstructionTable[inst].numBytes;
 		}
 	    }
 	    break;
+	case INST_TRY_CVT_TO_NUMERIC:
+	    switch (inst) {
+	    case INST_JUMP_TRUE1:
+	    case INST_JUMP_TRUE4:
+	    case INST_JUMP_FALSE1:
+	    case INST_JUMP_FALSE4:
+	    case INST_INCR_SCALAR1:
+	    case INST_INCR_ARRAY1:
+	    case INST_INCR_ARRAY_STK:
+	    case INST_INCR_SCALAR_STK:
+	    case INST_INCR_STK:
+	    case INST_LOR:
+	    case INST_LAND:
+	    case INST_EQ:
+	    case INST_NEQ:
+	    case INST_LT:
+	    case INST_LE:
+	    case INST_GT:
+	    case INST_GE:
+	    case INST_MOD:
+	    case INST_LSHIFT:
+	    case INST_RSHIFT:
+	    case INST_BITOR:
+	    case INST_BITXOR:
+	    case INST_BITAND:
+	    case INST_EXPON:
+	    case INST_ADD:
+	    case INST_SUB:
+	    case INST_DIV:
+	    case INST_MULT:
+	    case INST_LNOT:
+	    case INST_BITNOT:
+	    case INST_UMINUS:
+	    case INST_UPLUS:
+	    case INST_TRY_CVT_TO_NUMERIC:
+		blank = size;
+		break;
+	    }
+	    break;
 	}
 	if (blank > 0) {
 	    for (i=0 ; i<blank ; i++) {
@@ -1466,6 +1514,7 @@ TclInitCompileEnv(
     envPtr->mallocedLiteralArray = 0;
 
     envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
+    envPtr->exnStackDepthArrayPtr = envPtr->staticExnStackDepthArraySpace;
     envPtr->exceptArrayNext = 0;
     envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
     envPtr->mallocedExceptArray = 0;
@@ -1678,6 +1727,7 @@ TclFreeCompileEnv(
     }
     if (envPtr->mallocedExceptArray) {
 	ckfree(envPtr->exceptArrayPtr);
+	ckfree(envPtr->exnStackDepthArrayPtr);
     }
     if (envPtr->mallocedCmdMap) {
 	ckfree(envPtr->cmdMapPtr);
@@ -3371,12 +3421,16 @@ TclCreateExceptRange(
 
 	size_t currBytes =
 		envPtr->exceptArrayNext * sizeof(ExceptionRange);
+	size_t currBytes2 = envPtr->exceptArrayNext * sizeof(int);
 	int newElems = 2*envPtr->exceptArrayEnd;
 	size_t newBytes = newElems * sizeof(ExceptionRange);
+	size_t newBytes2 = newElems * sizeof(int);
 
 	if (envPtr->mallocedExceptArray) {
 	    envPtr->exceptArrayPtr =
 		    ckrealloc(envPtr->exceptArrayPtr, newBytes);
+	    envPtr->exnStackDepthArrayPtr =
+		    ckrealloc(envPtr->exnStackDepthArrayPtr, newBytes2);
 	} else {
 	    /*
 	     * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
@@ -3384,9 +3438,12 @@ TclCreateExceptRange(
 	     */
 
 	    ExceptionRange *newPtr = ckalloc(newBytes);
+	    int *newPtr2 = ckalloc(newBytes2);
 
 	    memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
+	    memcpy(newPtr2, envPtr->exnStackDepthArrayPtr, currBytes2);
 	    envPtr->exceptArrayPtr = newPtr;
+	    envPtr->exnStackDepthArrayPtr = newPtr2;
 	    envPtr->mallocedExceptArray = 1;
 	}
 	envPtr->exceptArrayEnd = newElems;
@@ -3401,6 +3458,7 @@ TclCreateExceptRange(
     rangePtr->breakOffset = -1;
     rangePtr->continueOffset = -1;
     rangePtr->catchOffset = -1;
+    envPtr->exnStackDepthArrayPtr[index] = envPtr->currStackDepth;
     return index;
 }
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 0be5d1d..c380823 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -275,6 +275,9 @@ typedef struct CompileEnv {
 				 * entry. */
     int mallocedExceptArray;	/* 1 if ExceptionRange array was expanded and
 				 * exceptArrayPtr points in heap, else 0. */
+    int *exnStackDepthArrayPtr;	/* Array of stack depths to restore to when
+				 * processing BREAK/CONTINUE exceptions. Must
+				 * be the same size as the exceptArrayPtr. */
     CmdLocation *cmdMapPtr;	/* Points to start of CmdLocation array.
 				 * numCommands is the index of the next entry
 				 * to use; (numCommands-1) is the entry index
@@ -296,6 +299,9 @@ typedef struct CompileEnv {
 				/* Initial storage of LiteralEntry array. */
     ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
 				/* Initial ExceptionRange array storage. */
+    int staticExnStackDepthArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
+				/* Initial static except stack depth array
+				 * storage. */
     CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
 				/* Initial storage for cmd location map. */
     AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
-- 
cgit v0.12


From bcc14fb74016c48149e9bc95e2b08a6275fe9410 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 30 May 2013 10:57:13 +0000
Subject: derp

---
 generic/tclCompile.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 631ff58..54946ee 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -562,7 +562,7 @@ static Command *	FindCompiledCommandFromToken(Tcl_Interp *interp,
 static void		FreeByteCodeInternalRep(Tcl_Obj *objPtr);
 static void		FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
 static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
-/* static */ int		IsCompactibleCompileEnv(Tcl_Interp *interp,
+static int		IsCompactibleCompileEnv(Tcl_Interp *interp,
 			    CompileEnv *envPtr);
 static void		PeepholeOptimize(CompileEnv *envPtr);
 #ifdef TCL_COMPILE_STATS
@@ -1036,7 +1036,7 @@ TclCleanupByteCode(
  * ---------------------------------------------------------------------
  */
 
-/* static */ int
+static int
 IsCompactibleCompileEnv(
     Tcl_Interp *interp,
     CompileEnv *envPtr)
-- 
cgit v0.12


From 74847151830190921262fa2a0155bf753465457f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 1 Jun 2013 21:05:55 +0000
Subject: Getting better at doing more efficient break/continue instruction
 handling.

---
 generic/tclCompCmds.c | 113 ++++++++++++++++++++++++++++----------------------
 generic/tclCompile.c  |  42 +++++++++++++++++++
 generic/tclCompile.h  |   6 +++
 3 files changed, 111 insertions(+), 50 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 1f99a22..6e5d187 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -480,7 +480,7 @@ TclCompileBreakCmd(
 				 * compiled. */
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
-    int i, exnIdx;
+    int depth;
     ExceptionRange *rangePtr;
 
     if (parsePtr->numWords != 1) {
@@ -488,33 +488,40 @@ TclCompileBreakCmd(
     }
 
     /*
-     * Find the innermost exception range that contains this command. Relies
-     * on the fact that the range has a numCodeBytes = -1 when it is being
-     * populated and that inner ranges come after outer ranges.
+     * Find the innermost exception range that contains this command.
      */
 
-    exnIdx = -1;
-    for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
-	rangePtr = &envPtr->exceptArrayPtr[i];
-	if (envPtr->codeStart+rangePtr->codeOffset <= envPtr->codeNext
-		&& rangePtr->numCodeBytes == -1) {
-	    exnIdx = i;
+    rangePtr = TclGetInnermostExceptionRange(envPtr, &depth);
+    if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+	int toPop = envPtr->currStackDepth - depth;
+
+	/*
+	 * Pop off the extra stack frames.
+	 */
+
+	while (toPop > 0) {
+	    TclEmitOpcode(INST_POP, envPtr);
+	    toPop--;
+#ifdef TCL_COMPILE_DEBUG
+	    /*
+	     * Instructions that raise exceptions don't really have to follow
+	     * the usual stack management rules.  But the checker wants them
+	     * followed, so lie about stack usage to make it happy.
+	     */
+	    TclAdjustStackDepth(1, envPtr);
+#endif
 	}
-    }
-    if (exnIdx != -1) {
-	rangePtr = &envPtr->exceptArrayPtr[exnIdx];
-	if (rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	    int toPop = envPtr->currStackDepth -
-		    envPtr->exnStackDepthArrayPtr[exnIdx];
+
+	if (envPtr->expandCount == 0 && rangePtr->breakOffset != -1) {
+	    int offset = (rangePtr->breakOffset - CurrentOffset(envPtr));
 
 	    /*
-	     * Pop off the extra stack frames.
+	     * Found the target! Also, no built-up expansion stack. No need
+	     * for a nasty INST_BREAK here.
 	     */
 
-	    while (toPop > 0) {
-		TclEmitOpcode(INST_POP, envPtr);
-		toPop--;
-	    }
+	    TclEmitInstInt4(INST_JUMP4, offset, envPtr);
+	    goto done;
 	}
     }
 
@@ -523,6 +530,8 @@ TclCompileBreakCmd(
      */
 
     TclEmitOpcode(INST_BREAK, envPtr);
+
+  done:
 #ifdef TCL_COMPILE_DEBUG
     /*
      * Instructions that raise exceptions don't really have to follow
@@ -824,7 +833,7 @@ TclCompileContinueCmd(
 				 * compiled. */
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
-    int i, exnIdx;
+    int depth;
     ExceptionRange *rangePtr;
 
     /*
@@ -837,45 +846,40 @@ TclCompileContinueCmd(
 
     /*
      * See if we can find a valid continueOffset (i.e., not -1) in the
-     * innermost containing exception range. Relies on the fact that the range
-     * has a numCodeBytes = -1 when it is being populated and that inner
-     * ranges come after outer ranges.
+     * innermost containing exception range.
      */
 
-    exnIdx = -1;
-    for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
-	rangePtr = &envPtr->exceptArrayPtr[i];
-	if (envPtr->codeStart+rangePtr->codeOffset <= envPtr->codeNext
-		&& rangePtr->numCodeBytes == -1) {
-	    exnIdx = i;
-	}
-    }
-    if (exnIdx >= 0) {
-	rangePtr = &envPtr->exceptArrayPtr[exnIdx];
-	if (rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	    int toPop = envPtr->currStackDepth -
-		    envPtr->exnStackDepthArrayPtr[exnIdx];
+    rangePtr = TclGetInnermostExceptionRange(envPtr, &depth);
+    if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+	int toPop = envPtr->currStackDepth - depth;
+
+	/*
+	 * Pop off the extra stack frames.
+	 */
 
+	while (toPop > 0) {
+	    TclEmitOpcode(INST_POP, envPtr);
+	    toPop--;
+#ifdef TCL_COMPILE_DEBUG
 	    /*
-	     * Pop off the extra stack frames.
+	     * Instructions that raise exceptions don't really have to follow
+	     * the usual stack management rules.  But the checker wants them
+	     * followed, so lie about stack usage to make it happy.
 	     */
-
-	    while (toPop > 0) {
-		TclEmitOpcode(INST_POP, envPtr);
-		toPop--;
-	    }
+	    TclAdjustStackDepth(1, envPtr);
+#endif
 	}
-	if (rangePtr->type == LOOP_EXCEPTION_RANGE
-		&& rangePtr->continueOffset != -1) {
+
+	if (envPtr->expandCount == 0 && rangePtr->continueOffset != -1) {
 	    int offset = (rangePtr->continueOffset - CurrentOffset(envPtr));
 
 	    /*
-	     * Found the target! No need for a nasty INST_CONTINUE here.
+	     * Found the target! Also, no built-up expansion stack. No need
+	     * for a nasty INST_CONTINUE here.
 	     */
 
 	    TclEmitInstInt4(INST_JUMP4, offset, envPtr);
-	    PushStringLiteral(envPtr, "");	/* Evil hack! */
-	    return TCL_OK;
+	    goto done;
 	}
     }
 
@@ -884,7 +888,16 @@ TclCompileContinueCmd(
      */
 
     TclEmitOpcode(INST_CONTINUE, envPtr);
-    PushStringLiteral(envPtr, "");	/* Evil hack! */
+
+  done:
+#ifdef TCL_COMPILE_DEBUG
+    /*
+     * Instructions that raise exceptions don't really have to follow
+     * the usual stack management rules.  But the checker wants them
+     * followed, so lie about stack usage to make it happy.
+     */
+    TclAdjustStackDepth(1, envPtr);
+#endif
     return TCL_OK;
 }
 
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 54946ee..c56b67f 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1523,6 +1523,7 @@ TclInitCompileEnv(
     envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
     envPtr->mallocedCmdMap = 0;
     envPtr->atCmdStart = 1;
+    envPtr->expandCount = 0;
 
     /*
      * TIP #280: Set up the extended command location information, based on
@@ -2060,6 +2061,7 @@ TclCompileScript(
 
 	    if (expand) {
 		TclEmitOpcode(INST_EXPAND_START, envPtr);
+		envPtr->expandCount++;
 	    }
 
 	    /*
@@ -2279,6 +2281,7 @@ TclCompileScript(
 		 */
 
 		TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
+		envPtr->expandCount--;
 		TclAdjustStackDepth(1 - wordIdx, envPtr);
 	    } else if (wordIdx > 0) {
 		/*
@@ -3463,6 +3466,45 @@ TclCreateExceptRange(
 }
 
 /*
+ * ---------------------------------------------------------------------
+ *
+ * TclGetInnermostExceptionRange --
+ *
+ *	Returns the innermost exception range that covers the current code
+ *	creation point, and (optionally) the stack depth that is expected at
+ *	that point. Relies on the fact that the range has a numCodeBytes = -1
+ *	when it is being populated and that inner ranges come after outer
+ *	ranges.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+ExceptionRange *
+TclGetInnermostExceptionRange(
+    CompileEnv *envPtr,
+    int *stackDepthPtr)
+{
+    int exnIdx = -1, i;
+
+    for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+	ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+
+	if (CurrentOffset(envPtr) >= rangePtr->codeOffset &&
+		(rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) <
+			rangePtr->codeOffset+rangePtr->numCodeBytes)) {
+	    exnIdx = i;
+	}
+    }
+    if (exnIdx == -1) {
+	return NULL;
+    }
+    if (stackDepthPtr) {
+	*stackDepthPtr = envPtr->exnStackDepthArrayPtr[exnIdx];
+    }
+    return &envPtr->exceptArrayPtr[exnIdx];
+}
+
+/*
  *----------------------------------------------------------------------
  *
  * TclCreateAuxData --
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index c380823..c9cbbd4 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -318,6 +318,10 @@ typedef struct CompileEnv {
 				 * inefficient. If set to 2, that instruction
 				 * should not be issued at all (by the generic
 				 * part of the command compiler). */
+    int expandCount;		/* Number of INST_EXPAND_START instructions
+				 * encountered that have not yet been paired
+				 * with a corresponding
+				 * INST_INVOKE_EXPANDED. */
     ContLineLoc *clLoc;		/* If not NULL, the table holding the
 				 * locations of the invisible continuation
 				 * lines in the input script, to adjust the
@@ -990,6 +994,8 @@ MODULE_SCOPE void	TclInitCompileEnv(Tcl_Interp *interp,
 			    int numBytes, const CmdFrame *invoker, int word);
 MODULE_SCOPE void	TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
 MODULE_SCOPE void	TclInitLiteralTable(LiteralTable *tablePtr);
+MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
+			    int *depthPtr);
 #ifdef TCL_COMPILE_STATS
 MODULE_SCOPE char *	TclLiteralStats(LiteralTable *tablePtr);
 MODULE_SCOPE int	TclLog2(int value);
-- 
cgit v0.12


From 7390940817e5488deafbd58693bb340d7f24c847 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 2 Jun 2013 17:41:14 +0000
Subject: Many improvements to code generation of efficient break and continue.

---
 generic/tclCompCmds.c   |  93 +++++++++++-----------------
 generic/tclCompCmdsSZ.c |  11 ++--
 generic/tclCompile.c    | 160 ++++++++++++++++++++++++++++++++++++++++++++----
 generic/tclCompile.h    |  52 ++++++++++++++--
 4 files changed, 235 insertions(+), 81 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 6e5d187..f2d2963 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -480,8 +480,8 @@ TclCompileBreakCmd(
 				 * compiled. */
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
-    int depth;
     ExceptionRange *rangePtr;
+    ExceptionAux *auxPtr;
 
     if (parsePtr->numWords != 1) {
 	return TCL_ERROR;
@@ -491,9 +491,9 @@ TclCompileBreakCmd(
      * Find the innermost exception range that contains this command.
      */
 
-    rangePtr = TclGetInnermostExceptionRange(envPtr, &depth);
+    rangePtr = TclGetInnermostExceptionRange(envPtr, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	int toPop = envPtr->currStackDepth - depth;
+	int toPop = envPtr->currStackDepth - auxPtr->stackDepth;
 
 	/*
 	 * Pop off the extra stack frames.
@@ -501,26 +501,18 @@ TclCompileBreakCmd(
 
 	while (toPop > 0) {
 	    TclEmitOpcode(INST_POP, envPtr);
-	    toPop--;
-#ifdef TCL_COMPILE_DEBUG
-	    /*
-	     * Instructions that raise exceptions don't really have to follow
-	     * the usual stack management rules.  But the checker wants them
-	     * followed, so lie about stack usage to make it happy.
-	     */
 	    TclAdjustStackDepth(1, envPtr);
-#endif
+	    toPop--;
 	}
 
-	if (envPtr->expandCount == 0 && rangePtr->breakOffset != -1) {
-	    int offset = (rangePtr->breakOffset - CurrentOffset(envPtr));
-
+	if (envPtr->expandCount == 0) {
 	    /*
 	     * Found the target! Also, no built-up expansion stack. No need
 	     * for a nasty INST_BREAK here.
 	     */
 
-	    TclEmitInstInt4(INST_JUMP4, offset, envPtr);
+	    TclAddLoopBreakFixup(envPtr, auxPtr);
+	    TclEmitInstInt4(INST_JUMP4, 0, envPtr);
 	    goto done;
 	}
     }
@@ -532,14 +524,12 @@ TclCompileBreakCmd(
     TclEmitOpcode(INST_BREAK, envPtr);
 
   done:
-#ifdef TCL_COMPILE_DEBUG
     /*
-     * Instructions that raise exceptions don't really have to follow
-     * the usual stack management rules.  But the checker wants them
-     * followed, so lie about stack usage to make it happy.
+     * Instructions that raise exceptions don't really have to follow the
+     * usual stack management rules, but the cleanup code does.
      */
+
     TclAdjustStackDepth(1, envPtr);
-#endif
     return TCL_OK;
 }
 
@@ -645,7 +635,7 @@ TclCompileCatchCmd(
      * uses.
      */
 
-    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
 
     /*
      * If the body is a simple word, compile a BEGIN_CATCH instruction,
@@ -833,8 +823,8 @@ TclCompileContinueCmd(
 				 * compiled. */
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
-    int depth;
     ExceptionRange *rangePtr;
+    ExceptionAux *auxPtr;
 
     /*
      * There should be no argument after the "continue".
@@ -849,9 +839,9 @@ TclCompileContinueCmd(
      * innermost containing exception range.
      */
 
-    rangePtr = TclGetInnermostExceptionRange(envPtr, &depth);
+    rangePtr = TclGetInnermostExceptionRange(envPtr, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	int toPop = envPtr->currStackDepth - depth;
+	int toPop = envPtr->currStackDepth - auxPtr->stackDepth;
 
 	/*
 	 * Pop off the extra stack frames.
@@ -859,26 +849,18 @@ TclCompileContinueCmd(
 
 	while (toPop > 0) {
 	    TclEmitOpcode(INST_POP, envPtr);
-	    toPop--;
-#ifdef TCL_COMPILE_DEBUG
-	    /*
-	     * Instructions that raise exceptions don't really have to follow
-	     * the usual stack management rules.  But the checker wants them
-	     * followed, so lie about stack usage to make it happy.
-	     */
 	    TclAdjustStackDepth(1, envPtr);
-#endif
+	    toPop--;
 	}
 
-	if (envPtr->expandCount == 0 && rangePtr->continueOffset != -1) {
-	    int offset = (rangePtr->continueOffset - CurrentOffset(envPtr));
-
+	if (envPtr->expandCount == 0) {
 	    /*
 	     * Found the target! Also, no built-up expansion stack. No need
 	     * for a nasty INST_CONTINUE here.
 	     */
 
-	    TclEmitInstInt4(INST_JUMP4, offset, envPtr);
+	    TclAddLoopContinueFixup(envPtr, auxPtr);
+	    TclEmitInstInt4(INST_JUMP4, 0, envPtr);
 	    goto done;
 	}
     }
@@ -890,14 +872,12 @@ TclCompileContinueCmd(
     TclEmitOpcode(INST_CONTINUE, envPtr);
 
   done:
-#ifdef TCL_COMPILE_DEBUG
     /*
-     * Instructions that raise exceptions don't really have to follow
-     * the usual stack management rules.  But the checker wants them
-     * followed, so lie about stack usage to make it happy.
+     * Instructions that raise exceptions don't really have to follow the
+     * usual stack management rules, but the cleanup code does.
      */
+
     TclAdjustStackDepth(1, envPtr);
-#endif
     return TCL_OK;
 }
 
@@ -1350,7 +1330,7 @@ TclCompileDictMergeCmd(
      * For each of the remaining dictionaries...
      */
 
-    outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     TclEmitInstInt4(		INST_BEGIN_CATCH4, outLoop,	envPtr);
     ExceptionRangeStarts(envPtr, outLoop);
     for (i=2 ; i<parsePtr->numWords ; i++) {
@@ -1563,7 +1543,7 @@ CompileDictEachCmd(
      * started by Tcl_DictObjFirst above.
      */
 
-    catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     TclEmitInstInt4(	INST_BEGIN_CATCH4, catchRange,		envPtr);
     ExceptionRangeStarts(envPtr, catchRange);
 
@@ -1581,7 +1561,7 @@ CompileDictEachCmd(
      * Set up the loop exception targets.
      */
 
-    loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+    loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
     ExceptionRangeStarts(envPtr, loopRange);
 
     /*
@@ -1629,6 +1609,7 @@ CompileDictEachCmd(
      */
 
     ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+    TclFinalizeLoopExceptionRange(envPtr, loopRange);
     TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
     TclEmitInt4(		infoIndex,			envPtr);
     TclEmitOpcode(	INST_END_CATCH,				envPtr);
@@ -1807,7 +1788,7 @@ TclCompileDictUpdateCmd(
     TclEmitInstInt4(	INST_DICT_UPDATE_START, dictIndex,	envPtr);
     TclEmitInt4(	infoIndex,				envPtr);
 
-    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     TclEmitInstInt4(	INST_BEGIN_CATCH4, range,		envPtr);
 
     ExceptionRangeStarts(envPtr, range);
@@ -2164,7 +2145,7 @@ TclCompileDictWithCmd(
      * Now the body of the [dict with].
      */
 
-    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     TclEmitInstInt4(		INST_BEGIN_CATCH4, range,	envPtr);
 
     ExceptionRangeStarts(envPtr, range);
@@ -2446,15 +2427,6 @@ TclCompileForCmd(
     }
 
     /*
-     * Create ExceptionRange records for the body and the "next" command. The
-     * "next" command's ExceptionRange supports break but not continue (and
-     * has a -1 continueOffset).
-     */
-
-    bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
-    nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
-
-    /*
      * Inline compile the initial command.
      */
 
@@ -2480,6 +2452,7 @@ TclCompileForCmd(
      * Compile the loop body.
      */
 
+    bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
     bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
     SetLineInformation(4);
     CompileBody(envPtr, bodyTokenPtr, interp);
@@ -2488,9 +2461,12 @@ TclCompileForCmd(
     TclEmitOpcode(INST_POP, envPtr);
 
     /*
-     * Compile the "next" subcommand.
+     * Compile the "next" subcommand. Note that this exception range will not
+     * have a continueOffset (other than -1) connected to it; it won't trap
+     * TCL_CONTINUE but rather just TCL_BREAK.
      */
 
+    nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
     envPtr->currStackDepth = savedStackDepth;
     nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
     SetLineInformation(3);
@@ -2538,6 +2514,8 @@ TclCompileForCmd(
 
     ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
     ExceptionRangeTarget(envPtr, nextRange, breakOffset);
+    TclFinalizeLoopExceptionRange(envPtr, bodyRange);
+    TclFinalizeLoopExceptionRange(envPtr, nextRange);
 
     /*
      * The for command's result is an empty string.
@@ -2829,7 +2807,7 @@ CompileEachloopCmd(
      * Create an exception record to handle [break] and [continue].
      */
 
-    range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+    range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
 
     /*
      * Evaluate then store each value list in the associated temporary.
@@ -2935,6 +2913,7 @@ CompileEachloopCmd(
      */
 
     ExceptionRangeTarget(envPtr, range, breakOffset);
+    TclFinalizeLoopExceptionRange(envPtr, range);
 
     /*
      * The command's result is an empty string if not collecting, or the
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 4f4286e..721f59a 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -834,7 +834,7 @@ TclSubstCompile(
 	}
 
 	envPtr->line = bline;
-	catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+	catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
 	OP4(	BEGIN_CATCH4, catchRange);
 	ExceptionRangeStarts(envPtr, catchRange);
 
@@ -2302,7 +2302,7 @@ IssueTryInstructions(
      * (and it's never called when there's a finally clause).
      */
 
-    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     OP4(				BEGIN_CATCH4, range);
     ExceptionRangeStarts(envPtr, range);
     BODY(				bodyToken, 1);
@@ -2455,7 +2455,7 @@ IssueTryFinallyInstructions(
      * (if any trap matches) and run a finally clause.
      */
 
-    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     OP4(				BEGIN_CATCH4, range);
     ExceptionRangeStarts(envPtr, range);
     envPtr->currStackDepth = savedStackDepth;
@@ -2522,7 +2522,7 @@ IssueTryFinallyInstructions(
 	     */
 
 	    if (resultVars[i] >= 0 || handlerTokens[i]) {
-		range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+		range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
 		OP4(			BEGIN_CATCH4, range);
 		ExceptionRangeStarts(envPtr, range);
 	    }
@@ -2833,7 +2833,7 @@ TclCompileWhileCmd(
      * implement break and continue.
      */
 
-    range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+    range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
 
     /*
      * Jump to the evaluation of the condition. This code uses the "loop
@@ -2917,6 +2917,7 @@ TclCompileWhileCmd(
     envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
     envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
     ExceptionRangeTarget(envPtr, range, breakOffset);
+    TclFinalizeLoopExceptionRange(envPtr, range);
 
     /*
      * The while command's result is an empty string.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c56b67f..96f8683 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1514,7 +1514,7 @@ TclInitCompileEnv(
     envPtr->mallocedLiteralArray = 0;
 
     envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
-    envPtr->exnStackDepthArrayPtr = envPtr->staticExnStackDepthArraySpace;
+    envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace;
     envPtr->exceptArrayNext = 0;
     envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
     envPtr->mallocedExceptArray = 0;
@@ -1728,7 +1728,7 @@ TclFreeCompileEnv(
     }
     if (envPtr->mallocedExceptArray) {
 	ckfree(envPtr->exceptArrayPtr);
-	ckfree(envPtr->exnStackDepthArrayPtr);
+	ckfree(envPtr->exceptAuxArrayPtr);
     }
     if (envPtr->mallocedCmdMap) {
 	ckfree(envPtr->cmdMapPtr);
@@ -3413,6 +3413,7 @@ TclCreateExceptRange(
 				 * new ExceptionRange structure. */
 {
     register ExceptionRange *rangePtr;
+    register ExceptionAux *auxPtr;
     int index = envPtr->exceptArrayNext;
 
     if (index >= envPtr->exceptArrayEnd) {
@@ -3424,16 +3425,16 @@ TclCreateExceptRange(
 
 	size_t currBytes =
 		envPtr->exceptArrayNext * sizeof(ExceptionRange);
-	size_t currBytes2 = envPtr->exceptArrayNext * sizeof(int);
+	size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
 	int newElems = 2*envPtr->exceptArrayEnd;
 	size_t newBytes = newElems * sizeof(ExceptionRange);
-	size_t newBytes2 = newElems * sizeof(int);
+	size_t newBytes2 = newElems * sizeof(ExceptionAux);
 
 	if (envPtr->mallocedExceptArray) {
 	    envPtr->exceptArrayPtr =
 		    ckrealloc(envPtr->exceptArrayPtr, newBytes);
-	    envPtr->exnStackDepthArrayPtr =
-		    ckrealloc(envPtr->exnStackDepthArrayPtr, newBytes2);
+	    envPtr->exceptAuxArrayPtr =
+		    ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
 	} else {
 	    /*
 	     * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
@@ -3441,12 +3442,12 @@ TclCreateExceptRange(
 	     */
 
 	    ExceptionRange *newPtr = ckalloc(newBytes);
-	    int *newPtr2 = ckalloc(newBytes2);
+	    ExceptionAux *newPtr2 = ckalloc(newBytes2);
 
 	    memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
-	    memcpy(newPtr2, envPtr->exnStackDepthArrayPtr, currBytes2);
+	    memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
 	    envPtr->exceptArrayPtr = newPtr;
-	    envPtr->exnStackDepthArrayPtr = newPtr2;
+	    envPtr->exceptAuxArrayPtr = newPtr2;
 	    envPtr->mallocedExceptArray = 1;
 	}
 	envPtr->exceptArrayEnd = newElems;
@@ -3461,7 +3462,14 @@ TclCreateExceptRange(
     rangePtr->breakOffset = -1;
     rangePtr->continueOffset = -1;
     rangePtr->catchOffset = -1;
-    envPtr->exnStackDepthArrayPtr[index] = envPtr->currStackDepth;
+    auxPtr = &envPtr->exceptAuxArrayPtr[index];
+    auxPtr->stackDepth = envPtr->currStackDepth;
+    auxPtr->numBreakTargets = 0;
+    auxPtr->breakTargets = NULL;
+    auxPtr->allocBreakTargets = 0;
+    auxPtr->numContinueTargets = 0;
+    auxPtr->continueTargets = NULL;
+    auxPtr->allocContinueTargets = 0;
     return index;
 }
 
@@ -3482,7 +3490,7 @@ TclCreateExceptRange(
 ExceptionRange *
 TclGetInnermostExceptionRange(
     CompileEnv *envPtr,
-    int *stackDepthPtr)
+    ExceptionAux **auxPtrPtr)
 {
     int exnIdx = -1, i;
 
@@ -3498,12 +3506,122 @@ TclGetInnermostExceptionRange(
     if (exnIdx == -1) {
 	return NULL;
     }
-    if (stackDepthPtr) {
-	*stackDepthPtr = envPtr->exnStackDepthArrayPtr[exnIdx];
+    if (auxPtrPtr) {
+	*auxPtrPtr = &envPtr->exceptAuxArrayPtr[exnIdx];
     }
     return &envPtr->exceptArrayPtr[exnIdx];
 }
 
+void
+TclAddLoopBreakFixup(
+    CompileEnv *envPtr,
+    ExceptionAux *auxPtr)
+{
+    int range = auxPtr - envPtr->exceptAuxArrayPtr;
+
+    if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+	Tcl_Panic("trying to add 'break' fixup to full exception range");
+    }
+
+    if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
+	auxPtr->allocBreakTargets *= 2;
+	auxPtr->allocBreakTargets += 2;
+	if (auxPtr->breakTargets) {
+	    auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets,
+		    sizeof(int) * auxPtr->allocBreakTargets);
+	} else {
+	    auxPtr->breakTargets =
+		    ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
+	}
+    }
+    auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
+}
+
+void
+TclAddLoopContinueFixup(
+    CompileEnv *envPtr,
+    ExceptionAux *auxPtr)
+{
+    int range = auxPtr - envPtr->exceptAuxArrayPtr;
+
+    if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+	Tcl_Panic("trying to add 'continue' fixup to full exception range");
+    }
+
+    if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
+	auxPtr->allocContinueTargets *= 2;
+	auxPtr->allocContinueTargets += 2;
+	if (auxPtr->continueTargets) {
+	    auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets,
+		    sizeof(int) * auxPtr->allocContinueTargets);
+	} else {
+	    auxPtr->continueTargets =
+		    ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
+	}
+    }
+    auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
+	    CurrentOffset(envPtr);
+}
+
+void
+TclFinalizeLoopExceptionRange(
+    CompileEnv *envPtr,
+    int range)
+{
+    ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range];
+    ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range];
+    int i, offset;
+    unsigned char *site;
+
+    if (rangePtr->type != LOOP_EXCEPTION_RANGE) {
+	Tcl_Panic("trying to finalize a loop exception range");
+    }
+
+    /*
+     * Do the jump fixups. Note that these are always issued as INST_JUMP4 so
+     * there is no need to fuss around with updating code offsets.
+     */
+
+    for (i=0 ; i<auxPtr->numBreakTargets ; i++) {
+	site = envPtr->codeStart + auxPtr->breakTargets[i];
+	offset = rangePtr->breakOffset - auxPtr->breakTargets[i];
+	TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
+    }
+    for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
+	site = envPtr->codeStart + auxPtr->continueTargets[i];
+	if (rangePtr->continueOffset == -1) {
+	    int j;
+
+	    /*
+	     * WTF? Can't bind, so revert to an INST_CONTINUE.
+	     */
+
+	    *site = INST_CONTINUE;
+	    for (j=0 ; j<4 ; j++) {
+		*++site = INST_NOP;
+	    }
+	} else {
+	    offset = rangePtr->continueOffset - auxPtr->continueTargets[i];
+	    TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
+	}
+    }
+
+    /*
+     * Drop the arrays we were holding the only reference to.
+     */
+
+    if (auxPtr->breakTargets) {
+	ckfree(auxPtr->breakTargets);
+	auxPtr->breakTargets = NULL;
+	auxPtr->numBreakTargets = 0;
+    }
+    if (auxPtr->continueTargets) {
+	ckfree(auxPtr->continueTargets);
+	auxPtr->continueTargets = NULL;
+	auxPtr->numContinueTargets = 0;
+    }
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -3864,6 +3982,22 @@ TclFixupForwardJump(
 	}
     }
 
+    for (k = 0 ; k < envPtr->exceptArrayNext ; k++) {
+	ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k];
+	int i;
+
+	for (i=0 ; i<auxPtr->numBreakTargets ; i++) {
+	    if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) {
+		auxPtr->breakTargets[i] += 3;
+	    }
+	}
+	for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
+	    if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) {
+		auxPtr->continueTargets[i] += 3;
+	    }
+	}
+    }
+
     /*
      * TIP #280: Adjust the mapping from PC values to the per-command
      * information about arguments and their line numbers.
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index c9cbbd4..8430da3 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -100,6 +100,38 @@ typedef struct ExceptionRange {
 } ExceptionRange;
 
 /*
+ * Auxiliary data used when issuing (currently just loop) exception ranges,
+ * but which is not required during execution.
+ */
+
+typedef struct ExceptionAux {
+    int stackDepth;		/* The stack depth at the point where the
+				 * exception range was created. This is used
+				 * to calculate the number of POPs required to
+				 * restore the stack to its prior state. */
+    int numBreakTargets;	/* The number of [break]s that want to be
+				 * targeted to the place where this loop
+				 * exception will be bound to. */
+    int *breakTargets;		/* The offsets of the INST_JUMP4 instructions
+				 * issued by the [break]s that we must
+				 * update. Note that resizing a jump (via
+				 * TclFixupForwardJump) can cause the contents
+				 * of this array to be updated. When
+				 * numBreakTargets==0, this is NULL. */
+    int allocBreakTargets;	/* The size of the breakTargets array. */
+    int numContinueTargets;	/* The number of [continue]s that want to be
+				 * targeted to the place where this loop
+				 * exception will be bound to. */
+    int *continueTargets;	/* The offsets of the INST_JUMP4 instructions
+				 * issued by the [continue]s that we must
+				 * update. Note that resizing a jump (via
+				 * TclFixupForwardJump) can cause the contents
+				 * of this array to be updated. When
+				 * numContinueTargets==0, this is NULL. */
+    int allocContinueTargets;	/* The size of the continueTargets array. */
+} ExceptionAux;
+
+/*
  * Structure used to map between instruction pc and source locations. It
  * defines for each compiled Tcl command its code's starting offset and its
  * source's starting offset and length. Note that the code offset increases
@@ -275,9 +307,11 @@ typedef struct CompileEnv {
 				 * entry. */
     int mallocedExceptArray;	/* 1 if ExceptionRange array was expanded and
 				 * exceptArrayPtr points in heap, else 0. */
-    int *exnStackDepthArrayPtr;	/* Array of stack depths to restore to when
-				 * processing BREAK/CONTINUE exceptions. Must
-				 * be the same size as the exceptArrayPtr. */
+    ExceptionAux *exceptAuxArrayPtr;
+				/* Array of information used to restore the
+				 * state when processing BREAK/CONTINUE
+				 * exceptions. Must be the same size as the
+				 * exceptArrayPtr. */
     CmdLocation *cmdMapPtr;	/* Points to start of CmdLocation array.
 				 * numCommands is the index of the next entry
 				 * to use; (numCommands-1) is the entry index
@@ -299,8 +333,8 @@ typedef struct CompileEnv {
 				/* Initial storage of LiteralEntry array. */
     ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
 				/* Initial ExceptionRange array storage. */
-    int staticExnStackDepthArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
-				/* Initial static except stack depth array
+    ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
+				/* Initial static except auxiliary info array
 				 * storage. */
     CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
 				/* Initial storage for cmd location map. */
@@ -995,7 +1029,13 @@ MODULE_SCOPE void	TclInitCompileEnv(Tcl_Interp *interp,
 MODULE_SCOPE void	TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
 MODULE_SCOPE void	TclInitLiteralTable(LiteralTable *tablePtr);
 MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
-			    int *depthPtr);
+			    ExceptionAux **auxPtrPtr);
+MODULE_SCOPE void	TclAddLoopBreakFixup(CompileEnv *envPtr,
+			    ExceptionAux *auxPtr);
+MODULE_SCOPE void	TclAddLoopContinueFixup(CompileEnv *envPtr,
+			    ExceptionAux *auxPtr);
+MODULE_SCOPE void	TclFinalizeLoopExceptionRange(CompileEnv *envPtr,
+			    int range);
 #ifdef TCL_COMPILE_STATS
 MODULE_SCOPE char *	TclLiteralStats(LiteralTable *tablePtr);
 MODULE_SCOPE int	TclLog2(int value);
-- 
cgit v0.12


From 15425ace0bf82bc4a3b245c412b093a3e3cd48b6 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 2 Jun 2013 18:54:09 +0000
Subject: Remove useless macro, use existing macro where it makes sense.

---
 generic/tclAssembly.c | 4 ++--
 generic/tclCompile.h  | 3 ---
 2 files changed, 2 insertions(+), 5 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 0fe50b3a..d1af8c6 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -650,7 +650,7 @@ BBEmitOpcode(
     }
 
     TclEmitInt1(op, envPtr);
-    envPtr->atCmdStart = ((op) == INST_START_CMD);
+    TclUpdateAtCmdStart(op, envPtr);
     BBUpdateStackReqs(bbPtr, tblIdx, count);
 }
 
@@ -711,7 +711,7 @@ BBEmitInst1or4(
     } else {
 	TclEmitInt4(param, envPtr);
     }
-    envPtr->atCmdStart = ((op) == INST_START_CMD);
+    TclUpdateAtCmdStart(op, envPtr);
     BBUpdateStackReqs(bbPtr, tblIdx, count);
 }
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 8430da3..4b50710 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1450,14 +1450,11 @@ MODULE_SCOPE Tcl_Obj	*TclNewInstNameObj(unsigned char inst);
  * of LOOP ranges is an interesting datum for debugging purposes, and that is
  * what we compute now.
  *
- * static int	DeclareExceptionRange(CompileEnv *envPtr, int type);
  * static int	ExceptionRangeStarts(CompileEnv *envPtr, int index);
  * static void	ExceptionRangeEnds(CompileEnv *envPtr, int index);
  * static void	ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
  */
 
-#define DeclareExceptionRange(envPtr, type) \
-    (TclCreateExceptRange((type), (envPtr)))
 #define ExceptionRangeStarts(envPtr, index) \
     (((envPtr)->exceptDepth++),						\
     ((envPtr)->maxExceptDepth =						\
-- 
cgit v0.12


From 7da4d962162d8e1404b07a50a42f4d29fb7a0e47 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 2 Jun 2013 21:32:16 +0000
Subject: Fix a stack depth calculation.

---
 generic/tclCompCmdsSZ.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 721f59a..7831198 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -1518,7 +1518,7 @@ IssueSwitchChainedTests(
 	 */
 
 	OP(	POP);
-	envPtr->currStackDepth = savedStackDepth + 1;
+	envPtr->currStackDepth = savedStackDepth;
 	envPtr->line = bodyLines[i+1];		/* TIP #280 */
 	envPtr->clNext = bodyContLines[i+1];	/* TIP #280 */
 	TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
-- 
cgit v0.12


From 2797b611e3c91e59d77af63fcc37bc3ba85dcabb Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 3 Jun 2013 09:37:14 +0000
Subject: Generate [continue] optimally in [for] next clauses. Add tests for
 Bug 3614226.

---
 generic/tclCompCmds.c | 11 ++++----
 generic/tclCompile.c  | 35 +++++++++++++++++++++++-
 generic/tclCompile.h  | 13 ++++++++-
 tests/for.test        | 74 ++++++++++++++++++++++++++++++++++++++++++++++-----
 4 files changed, 119 insertions(+), 14 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index f2d2963..3046841 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -491,7 +491,7 @@ TclCompileBreakCmd(
      * Find the innermost exception range that contains this command.
      */
 
-    rangePtr = TclGetInnermostExceptionRange(envPtr, &auxPtr);
+    rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
 	int toPop = envPtr->currStackDepth - auxPtr->stackDepth;
 
@@ -505,14 +505,13 @@ TclCompileBreakCmd(
 	    toPop--;
 	}
 
-	if (envPtr->expandCount == 0) {
+	if (envPtr->expandCount == auxPtr->expandTarget) {
 	    /*
 	     * Found the target! Also, no built-up expansion stack. No need
 	     * for a nasty INST_BREAK here.
 	     */
 
 	    TclAddLoopBreakFixup(envPtr, auxPtr);
-	    TclEmitInstInt4(INST_JUMP4, 0, envPtr);
 	    goto done;
 	}
     }
@@ -839,7 +838,7 @@ TclCompileContinueCmd(
      * innermost containing exception range.
      */
 
-    rangePtr = TclGetInnermostExceptionRange(envPtr, &auxPtr);
+    rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
 	int toPop = envPtr->currStackDepth - auxPtr->stackDepth;
 
@@ -853,14 +852,13 @@ TclCompileContinueCmd(
 	    toPop--;
 	}
 
-	if (envPtr->expandCount == 0) {
+	if (envPtr->expandCount == auxPtr->expandTarget) {
 	    /*
 	     * Found the target! Also, no built-up expansion stack. No need
 	     * for a nasty INST_CONTINUE here.
 	     */
 
 	    TclAddLoopContinueFixup(envPtr, auxPtr);
-	    TclEmitInstInt4(INST_JUMP4, 0, envPtr);
 	    goto done;
 	}
     }
@@ -2467,6 +2465,7 @@ TclCompileForCmd(
      */
 
     nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+    envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0;
     envPtr->currStackDepth = savedStackDepth;
     nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
     SetLineInformation(3);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 96f8683..f2e9329 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -3463,7 +3463,9 @@ TclCreateExceptRange(
     rangePtr->continueOffset = -1;
     rangePtr->catchOffset = -1;
     auxPtr = &envPtr->exceptAuxArrayPtr[index];
+    auxPtr->supportsContinue = 1;
     auxPtr->stackDepth = envPtr->currStackDepth;
+    auxPtr->expandTarget = envPtr->expandCount;
     auxPtr->numBreakTargets = 0;
     auxPtr->breakTargets = NULL;
     auxPtr->allocBreakTargets = 0;
@@ -3490,6 +3492,7 @@ TclCreateExceptRange(
 ExceptionRange *
 TclGetInnermostExceptionRange(
     CompileEnv *envPtr,
+    int returnCode,
     ExceptionAux **auxPtrPtr)
 {
     int exnIdx = -1, i;
@@ -3499,7 +3502,9 @@ TclGetInnermostExceptionRange(
 
 	if (CurrentOffset(envPtr) >= rangePtr->codeOffset &&
 		(rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) <
-			rangePtr->codeOffset+rangePtr->numCodeBytes)) {
+			rangePtr->codeOffset+rangePtr->numCodeBytes) &&
+		(returnCode != TCL_CONTINUE ||
+			envPtr->exceptAuxArrayPtr[i].supportsContinue)) {
 	    exnIdx = i;
 	}
     }
@@ -3512,6 +3517,19 @@ TclGetInnermostExceptionRange(
     return &envPtr->exceptArrayPtr[exnIdx];
 }
 
+/*
+ * ---------------------------------------------------------------------
+ *
+ * TclAddLoopBreakFixup, TclAddLoopContinueFixup --
+ *
+ *	Adds a place that wants to break/continue to the loop exception range
+ *	tracking that will be fixed up once the loop can be finalized. These
+ *	functions will generate an INST_JUMP4 that will be fixed up during the
+ *	loop finalization.
+ *
+ * ---------------------------------------------------------------------
+ */
+
 void
 TclAddLoopBreakFixup(
     CompileEnv *envPtr,
@@ -3535,6 +3553,7 @@ TclAddLoopBreakFixup(
 	}
     }
     auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
+    TclEmitInstInt4(INST_JUMP4, 0, envPtr);
 }
 
 void
@@ -3561,7 +3580,21 @@ TclAddLoopContinueFixup(
     }
     auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
 	    CurrentOffset(envPtr);
+    TclEmitInstInt4(INST_JUMP4, 0, envPtr);
 }
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * TclFinalizeLoopExceptionRange --
+ *
+ *	Finalizes a loop exception range, binding the registered [break] and
+ *	[continue] implementations so that they jump to the correct place.
+ *	Note that this must only be called after *all* the exception range
+ *	target offsets have been set.
+ *
+ * ---------------------------------------------------------------------
+ */
 
 void
 TclFinalizeLoopExceptionRange(
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 4b50710..957c724 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -105,10 +105,21 @@ typedef struct ExceptionRange {
  */
 
 typedef struct ExceptionAux {
+    int supportsContinue;	/* Whether this exception range will have a
+				 * continueOffset created for it; if it is a
+				 * loop exception range that *doesn't* have
+				 * one (see [for] next-clause) then we must
+				 * not pick up the range when scanning for a
+				 * target to continue to. */
     int stackDepth;		/* The stack depth at the point where the
 				 * exception range was created. This is used
 				 * to calculate the number of POPs required to
 				 * restore the stack to its prior state. */
+    int expandTarget;		/* The number of expansions expected on the
+				 * auxData stack at the time the loop starts;
+				 * we can't currently discard them except by
+				 * doing INST_INVOKE_EXPANDED; this is a known
+				 * problem. */
     int numBreakTargets;	/* The number of [break]s that want to be
 				 * targeted to the place where this loop
 				 * exception will be bound to. */
@@ -1029,7 +1040,7 @@ MODULE_SCOPE void	TclInitCompileEnv(Tcl_Interp *interp,
 MODULE_SCOPE void	TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
 MODULE_SCOPE void	TclInitLiteralTable(LiteralTable *tablePtr);
 MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
-			    ExceptionAux **auxPtrPtr);
+			    int returnCode, ExceptionAux **auxPtrPtr);
 MODULE_SCOPE void	TclAddLoopBreakFixup(CompileEnv *envPtr,
 			    ExceptionAux *auxPtr);
 MODULE_SCOPE void	TclAddLoopContinueFixup(CompileEnv *envPtr,
diff --git a/tests/for.test b/tests/for.test
index ff4dc0e..3f4d2b7 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -14,6 +14,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
     namespace import -force ::tcltest::*
 }
 
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+    proc meminfo {} {lindex [split [memory info] "\n"] 3 3}
+}
+
 # Basic "for" operation.
 
 test for-1.1 {TclCompileForCmd: missing initial command} {
@@ -345,7 +351,6 @@ proc formatMail {} {
         64 {        UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \
         65 {     binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \
     }
-
     set result ""
     set NL "
 "
@@ -365,7 +370,6 @@ proc formatMail {} {
     } else {
 	set break 1
     }
-
     set xmailer 0
     set inheaders 1
     set last [array size lines]
@@ -386,9 +390,7 @@ proc formatMail {} {
 	    set limit 55
 	} else {
 	    set limit 55
-
 	    # Decide whether or not to break the body line
-
 	    if {$plen > 0} {
 		if {[string first {> } $line] == 0} {
 		    # This is quoted text from previous message, don't reformat
@@ -431,7 +433,7 @@ proc formatMail {} {
 	set climit [expr $limit-1]
 	set cutoff 50
 	set continuation 0
-	
+
 	while {[string length $line] > $limit} {
 	    for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} {
 		set char [string index $line $c]
@@ -824,7 +826,67 @@ test for-6.18 {Tcl_ForObjCmd: for command result} {
     1 {invoked "continue" outside of a loop} \
     ]
 
-
+test for-7.1 {Bug 3614226: ensure that break cleans up the stack} memory {
+    apply {{} {
+	# 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} {$x < 5} {incr x} {
+		list a b c [break] d e f
+	    }
+	    set tmp $end
+	    set end [meminfo]
+	}
+	expr {$end - $tmp}
+    }}
+} 0
+test for-7.2 {Bug 3614226: ensure that continue cleans up the stack} memory {
+    apply {{} {
+	# 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} {$x < 5} {incr x} {
+		list a b c [continue] d e f
+	    }
+	    set tmp $end
+	    set end [meminfo]
+	}
+	expr {$end - $tmp}
+    }}
+} 0
+test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} {memory knownBug} {
+    apply {{} {
+	# 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 a b c {*}[break] d e f]
+	    }
+	    set tmp $end
+	    set end [meminfo]
+	}
+	expr {$end - $tmp}
+    }}
+} 0
+test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} {memory knownBug} {
+    apply {{} {
+	# 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 a b c {*}[continue] d e f]
+	    }
+	    set tmp $end
+	    set end [meminfo]
+	}
+	expr {$end - $tmp}
+    }}
+} 0
+
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End:
-- 
cgit v0.12


From e7d31b9449627e1366d5127c104769228337d653 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 3 Jun 2013 14:01:24 +0000
Subject: Improve reliability of test httpold-4.12.  Thanks AF!

---
 tests/httpd | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/httpd b/tests/httpd
index 3ea8024..7ba07af 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -39,7 +39,7 @@ proc httpdAccept {newsock ipaddr port} {
     fconfigure $newsock -blocking 0 -translation {auto crlf}
     httpd_log $newsock Connect $ipaddr $port
     set data(ipaddr) $ipaddr
-    fileevent $newsock readable [list httpdRead $newsock]
+    after 50 [list fileevent $newsock readable [list httpdRead $newsock]]
 }
 
 # read data from a client request
-- 
cgit v0.12


From 546d781de9e987b0e73eb2c52d7561c30407d6eb Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 3 Jun 2013 14:19:43 +0000
Subject: last-moment fix for FreeBSD from Pietro Cerutti

---
 unix/configure | 4 ++--
 unix/tcl.m4    | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/unix/configure b/unix/configure
index ec5298c..36d7b8d 100755
--- a/unix/configure
+++ b/unix/configure
@@ -3425,14 +3425,14 @@ echo "$ac_t""$tcl_cv_ld_elf" 1>&6
 	    # This configuration from FreeBSD Ports.
 	    SHLIB_CFLAGS="-fPIC"
 	    SHLIB_LD="${CC} -shared"
-	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname \$@"
+	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@"
 	    SHLIB_SUFFIX=".so"
 	    DL_OBJS="tclLoadDl.o"
 	    DL_LIBS=""
 	    LDFLAGS=""
 	    if test $doRpath = yes ; then
 		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
-		LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
 		fi
 	    if test "${TCL_THREADS}" = "1" ; then
 		# The -pthread needs to go in the LDFLAGS, not LIBS
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 85b8f82..45d19ae 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1564,14 +1564,14 @@ dnl AC_CHECK_TOOL(AR, ar)
 	    # This configuration from FreeBSD Ports.
 	    SHLIB_CFLAGS="-fPIC"
 	    SHLIB_LD="${CC} -shared"
-	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname \$[@]"
+	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]"
 	    SHLIB_SUFFIX=".so"
 	    DL_OBJS="tclLoadDl.o"
 	    DL_LIBS=""
 	    LDFLAGS=""
 	    if test $doRpath = yes ; then
 		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
-		LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
 		fi
 	    if test "${TCL_THREADS}" = "1" ; then
 		# The -pthread needs to go in the LDFLAGS, not LIBS
-- 
cgit v0.12


From 2a3000c25e6712d2bc2e4c1f631fdf6a22b41547 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 3 Jun 2013 14:57:48 +0000
Subject: Next stage of fixing the break/continue generation.

---
 generic/tclCompCmds.c | 76 +++++++++++++++++++++++++++++----------------------
 generic/tclCompile.c  |  3 ++
 generic/tclCompile.h  |  4 ++-
 generic/tclExecute.c  | 11 ++++++++
 tests/for.test        |  4 +--
 5 files changed, 63 insertions(+), 35 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 3046841..3d6abcf 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -493,36 +493,42 @@ TclCompileBreakCmd(
 
     rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	int toPop = envPtr->currStackDepth - auxPtr->stackDepth;
+	int toPop;
+
+	/*
+	 * Ditch the extra elements from the auxiliary stack.
+	 */
+
+	toPop = envPtr->expandCount - auxPtr->expandTarget;
+	while (toPop > 0) {
+	    TclEmitOpcode(INST_EXPAND_DROP, envPtr);
+	    toPop--;
+	}
 
 	/*
 	 * Pop off the extra stack frames.
 	 */
 
+	toPop = envPtr->currStackDepth - auxPtr->stackDepth;
 	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.
-	     */
-
-	    TclAddLoopBreakFixup(envPtr, auxPtr);
-	    goto done;
-	}
-    }
+	/*
+	 * Found the target! No need for a nasty INST_BREAK here.
+	 */
 
-    /*
-     * Emit a break instruction.
-     */
+	TclAddLoopBreakFixup(envPtr, auxPtr);
+    } else {
+	/*
+	 * Emit a break instruction.
+	 */
 
-    TclEmitOpcode(INST_BREAK, envPtr);
+	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,36 +846,42 @@ TclCompileContinueCmd(
 
     rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	int toPop = envPtr->currStackDepth - auxPtr->stackDepth;
+	int toPop;
+
+	/*
+	 * Ditch the extra elements from the auxiliary stack.
+	 */
+
+	toPop = envPtr->expandCount - auxPtr->expandTarget;
+	while (toPop > 0) {
+	    TclEmitOpcode(INST_EXPAND_DROP, envPtr);
+	    toPop--;
+	}
 
 	/*
 	 * Pop off the extra stack frames.
 	 */
 
+	toPop = envPtr->currStackDepth - auxPtr->stackDepth;
 	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.
-	     */
-
-	    TclAddLoopContinueFixup(envPtr, auxPtr);
-	    goto done;
-	}
-    }
+	/*
+	 * Found the target! No need for a nasty INST_CONTINUE here.
+	 */
 
-    /*
-     * Emit a continue instruction.
-     */
+	TclAddLoopContinueFixup(envPtr, auxPtr);
+    } else {
+	/*
+	 * Emit a continue instruction.
+	 */
 
-    TclEmitOpcode(INST_CONTINUE, envPtr);
+	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..f8dd504 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -540,6 +540,9 @@ 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. */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 957c724..75de025 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -772,8 +772,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
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 7c645e7..559df0b 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2718,6 +2718,17 @@ TEBCresume(
 	PUSH_TAUX_OBJ(objPtr);
 	NEXT_INST_F(1, 0, 0);
 
+    case INST_EXPAND_DROP:
+	/*
+	 * Drops an element of the auxObjList. Does not do any clean up of the
+	 * actual stack.
+	 *
+	 * TODO: POP MAIN STACK BACK TO MARKER
+	 */
+
+	POP_TAUX_OBJ();
+	NEXT_INST_F(1, 0, 0);
+
     case INST_EXPAND_STKTOP: {
 	int i;
 	ptrdiff_t moved;
diff --git a/tests/for.test b/tests/for.test
index 3f4d2b7..cfba1fe 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]
-- 
cgit v0.12


From 17f4b04d101612d86e9aa09917a613a3a5e2496a Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 3 Jun 2013 16:10:30 +0000
Subject: fix for perf bug detected by Kieran
 (https://groups.google.com/forum/?fromgroups#!topic/comp.lang.tcl/vfpI3bc-DkQ)

---
 ChangeLog            |  8 ++++++++
 generic/tclExecute.c | 11 ++++++-----
 2 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 0661925..9d5e542 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2013-06-03  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclExecute.c: fix for perf bug detected by Kieran
+	(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]. 
+
 2013-05-28 Harald Oehlmann  <oehhar@users.sf.net>
 
 	* library/msgcat/msgcat.tcl: [Bug 3036566]: Also get locale from
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 0de8e3c..8fb8e63 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2424,11 +2424,6 @@ TclExecuteByteCode(
 	    if (result == TCL_OK) {
 		Tcl_Obj *objPtr;
 
-#ifndef TCL_COMPILE_DEBUG
-		if (*(pc+pcAdjustment) == INST_POP) {
-		    NEXT_INST_V((pcAdjustment+1), objc, 0);
-		}
-#endif
 		/*
 		 * Push the call's object result and continue execution with
 		 * the next instruction.
@@ -2455,6 +2450,12 @@ TclExecuteByteCode(
 		TclNewObj(objPtr);
 		Tcl_IncrRefCount(objPtr);
 		iPtr->objResultPtr = objPtr;
+#ifndef TCL_COMPILE_DEBUG
+		if (*(pc+pcAdjustment) == INST_POP) {
+		    TclDecrRefCount(objResultPtr);
+		    NEXT_INST_V((pcAdjustment+1), objc, 0);
+		}
+#endif
 		NEXT_INST_V(pcAdjustment, objc, -1);
 	    } else {
 		cleanup = objc;
-- 
cgit v0.12


From c8b0ad64d121990ec3daf7b42424ac1539fb0c7d Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 4 Jun 2013 08:33:16 +0000
Subject: Eliminate NO_VIZ macro as current zlib uses HAVE_HIDDEN in stead. One
 more last-moment fix for FreeBSD by Pietro Cerutti

---
 ChangeLog           |  6 ++++++
 unix/configure      | 20 ++++++--------------
 unix/tcl.m4         | 12 ++----------
 unix/tclConfig.h.in |  4 ++--
 win/configure       |  4 ----
 win/configure.in    |  1 -
 6 files changed, 16 insertions(+), 31 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f2a8c44..53bcb80 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+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
+
 2013-06-03  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclExecute.c: fix for perf bug detected by Kieran
diff --git a/unix/configure b/unix/configure
index 583cd01..7626343 100755
--- a/unix/configure
+++ b/unix/configure
@@ -6617,6 +6617,11 @@ cat >>confdefs.h <<\_ACEOF
 _ACEOF
 
 
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_HIDDEN 1
+_ACEOF
+
+
 fi
 
 
@@ -7827,20 +7832,12 @@ fi
 
 fi
 
-	    case $system in
-	    FreeBSD-3.*)
-	    	# FreeBSD-3 doesn't handle version numbers with dots.
-	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
-	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
-	    	TCL_LIB_VERSIONS_OK=nodots
-		;;
-	    esac
 	    ;;
 	FreeBSD-*)
 	    # This configuration from FreeBSD Ports.
 	    SHLIB_CFLAGS="-fPIC"
 	    SHLIB_LD="${CC} -shared"
-	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$@"
+	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$@"
 	    SHLIB_SUFFIX=".so"
 	    DL_OBJS="tclLoadDl.o"
 	    DL_LIBS=""
@@ -9057,11 +9054,6 @@ cat >>confdefs.h <<\_ACEOF
 _ACEOF
 
 
-cat >>confdefs.h <<\_ACEOF
-#define NO_VIZ
-_ACEOF
-
-
 fi
 
 
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index cc7c936..43e2b78 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1067,6 +1067,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 	    AC_DEFINE(MODULE_SCOPE,
 		[extern __attribute__((__visibility__("hidden")))],
 		[Compiler support for module scope symbols])
+	    AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols])
 	])
     ])
 
@@ -1537,20 +1538,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 		CFLAGS="$CFLAGS -pthread"
 	    	LDFLAGS="$LDFLAGS -pthread"
 	    ])
-	    case $system in
-	    FreeBSD-3.*)
-	    	# FreeBSD-3 doesn't handle version numbers with dots.
-	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
-	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so'
-	    	TCL_LIB_VERSIONS_OK=nodots
-		;;
-	    esac
 	    ;;
 	FreeBSD-*)
 	    # This configuration from FreeBSD Ports.
 	    SHLIB_CFLAGS="-fPIC"
 	    SHLIB_LD="${CC} -shared"
-	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname,\$[@]"
+	    TCL_SHLIB_LD_EXTRAS="-Wl,-soname=\$[@]"
 	    SHLIB_SUFFIX=".so"
 	    DL_OBJS="tclLoadDl.o"
 	    DL_LIBS=""
@@ -2048,7 +2041,6 @@ dnl # preprocessing tests use only CPPFLAGS.
     AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
 	AC_DEFINE(MODULE_SCOPE, [extern],
 	    [No Compiler support for module scope symbols])
-	AC_DEFINE(NO_VIZ, [], [No visibility attribute])
     ])
 
     AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [
diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index 839c2ab..23d6026 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -343,8 +343,8 @@
 /* Do we have <values.h>? */
 #undef NO_VALUES_H
 
-/* No visibility attribute */
-#undef NO_VIZ
+/* Compiler support for module scope symbols */
+#undef HAVE_HIDDEN
 
 /* Do we have wait3() */
 #undef NO_WAIT3
diff --git a/win/configure b/win/configure
index 0b07e9f..bad344c 100755
--- a/win/configure
+++ b/win/configure
@@ -4377,10 +4377,6 @@ else
 
   ZLIB_OBJS=\${ZLIB_OBJS}
 
-  cat >>confdefs.h <<_ACEOF
-#define NO_VIZ 1
-_ACEOF
-
 
 fi
 
diff --git a/win/configure.in b/win/configure.in
index b0c007a..574fce2 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -135,7 +135,6 @@ AS_IF([test "$tcl_ok" = "yes"], [
   ])
 ], [
   AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
-  AC_DEFINE_UNQUOTED(NO_VIZ, 1)
 ])
 AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
 
-- 
cgit v0.12


From 68d7745b270a3cd158d4f2140b321c3dfa3b0f5f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 5 Jun 2013 07:19:02 +0000
Subject: Stack cleanup works now even in the most evil expansion cases.

---
 generic/tclAssembly.c |   2 +-
 generic/tclCompCmds.c |  62 ++++++-----------------------
 generic/tclCompile.c  | 108 ++++++++++++++++++++++++++++++++++++++++++++++++--
 generic/tclCompile.h  |   7 ++++
 generic/tclExecute.c  |  11 ++---
 tests/for.test        |  30 ++++++++++++++
 6 files changed, 160 insertions(+), 60 deletions(-)

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 3d6abcf..365e647 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -493,40 +493,21 @@ TclCompileBreakCmd(
 
     rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	int toPop;
-
-	/*
-	 * Ditch the extra elements from the auxiliary stack.
-	 */
-
-	toPop = envPtr->expandCount - auxPtr->expandTarget;
-	while (toPop > 0) {
-	    TclEmitOpcode(INST_EXPAND_DROP, envPtr);
-	    toPop--;
-	}
-
-	/*
-	 * Pop off the extra stack frames.
-	 */
-
-	toPop = envPtr->currStackDepth - auxPtr->stackDepth;
-	while (toPop > 0) {
-	    TclEmitOpcode(INST_POP, envPtr);
-	    TclAdjustStackDepth(1, envPtr);
-	    toPop--;
-	}
-
 	/*
 	 * Found the target! No need for a nasty INST_BREAK here.
 	 */
 
+	TclCleanupStackForBreakContinue(envPtr, auxPtr);
 	TclAddLoopBreakFixup(envPtr, auxPtr);
     } else {
 	/*
-	 * Emit a break instruction.
+	 * Emit a real break.
 	 */
 
-	TclEmitOpcode(INST_BREAK, envPtr);
+	PushStringLiteral(envPtr, "");
+	TclEmitOpcode(INST_DUP, envPtr);
+	TclEmitInstInt4(INST_RETURN_IMM, TCL_BREAK, envPtr);
+	TclEmitInt4(0, envPtr);
     }
 
     /*
@@ -846,40 +827,21 @@ TclCompileContinueCmd(
 
     rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr);
     if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
-	int toPop;
-
-	/*
-	 * Ditch the extra elements from the auxiliary stack.
-	 */
-
-	toPop = envPtr->expandCount - auxPtr->expandTarget;
-	while (toPop > 0) {
-	    TclEmitOpcode(INST_EXPAND_DROP, envPtr);
-	    toPop--;
-	}
-
-	/*
-	 * Pop off the extra stack frames.
-	 */
-
-	toPop = envPtr->currStackDepth - auxPtr->stackDepth;
-	while (toPop > 0) {
-	    TclEmitOpcode(INST_POP, envPtr);
-	    TclAdjustStackDepth(1, envPtr);
-	    toPop--;
-	}
-
 	/*
 	 * Found the target! No need for a nasty INST_CONTINUE here.
 	 */
 
+	TclCleanupStackForBreakContinue(envPtr, auxPtr);
 	TclAddLoopContinueFixup(envPtr, auxPtr);
     } else {
 	/*
-	 * Emit a continue instruction.
+	 * Emit a real continue.
 	 */
 
-	TclEmitOpcode(INST_CONTINUE, envPtr);
+	PushStringLiteral(envPtr, "");
+	TclEmitOpcode(INST_DUP, envPtr);
+	TclEmitInstInt4(INST_RETURN_IMM, TCL_CONTINUE, envPtr);
+	TclEmitInt4(0, envPtr);
     }
 
     /*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index f8dd504..69517bc 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -541,7 +541,8 @@ InstructionDesc const tclInstructionTable[] = {
 	 * Stack: ... list1 list2 => ... [lconcat list1 list2] */
 
     {"expandDrop",       1,    0,          0,	{OPERAND_NONE}},
-	/* Drops an element from the auxiliary stack. */
+	/* Drops an element from the auxiliary stack, popping stack elements
+	 * until the matching stack depth is reached. */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
@@ -574,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,
@@ -2063,8 +2065,7 @@ TclCompileScript(
 	     */
 
 	    if (expand) {
-		TclEmitOpcode(INST_EXPAND_START, envPtr);
-		envPtr->expandCount++;
+		StartExpanding(envPtr);
 	    }
 
 	    /*
@@ -3469,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;
@@ -3589,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
@@ -3629,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 75de025..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. */
@@ -987,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 559df0b..fc50a74 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2720,14 +2720,15 @@ TEBCresume(
 
     case INST_EXPAND_DROP:
 	/*
-	 * Drops an element of the auxObjList. Does not do any clean up of the
-	 * actual stack.
-	 *
-	 * TODO: POP MAIN STACK BACK TO MARKER
+	 * 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_F(1, 0, 0);
+	NEXT_INST_V(1, objc, 0);
 
     case INST_EXPAND_STKTOP: {
 	int i;
diff --git a/tests/for.test b/tests/for.test
index cfba1fe..c5803ee 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -882,6 +882,36 @@ test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} m
 	expr {$end - $tmp}
     }}
 } 0
+test for-7.5 {Bug 3614226: ensure that break cleans up the 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 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
 
 # cleanup
 ::tcltest::cleanupTests
-- 
cgit v0.12


From a20873ddab1a6f399bde1e840c9f357dedea61eb Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 5 Jun 2013 07:51:06 +0000
Subject: Even better tests

---
 tests/for.test | 34 ++++++++++++++++++++++++++++++++--
 1 file changed, 32 insertions(+), 2 deletions(-)

diff --git a/tests/for.test b/tests/for.test
index c5803ee..8936682 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -882,7 +882,7 @@ test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} m
 	expr {$end - $tmp}
     }}
 } 0
-test for-7.5 {Bug 3614226: ensure that break cleans up the expansion stack} memory {
+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
@@ -897,7 +897,7 @@ test for-7.5 {Bug 3614226: ensure that break cleans up the expansion stack} memo
 	expr {$end - $tmp}
     }}
 } 0
-test for-7.6 {Bug 3614226: ensure that continue cleans up the expansion stack} memory {
+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
@@ -912,6 +912,36 @@ test for-7.6 {Bug 3614226: ensure that continue cleans up the expansion stack} m
 	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
-- 
cgit v0.12


From 3c76eb88e82efdc94d16741622d0f4f5c9148d05 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 5 Jun 2013 12:34:21 +0000
Subject: More cleaning up; factor out optimizer to new file. Some weird
 problems still.

---
 generic/tclCompCmds.c |  30 +++++----
 generic/tclCompile.c  | 174 +-------------------------------------------------
 generic/tclCompile.h  |   1 +
 unix/Makefile.in      |   6 +-
 win/Makefile.in       |   1 +
 win/makefile.bc       |   1 +
 win/makefile.vc       |   1 +
 7 files changed, 26 insertions(+), 188 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 365e647..8cb5fcd 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -499,6 +499,13 @@ TclCompileBreakCmd(
 
 	TclCleanupStackForBreakContinue(envPtr, auxPtr);
 	TclAddLoopBreakFixup(envPtr, auxPtr);
+
+	/*
+	 * Instructions that raise exceptions don't really have to follow the
+	 * usual stack management rules, but the cleanup code does.
+	 */
+
+	TclAdjustStackDepth(1, envPtr);
     } else {
 	/*
 	 * Emit a real break.
@@ -510,12 +517,6 @@ TclCompileBreakCmd(
 	TclEmitInt4(0, envPtr);
     }
 
-    /*
-     * Instructions that raise exceptions don't really have to follow the
-     * usual stack management rules, but the cleanup code does.
-     */
-
-    TclAdjustStackDepth(1, envPtr);
     return TCL_OK;
 }
 
@@ -833,6 +834,13 @@ TclCompileContinueCmd(
 
 	TclCleanupStackForBreakContinue(envPtr, auxPtr);
 	TclAddLoopContinueFixup(envPtr, auxPtr);
+
+	/*
+	 * Instructions that raise exceptions don't really have to follow the
+	 * usual stack management rules, but the cleanup code does.
+	 */
+
+	TclAdjustStackDepth(1, envPtr);
     } else {
 	/*
 	 * Emit a real continue.
@@ -844,12 +852,6 @@ TclCompileContinueCmd(
 	TclEmitInt4(0, envPtr);
     }
 
-    /*
-     * Instructions that raise exceptions don't really have to follow the
-     * usual stack management rules, but the cleanup code does.
-     */
-
-    TclAdjustStackDepth(1, envPtr);
     return TCL_OK;
 }
 
@@ -2121,10 +2123,10 @@ TclCompileDictWithCmd(
     TclEmitInstInt4(		INST_BEGIN_CATCH4, range,	envPtr);
 
     ExceptionRangeStarts(envPtr, range);
-    envPtr->currStackDepth++;
+    //envPtr->currStackDepth++;
     SetLineInformation(parsePtr->numWords-1);
     CompileBody(envPtr, tokenPtr, interp);
-    envPtr->currStackDepth = savedStackDepth;
+    //envPtr->currStackDepth = savedStackDepth;
     ExceptionRangeEnds(envPtr, range);
 
     /*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 69517bc..4a989c7 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -568,7 +568,6 @@ static void		FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
 static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
 static int		IsCompactibleCompileEnv(Tcl_Interp *interp,
 			    CompileEnv *envPtr);
-static void		PeepholeOptimize(CompileEnv *envPtr);
 #ifdef TCL_COMPILE_STATS
 static void		RecordByteCodeStats(ByteCode *codePtr);
 #endif /* TCL_COMPILE_STATS */
@@ -760,7 +759,7 @@ TclSetByteCodeFromAny(
      * instruction generator boundaries.
      */
 
-    PeepholeOptimize(&compEnv);
+    TclOptimizeBytecode(&compEnv);
 
     /*
      * Invoke the compilation hook procedure if one exists.
@@ -1102,177 +1101,6 @@ IsCompactibleCompileEnv(
 }
 
 /*
- * ----------------------------------------------------------------------
- *
- * PeepholeOptimize --
- *
- *	A very simple peephole optimizer for bytecode.
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-PeepholeOptimize(
-    CompileEnv *envPtr)
-{
-    unsigned char *pc, *prev1 = NULL, *prev2 = NULL, *target;
-    int size, isNew;
-    Tcl_HashTable targets;
-    Tcl_HashEntry *hPtr;
-    Tcl_HashSearch hSearch;
-
-    /*
-     * Find places where we should be careful about replacing instructions
-     * because they are the targets of various types of jumps.
-     */
-
-    Tcl_InitHashTable(&targets, TCL_ONE_WORD_KEYS);
-    for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
-	size = tclInstructionTable[*pc].numBytes;
-	switch (*pc) {
-	case INST_JUMP1:
-	case INST_JUMP_TRUE1:
-	case INST_JUMP_FALSE1:
-	    target = pc + TclGetInt1AtPtr(pc+1);
-	    goto storeTarget;
-	case INST_JUMP4:
-	case INST_JUMP_TRUE4:
-	case INST_JUMP_FALSE4:
-	    target = pc + TclGetInt4AtPtr(pc+1);
-	    goto storeTarget;
-	case INST_BEGIN_CATCH4:
-	    target = envPtr->codeStart + envPtr->exceptArrayPtr[
-		    TclGetUInt4AtPtr(pc+1)].codeOffset;
-	storeTarget:
-	    (void) Tcl_CreateHashEntry(&targets, (void *) target, &isNew);
-	    break;
-	case INST_JUMP_TABLE:
-	    hPtr = Tcl_FirstHashEntry(
-		    &JUMPTABLEINFO(envPtr, pc+1)->hashTable, &hSearch);
-	    for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) {
-		target = pc + PTR2INT(Tcl_GetHashValue(hPtr));
-		(void) Tcl_CreateHashEntry(&targets, (void *) target, &isNew);
-	    }
-	    break;
-	case INST_START_CMD:
-	    assert (envPtr->atCmdStart < 2);
-	}
-    }
-
-    /*
-     * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also replace
-     * PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an operation
-     * that guarantees the check for arithmeticity).
-     */
-
-    (void) Tcl_CreateHashEntry(&targets, (void *) pc, &isNew);
-    for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
-	int blank = 0, i, inst;
-
-	size = tclInstructionTable[*pc].numBytes;
-	prev2 = prev1;
-	prev1 = pc;
-	while (*(pc+size) == INST_NOP) {
-	    if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) {
-		break;
-	    }
-	    size += tclInstructionTable[INST_NOP].numBytes;
-	}
-	if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) {
-	    continue;
-	}
-	inst = *(pc + size);
-	switch (*pc) {
-	case INST_PUSH1:
-	    if (inst == INST_POP) {
-		blank = size + tclInstructionTable[inst].numBytes;
-	    } else if (inst == INST_CONCAT1
-		    && TclGetUInt1AtPtr(pc + size + 1) == 2) {
-		Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
-			TclGetUInt1AtPtr(pc + 1));
-		int numBytes;
-
-		(void) Tcl_GetStringFromObj(litPtr, &numBytes);
-		if (numBytes == 0) {
-		    blank = size + tclInstructionTable[inst].numBytes;
-		}
-	    }
-	    break;
-	case INST_PUSH4:
-	    if (inst == INST_POP) {
-		blank = size + 1;
-	    } else if (inst == INST_CONCAT1
-		    && TclGetUInt1AtPtr(pc + size + 1) == 2) {
-		Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
-			TclGetUInt4AtPtr(pc + 1));
-		int numBytes;
-
-		(void) Tcl_GetStringFromObj(litPtr, &numBytes);
-		if (numBytes == 0) {
-		    blank = size + tclInstructionTable[inst].numBytes;
-		}
-	    }
-	    break;
-	case INST_TRY_CVT_TO_NUMERIC:
-	    switch (inst) {
-	    case INST_JUMP_TRUE1:
-	    case INST_JUMP_TRUE4:
-	    case INST_JUMP_FALSE1:
-	    case INST_JUMP_FALSE4:
-	    case INST_INCR_SCALAR1:
-	    case INST_INCR_ARRAY1:
-	    case INST_INCR_ARRAY_STK:
-	    case INST_INCR_SCALAR_STK:
-	    case INST_INCR_STK:
-	    case INST_LOR:
-	    case INST_LAND:
-	    case INST_EQ:
-	    case INST_NEQ:
-	    case INST_LT:
-	    case INST_LE:
-	    case INST_GT:
-	    case INST_GE:
-	    case INST_MOD:
-	    case INST_LSHIFT:
-	    case INST_RSHIFT:
-	    case INST_BITOR:
-	    case INST_BITXOR:
-	    case INST_BITAND:
-	    case INST_EXPON:
-	    case INST_ADD:
-	    case INST_SUB:
-	    case INST_DIV:
-	    case INST_MULT:
-	    case INST_LNOT:
-	    case INST_BITNOT:
-	    case INST_UMINUS:
-	    case INST_UPLUS:
-	    case INST_TRY_CVT_TO_NUMERIC:
-		blank = size;
-		break;
-	    }
-	    break;
-	}
-	if (blank > 0) {
-	    for (i=0 ; i<blank ; i++) {
-		*(pc + i) = INST_NOP;
-	    }
-	    size = blank;
-	}
-    }
-
-    /*
-     * Trim a trailing double DONE.
-     */
-
-    if (prev1 && prev2 && *prev1 == INST_DONE && *prev2 == INST_DONE
-	    && !Tcl_FindHashEntry(&targets, (void *) prev1)) {
-	envPtr->codeNext--;
-    }
-    Tcl_DeleteHashTable(&targets);
-}
-
-/*
  *----------------------------------------------------------------------
  *
  * Tcl_SubstObj --
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 15b5477..fdb281b 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1060,6 +1060,7 @@ MODULE_SCOPE void	TclFinalizeLoopExceptionRange(CompileEnv *envPtr,
 MODULE_SCOPE char *	TclLiteralStats(LiteralTable *tablePtr);
 MODULE_SCOPE int	TclLog2(int value);
 #endif
+MODULE_SCOPE void	TclOptimizeBytecode(CompileEnv *envPtr);
 #ifdef TCL_COMPILE_DEBUG
 MODULE_SCOPE void	TclPrintByteCodeObj(Tcl_Interp *interp,
 			    Tcl_Obj *objPtr);
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 9bf8b43..3e4a6f6 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -301,7 +301,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
 	tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \
 	tclLink.o tclListObj.o \
 	tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
-	tclObj.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
+	tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
 	tclPkg.o tclPkgConfig.o tclPosixStr.o \
 	tclPreserve.o tclProc.o tclRegexp.o \
 	tclResolve.o tclResult.o tclScan.o tclStringObj.o \
@@ -429,6 +429,7 @@ GENERIC_SRCS = \
 	$(GENERIC_DIR)/tclNamesp.c \
 	$(GENERIC_DIR)/tclNotify.c \
 	$(GENERIC_DIR)/tclObj.c \
+	$(GENERIC_DIR)/tclOptimize.c \
 	$(GENERIC_DIR)/tclParse.c \
 	$(GENERIC_DIR)/tclPathObj.c \
 	$(GENERIC_DIR)/tclPipe.c \
@@ -1165,6 +1166,9 @@ tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR)
 tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS)
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c
 
+tclOptimize.o: $(GENERIC_DIR)/tclOptimize.c $(COMPILEHDR)
+	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOptimize.c
+
 tclLoad.o: $(GENERIC_DIR)/tclLoad.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLoad.c
 
diff --git a/win/Makefile.in b/win/Makefile.in
index 047b0b5..18993fe 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -267,6 +267,7 @@ GENERIC_OBJS = \
 	tclOOMethod.$(OBJEXT) \
 	tclOOStubInit.$(OBJEXT) \
 	tclObj.$(OBJEXT) \
+	tclOptimize.$(OBJEXT) \
 	tclPanic.$(OBJEXT) \
 	tclParse.$(OBJEXT) \
 	tclPathObj.$(OBJEXT) \
diff --git a/win/makefile.bc b/win/makefile.bc
index d148513..0b17cea 100644
--- a/win/makefile.bc
+++ b/win/makefile.bc
@@ -239,6 +239,7 @@ TCLOBJS	= \
 	$(TMPDIR)\tclOOMethod.obj \
 	$(TMPDIR)\tclOOStubInit.obj \
 	$(TMPDIR)\tclObj.obj \
+	$(TMPDIR)\tclOptimize.obj \
 	$(TMPDIR)\tclPanic.obj \
 	$(TMPDIR)\tclParse.obj \
 	$(TMPDIR)\tclPipe.obj \
diff --git a/win/makefile.vc b/win/makefile.vc
index 95d3a9d..cddb253 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -316,6 +316,7 @@ COREOBJS = \
 	$(TMP_DIR)\tclOOMethod.obj \
 	$(TMP_DIR)\tclOOStubInit.obj \
 	$(TMP_DIR)\tclObj.obj \
+	$(TMP_DIR)\tclOptimize.obj \
 	$(TMP_DIR)\tclPanic.obj \
 	$(TMP_DIR)\tclParse.obj \
 	$(TMP_DIR)\tclPathObj.obj \
-- 
cgit v0.12


From 3903b017ec703a6285ab0ef7a785569a50961315 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 5 Jun 2013 14:50:39 +0000
Subject: Stack Depth fixups.

---
 generic/tclCompCmds.c | 14 ++------------
 generic/tclExecute.c  |  2 ++
 2 files changed, 4 insertions(+), 12 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 365e647..10a789e 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -499,6 +499,7 @@ TclCompileBreakCmd(
 
 	TclCleanupStackForBreakContinue(envPtr, auxPtr);
 	TclAddLoopBreakFixup(envPtr, auxPtr);
+	TclAdjustStackDepth(1, envPtr);
     } else {
 	/*
 	 * Emit a real break.
@@ -510,12 +511,6 @@ TclCompileBreakCmd(
 	TclEmitInt4(0, envPtr);
     }
 
-    /*
-     * Instructions that raise exceptions don't really have to follow the
-     * usual stack management rules, but the cleanup code does.
-     */
-
-    TclAdjustStackDepth(1, envPtr);
     return TCL_OK;
 }
 
@@ -833,6 +828,7 @@ TclCompileContinueCmd(
 
 	TclCleanupStackForBreakContinue(envPtr, auxPtr);
 	TclAddLoopContinueFixup(envPtr, auxPtr);
+	TclAdjustStackDepth(1, envPtr);
     } else {
 	/*
 	 * Emit a real continue.
@@ -844,12 +840,6 @@ TclCompileContinueCmd(
 	TclEmitInt4(0, envPtr);
     }
 
-    /*
-     * Instructions that raise exceptions don't really have to follow the
-     * usual stack management rules, but the cleanup code does.
-     */
-
-    TclAdjustStackDepth(1, envPtr);
     return TCL_OK;
 }
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 98ce51e..6ee3cae 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2728,6 +2728,8 @@ TEBCresume(
 	CLANG_ASSERT(auxObjList);
 	objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
 	POP_TAUX_OBJ();
+	/* Ugly abuse! */
+	starting = 1;
 	NEXT_INST_V(1, objc, 0);
 
     case INST_EXPAND_STKTOP: {
-- 
cgit v0.12


From b2423f72cf51723ed50c77ec67b5a9cc74135e61 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 5 Jun 2013 15:07:40 +0000
Subject: Repair TCL_COMPILE_DEBUG guards

---
 generic/tclExecute.c | 12 +++++++-----
 1 file changed, 7 insertions(+), 5 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 6ee3cae..443fb85 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -257,7 +257,7 @@ VarHashCreateVar(
 
 /* Verify the stack depth, only when no expansion is in progress */
 
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
 #define CHECK_STACK()							\
     do {								\
 	ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH,			\
@@ -2630,7 +2630,7 @@ TEBCresume(
 		Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
 			INT_MAX);
 	    }
-#if !TCL_COMPILE_DEBUG
+#ifndef TCL_COMPILE_DEBUG
 	    if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
 		TclFreeIntRep(objResultPtr);
 		objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
@@ -2666,7 +2666,7 @@ TEBCresume(
 		Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
 			INT_MAX);
 	    }
-#if !TCL_COMPILE_DEBUG
+#ifndef TCL_COMPILE_DEBUG
 	    if (!Tcl_IsShared(objResultPtr)) {
 		bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
 			length + appendLen);
@@ -2728,8 +2728,10 @@ TEBCresume(
 	CLANG_ASSERT(auxObjList);
 	objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
 	POP_TAUX_OBJ();
+#ifdef TCL_COMPILE_DEBUG
 	/* Ugly abuse! */
 	starting = 1;
+#endif
 	NEXT_INST_V(1, objc, 0);
 
     case INST_EXPAND_STKTOP: {
@@ -6838,7 +6840,7 @@ TEBCresume(
 	 */
 
     processExceptionReturn:
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
 	switch (*pc) {
 	case INST_INVOKE_STK1:
 	    opnd = TclGetUInt1AtPtr(pc+1);
@@ -6895,7 +6897,7 @@ TEBCresume(
 		    rangePtr->codeOffset, rangePtr->continueOffset));
 	    NEXT_INST_F(0, 0, 0);
 	}
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
 	if (traceInstructions) {
 	    objPtr = Tcl_GetObjResult(interp);
 	    if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
-- 
cgit v0.12


From 270a615a09fcce9e731ef2fe90a6961957cda6e4 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 5 Jun 2013 20:55:29 +0000
Subject: Corrected wrong information about instruction width that was causing
 an optimizer crash.

---
 generic/tclCompile.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 4a989c7..572f660 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -431,7 +431,7 @@ InstructionDesc const tclInstructionTable[] = {
         /* Map variable contents back into a dictionary in a variable. Part of
          * [dict with].
 	 * Stack:  ... dictVarName path keyList => ... */
-    {"dictRecombineImm", 1,    -2,        1,    {OPERAND_LVT4}},
+    {"dictRecombineImm", 5,    -2,        1,    {OPERAND_LVT4}},
         /* Map variable contents back into a dictionary in the local variable
          * indicated by the LVT index. Part of [dict with].
 	 * Stack:  ... path keyList => ... */
-- 
cgit v0.12


From 5dad1c5205992ee2d4a31499121b7cf68c326251 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 5 Jun 2013 21:05:41 +0000
Subject: Added the optimizer...

---
 generic/tclOptimize.c | 287 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 287 insertions(+)
 create mode 100644 generic/tclOptimize.c

diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
new file mode 100644
index 0000000..18dc208
--- /dev/null
+++ b/generic/tclOptimize.c
@@ -0,0 +1,287 @@
+/*
+ * tclOptimize.c --
+ *
+ *	This file contains the bytecode optimizer.
+ *
+ * Copyright (c) 2013 by Donal Fellows.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+#include <assert.h>
+
+#define DefineTargetAddress(tablePtr, address) \
+    ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
+#define IsTargetAddress(tablePtr, address) \
+    (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
+
+static void
+LocateTargetAddresses(
+    CompileEnv *envPtr,
+    Tcl_HashTable *tablePtr)
+{
+    unsigned char *pc, *target;
+    int size, isNew, i;
+    Tcl_HashEntry *hPtr;
+    Tcl_HashSearch hSearch;
+
+    Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);
+
+    /*
+     * The starts of commands represent target addresses.
+     */
+
+    for (i=0 ; i<envPtr->numCommands ; i++) {
+	DefineTargetAddress(tablePtr,
+		envPtr->codeStart + envPtr->cmdMapPtr[i].codeOffset);
+    }
+
+    /*
+     * Find places where we should be careful about replacing instructions
+     * because they are the targets of various types of jumps.
+     */
+
+    for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
+	size = tclInstructionTable[*pc].numBytes;
+	switch (*pc) {
+	case INST_JUMP1:
+	case INST_JUMP_TRUE1:
+	case INST_JUMP_FALSE1:
+	    target = pc + TclGetInt1AtPtr(pc+1);
+	    goto storeTarget;
+	case INST_JUMP4:
+	case INST_JUMP_TRUE4:
+	case INST_JUMP_FALSE4:
+	    target = pc + TclGetInt4AtPtr(pc+1);
+	    goto storeTarget;
+	case INST_BEGIN_CATCH4:
+	    target = envPtr->codeStart + envPtr->exceptArrayPtr[
+		    TclGetUInt4AtPtr(pc+1)].codeOffset;
+	storeTarget:
+	    DefineTargetAddress(tablePtr, target);
+	    break;
+	case INST_JUMP_TABLE:
+	    hPtr = Tcl_FirstHashEntry(
+		    &JUMPTABLEINFO(envPtr, pc+1)->hashTable, &hSearch);
+	    for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) {
+		target = pc + PTR2INT(Tcl_GetHashValue(hPtr));
+		DefineTargetAddress(tablePtr, target);
+	    }
+	    break;
+	case INST_RETURN_CODE_BRANCH:
+	    for (i=TCL_ERROR ; i<TCL_CONTINUE+1 ; i++) {
+		DefineTargetAddress(tablePtr, pc + 2*i - 1);
+	    }
+	    break;
+	case INST_START_CMD:
+	    assert (envPtr->atCmdStart < 2);
+	}
+    }
+
+    /*
+     * Add a marker *after* the last bytecode instruction. WARNING: points to
+     * one past the end!
+     */
+
+    DefineTargetAddress(tablePtr, pc);
+
+    /*
+     * Enter in the targets of exception ranges.
+     */
+
+    for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+	ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+
+	if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
+	    target = envPtr->codeStart + rangePtr->catchOffset;
+	    DefineTargetAddress(tablePtr, target);
+	} else {
+	    target = envPtr->codeStart + rangePtr->breakOffset;
+	    DefineTargetAddress(tablePtr, target);
+	    if (rangePtr->continueOffset >= 0) {
+		target = envPtr->codeStart + rangePtr->continueOffset;
+		DefineTargetAddress(tablePtr, target);
+	    }
+	}
+    }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOptimizeBytecode --
+ *
+ *	A very simple peephole optimizer for bytecode.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOptimizeBytecode(
+    CompileEnv *envPtr)
+{
+    unsigned char *pc;
+    int size;
+    Tcl_HashTable targets;
+
+    /*
+     * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also replace
+     * PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an operation
+     * that guarantees the check for arithmeticity) and eliminate LNOT when we
+     * can invert the following JUMP condition.
+     */
+
+    LocateTargetAddresses(envPtr, &targets);
+    for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
+	int blank = 0, i, inst;
+
+	size = tclInstructionTable[*pc].numBytes;
+	while (*(pc+size) == INST_NOP) {
+	    if (IsTargetAddress(&targets, pc + size)) {
+		break;
+	    }
+	    size += tclInstructionTable[INST_NOP].numBytes;
+	}
+	if (IsTargetAddress(&targets, pc + size)) {
+	    continue;
+	}
+	inst = *(pc + size);
+	switch (*pc) {
+	case INST_PUSH1:
+	    if (inst == INST_POP) {
+		blank = size + tclInstructionTable[inst].numBytes;
+	    } else if (inst == INST_CONCAT1
+		    && TclGetUInt1AtPtr(pc + size + 1) == 2) {
+		Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
+			TclGetUInt1AtPtr(pc + 1));
+		int numBytes;
+
+		(void) Tcl_GetStringFromObj(litPtr, &numBytes);
+		if (numBytes == 0) {
+		    blank = size + tclInstructionTable[inst].numBytes;
+		}
+	    }
+	    break;
+	case INST_PUSH4:
+	    if (inst == INST_POP) {
+		blank = size + 1;
+	    } else if (inst == INST_CONCAT1
+		    && TclGetUInt1AtPtr(pc + size + 1) == 2) {
+		Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
+			TclGetUInt4AtPtr(pc + 1));
+		int numBytes;
+
+		(void) Tcl_GetStringFromObj(litPtr, &numBytes);
+		if (numBytes == 0) {
+		    blank = size + tclInstructionTable[inst].numBytes;
+		}
+	    }
+	    break;
+	case INST_LNOT:
+	    switch (inst) {
+	    case INST_JUMP_TRUE1:
+		blank = size;
+		*(pc + size) = INST_JUMP_FALSE1;
+		break;
+	    case INST_JUMP_FALSE1:
+		blank = size;
+		*(pc + size) = INST_JUMP_TRUE1;
+		break;
+	    case INST_JUMP_TRUE4:
+		blank = size;
+		*(pc + size) = INST_JUMP_FALSE4;
+		break;
+	    case INST_JUMP_FALSE4:
+		blank = size;
+		*(pc + size) = INST_JUMP_TRUE4;
+		break;
+	    }
+	    break;
+	case INST_TRY_CVT_TO_NUMERIC:
+	    switch (inst) {
+	    case INST_JUMP_TRUE1:
+	    case INST_JUMP_TRUE4:
+	    case INST_JUMP_FALSE1:
+	    case INST_JUMP_FALSE4:
+	    case INST_INCR_SCALAR1:
+	    case INST_INCR_ARRAY1:
+	    case INST_INCR_ARRAY_STK:
+	    case INST_INCR_SCALAR_STK:
+	    case INST_INCR_STK:
+	    case INST_LOR:
+	    case INST_LAND:
+	    case INST_EQ:
+	    case INST_NEQ:
+	    case INST_LT:
+	    case INST_LE:
+	    case INST_GT:
+	    case INST_GE:
+	    case INST_MOD:
+	    case INST_LSHIFT:
+	    case INST_RSHIFT:
+	    case INST_BITOR:
+	    case INST_BITXOR:
+	    case INST_BITAND:
+	    case INST_EXPON:
+	    case INST_ADD:
+	    case INST_SUB:
+	    case INST_DIV:
+	    case INST_MULT:
+	    case INST_LNOT:
+	    case INST_BITNOT:
+	    case INST_UMINUS:
+	    case INST_UPLUS:
+	    case INST_TRY_CVT_TO_NUMERIC:
+		blank = size;
+		break;
+	    }
+	    break;
+	}
+	if (blank > 0) {
+	    for (i=0 ; i<blank ; i++) {
+		*(pc + i) = INST_NOP;
+	    }
+	    size = blank;
+	}
+    }
+    Tcl_DeleteHashTable(&targets);
+
+    /*
+     * Trim unreachable instructions after a DONE.
+     */
+
+    LocateTargetAddresses(envPtr, &targets);
+    for (pc = envPtr->codeStart ; pc < envPtr->codeNext-1 ; pc += size) {
+	int clear = 0;
+
+	size = tclInstructionTable[*pc].numBytes;
+	if (*pc != INST_DONE) {
+	    continue;
+	}
+	assert (size == 1);
+	while (!IsTargetAddress(&targets, pc + 1 + clear)) {
+	    clear += tclInstructionTable[*(pc + 1 + clear)].numBytes;
+	}
+	if (pc + 1 + clear == envPtr->codeNext) {
+	    envPtr->codeNext -= clear;
+	} else {
+	    while (clear --> 0) {
+		*(pc + 1 + clear) = INST_NOP;
+	    }
+	}
+    }
+
+    Tcl_DeleteHashTable(&targets);
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
-- 
cgit v0.12


From 10ccda493663be68aa6504ade6479a54835604c6 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 5 Jun 2013 23:05:58 +0000
Subject: Added optimizing of jump-to-nop and jump-to-jump cases. Ta to AK for
 suggesting.

---
 generic/tclOptimize.c | 209 ++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 152 insertions(+), 57 deletions(-)

diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
index 18dc208..3e0d351 100644
--- a/generic/tclOptimize.c
+++ b/generic/tclOptimize.c
@@ -13,18 +13,45 @@
 #include "tclCompile.h"
 #include <assert.h>
 
+/*
+ * Forward declarations.
+ */
+
+static void		LocateTargetAddresses(CompileEnv *envPtr,
+			    Tcl_HashTable *tablePtr);
+
+/*
+ * Helper macros.
+ */
+
 #define DefineTargetAddress(tablePtr, address) \
     ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
 #define IsTargetAddress(tablePtr, address) \
     (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
+#define AddrLength(address) \
+    (tclInstructionTable[*(unsigned char *)(address)].numBytes)
+#define InstLength(instruction) \
+    (tclInstructionTable[(unsigned char)(instruction)].numBytes)
 
+/*
+ * ----------------------------------------------------------------------
+ *
+ * LocateTargetAddresses --
+ *
+ *	Populate a hash table with places that we need to be careful around
+ *	because they're the targets of various kinds of jumps and other
+ *	non-local behavior.
+ *
+ * ----------------------------------------------------------------------
+ */
+
 static void
 LocateTargetAddresses(
     CompileEnv *envPtr,
     Tcl_HashTable *tablePtr)
 {
-    unsigned char *pc, *target;
-    int size, isNew, i;
+    unsigned char *currentInstPtr, *targetInstPtr;
+    int isNew, i;
     Tcl_HashEntry *hPtr;
     Tcl_HashSearch hSearch;
 
@@ -44,36 +71,39 @@ LocateTargetAddresses(
      * because they are the targets of various types of jumps.
      */
 
-    for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
-	size = tclInstructionTable[*pc].numBytes;
-	switch (*pc) {
+    for (currentInstPtr = envPtr->codeStart ;
+	    currentInstPtr < envPtr->codeNext ;
+	    currentInstPtr += AddrLength(currentInstPtr)) {
+	switch (*currentInstPtr) {
 	case INST_JUMP1:
 	case INST_JUMP_TRUE1:
 	case INST_JUMP_FALSE1:
-	    target = pc + TclGetInt1AtPtr(pc+1);
+	    targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1);
 	    goto storeTarget;
 	case INST_JUMP4:
 	case INST_JUMP_TRUE4:
 	case INST_JUMP_FALSE4:
-	    target = pc + TclGetInt4AtPtr(pc+1);
+	    targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1);
 	    goto storeTarget;
 	case INST_BEGIN_CATCH4:
-	    target = envPtr->codeStart + envPtr->exceptArrayPtr[
-		    TclGetUInt4AtPtr(pc+1)].codeOffset;
+	    targetInstPtr = envPtr->codeStart + envPtr->exceptArrayPtr[
+		    TclGetUInt4AtPtr(currentInstPtr+1)].codeOffset;
 	storeTarget:
-	    DefineTargetAddress(tablePtr, target);
+	    DefineTargetAddress(tablePtr, targetInstPtr);
 	    break;
 	case INST_JUMP_TABLE:
 	    hPtr = Tcl_FirstHashEntry(
-		    &JUMPTABLEINFO(envPtr, pc+1)->hashTable, &hSearch);
+		    &JUMPTABLEINFO(envPtr, currentInstPtr+1)->hashTable,
+		    &hSearch);
 	    for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) {
-		target = pc + PTR2INT(Tcl_GetHashValue(hPtr));
-		DefineTargetAddress(tablePtr, target);
+		targetInstPtr = currentInstPtr +
+			PTR2INT(Tcl_GetHashValue(hPtr));
+		DefineTargetAddress(tablePtr, targetInstPtr);
 	    }
 	    break;
 	case INST_RETURN_CODE_BRANCH:
 	    for (i=TCL_ERROR ; i<TCL_CONTINUE+1 ; i++) {
-		DefineTargetAddress(tablePtr, pc + 2*i - 1);
+		DefineTargetAddress(tablePtr, currentInstPtr + 2*i - 1);
 	    }
 	    break;
 	case INST_START_CMD:
@@ -86,7 +116,7 @@ LocateTargetAddresses(
      * one past the end!
      */
 
-    DefineTargetAddress(tablePtr, pc);
+    DefineTargetAddress(tablePtr, currentInstPtr);
 
     /*
      * Enter in the targets of exception ranges.
@@ -96,14 +126,14 @@ LocateTargetAddresses(
 	ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
 
 	if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
-	    target = envPtr->codeStart + rangePtr->catchOffset;
-	    DefineTargetAddress(tablePtr, target);
+	    targetInstPtr = envPtr->codeStart + rangePtr->catchOffset;
+	    DefineTargetAddress(tablePtr, targetInstPtr);
 	} else {
-	    target = envPtr->codeStart + rangePtr->breakOffset;
-	    DefineTargetAddress(tablePtr, target);
+	    targetInstPtr = envPtr->codeStart + rangePtr->breakOffset;
+	    DefineTargetAddress(tablePtr, targetInstPtr);
 	    if (rangePtr->continueOffset >= 0) {
-		target = envPtr->codeStart + rangePtr->continueOffset;
-		DefineTargetAddress(tablePtr, target);
+		targetInstPtr = envPtr->codeStart + rangePtr->continueOffset;
+		DefineTargetAddress(tablePtr, targetInstPtr);
 	    }
 	}
     }
@@ -123,7 +153,7 @@ void
 TclOptimizeBytecode(
     CompileEnv *envPtr)
 {
-    unsigned char *pc;
+    unsigned char *currentInstPtr;
     int size;
     Tcl_HashTable targets;
 
@@ -135,73 +165,74 @@ TclOptimizeBytecode(
      */
 
     LocateTargetAddresses(envPtr, &targets);
-    for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
-	int blank = 0, i, inst;
+    for (currentInstPtr = envPtr->codeStart ;
+	    currentInstPtr < envPtr->codeNext ; currentInstPtr += size) {
+	int blank = 0, i, nextInst;
 
-	size = tclInstructionTable[*pc].numBytes;
-	while (*(pc+size) == INST_NOP) {
-	    if (IsTargetAddress(&targets, pc + size)) {
+	size = AddrLength(currentInstPtr);
+	while (*(currentInstPtr+size) == INST_NOP) {
+	    if (IsTargetAddress(&targets, currentInstPtr + size)) {
 		break;
 	    }
-	    size += tclInstructionTable[INST_NOP].numBytes;
+	    size += InstLength(INST_NOP);
 	}
-	if (IsTargetAddress(&targets, pc + size)) {
+	if (IsTargetAddress(&targets, currentInstPtr + size)) {
 	    continue;
 	}
-	inst = *(pc + size);
-	switch (*pc) {
+	nextInst = *(currentInstPtr + size);
+	switch (*currentInstPtr) {
 	case INST_PUSH1:
-	    if (inst == INST_POP) {
-		blank = size + tclInstructionTable[inst].numBytes;
-	    } else if (inst == INST_CONCAT1
-		    && TclGetUInt1AtPtr(pc + size + 1) == 2) {
+	    if (nextInst == INST_POP) {
+		blank = size + InstLength(nextInst);
+	    } else if (nextInst == INST_CONCAT1
+		    && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
 		Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
-			TclGetUInt1AtPtr(pc + 1));
+			TclGetUInt1AtPtr(currentInstPtr + 1));
 		int numBytes;
 
 		(void) Tcl_GetStringFromObj(litPtr, &numBytes);
 		if (numBytes == 0) {
-		    blank = size + tclInstructionTable[inst].numBytes;
+		    blank = size + InstLength(nextInst);
 		}
 	    }
 	    break;
 	case INST_PUSH4:
-	    if (inst == INST_POP) {
+	    if (nextInst == INST_POP) {
 		blank = size + 1;
-	    } else if (inst == INST_CONCAT1
-		    && TclGetUInt1AtPtr(pc + size + 1) == 2) {
+	    } else if (nextInst == INST_CONCAT1
+		    && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
 		Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
-			TclGetUInt4AtPtr(pc + 1));
+			TclGetUInt4AtPtr(currentInstPtr + 1));
 		int numBytes;
 
 		(void) Tcl_GetStringFromObj(litPtr, &numBytes);
 		if (numBytes == 0) {
-		    blank = size + tclInstructionTable[inst].numBytes;
+		    blank = size + InstLength(nextInst);
 		}
 	    }
 	    break;
 	case INST_LNOT:
-	    switch (inst) {
+	    switch (nextInst) {
 	    case INST_JUMP_TRUE1:
 		blank = size;
-		*(pc + size) = INST_JUMP_FALSE1;
+		*(currentInstPtr + size) = INST_JUMP_FALSE1;
 		break;
 	    case INST_JUMP_FALSE1:
 		blank = size;
-		*(pc + size) = INST_JUMP_TRUE1;
+		*(currentInstPtr + size) = INST_JUMP_TRUE1;
 		break;
 	    case INST_JUMP_TRUE4:
 		blank = size;
-		*(pc + size) = INST_JUMP_FALSE4;
+		*(currentInstPtr + size) = INST_JUMP_FALSE4;
 		break;
 	    case INST_JUMP_FALSE4:
 		blank = size;
-		*(pc + size) = INST_JUMP_TRUE4;
+		*(currentInstPtr + size) = INST_JUMP_TRUE4;
 		break;
 	    }
 	    break;
 	case INST_TRY_CVT_TO_NUMERIC:
-	    switch (inst) {
+	    switch (nextInst) {
 	    case INST_JUMP_TRUE1:
 	    case INST_JUMP_TRUE4:
 	    case INST_JUMP_FALSE1:
@@ -242,7 +273,7 @@ TclOptimizeBytecode(
 	}
 	if (blank > 0) {
 	    for (i=0 ; i<blank ; i++) {
-		*(pc + i) = INST_NOP;
+		*(currentInstPtr + i) = INST_NOP;
 	    }
 	    size = blank;
 	}
@@ -250,26 +281,90 @@ TclOptimizeBytecode(
     Tcl_DeleteHashTable(&targets);
 
     /*
+     * Advance jumps past NOPs and chained JUMPs.
+     */
+
+    for (currentInstPtr = envPtr->codeStart ;
+	    currentInstPtr < envPtr->codeNext-1 ;
+	    currentInstPtr += AddrLength(currentInstPtr)) {
+	int offset, delta;
+
+	switch (*currentInstPtr) {
+	case INST_JUMP1:
+	case INST_JUMP_TRUE1:
+	case INST_JUMP_FALSE1:
+	    offset = TclGetInt1AtPtr(currentInstPtr + 1);
+	    delta = 0;
+	advanceNext1:
+	    if (offset + delta == 0) {
+		continue;
+	    }	    
+	    if (offset + delta < -128 || offset + delta > 127) {
+		TclStoreInt1AtPtr(offset, currentInstPtr + 1);
+		continue;
+	    }
+	    offset += delta;
+	    switch (*(currentInstPtr + offset)) {
+	    case INST_NOP:
+		delta = InstLength(INST_NOP);
+		goto advanceNext1;
+	    case INST_JUMP1:
+		delta = TclGetInt1AtPtr(currentInstPtr + offset + 1);
+		goto advanceNext1;
+	    case INST_JUMP4:
+		delta = TclGetInt4AtPtr(currentInstPtr + offset + 1);
+		goto advanceNext1;
+	    default:
+		TclStoreInt1AtPtr(offset, currentInstPtr + 1);
+		continue;
+	    }
+	case INST_JUMP4:
+	case INST_JUMP_TRUE4:
+	case INST_JUMP_FALSE4:
+	    offset = TclGetInt4AtPtr(currentInstPtr + 1);
+	advanceNext4:
+	    if (offset == 0) {
+		continue;
+	    }
+	    switch (*(currentInstPtr + offset)) {
+	    case INST_NOP:
+		offset += InstLength(INST_NOP);
+		goto advanceNext4;
+	    case INST_JUMP1:
+		offset += TclGetInt1AtPtr(currentInstPtr + offset + 1);
+		goto advanceNext4;
+	    case INST_JUMP4:
+		offset += TclGetInt4AtPtr(currentInstPtr + offset + 1);
+		goto advanceNext4;
+	    default:
+		TclStoreInt4AtPtr(offset, currentInstPtr + 1);
+		continue;
+	    }
+	}
+    }
+
+    /*
      * Trim unreachable instructions after a DONE.
      */
 
     LocateTargetAddresses(envPtr, &targets);
-    for (pc = envPtr->codeStart ; pc < envPtr->codeNext-1 ; pc += size) {
+    for (currentInstPtr = envPtr->codeStart ;
+	    currentInstPtr < envPtr->codeNext-1 ;
+	    currentInstPtr += AddrLength(currentInstPtr)) {
 	int clear = 0;
 
-	size = tclInstructionTable[*pc].numBytes;
-	if (*pc != INST_DONE) {
+	if (*currentInstPtr != INST_DONE) {
 	    continue;
 	}
-	assert (size == 1);
-	while (!IsTargetAddress(&targets, pc + 1 + clear)) {
-	    clear += tclInstructionTable[*(pc + 1 + clear)].numBytes;
+
+	while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) {
+	    clear += AddrLength(currentInstPtr + 1 + clear);
 	}
-	if (pc + 1 + clear == envPtr->codeNext) {
+	if (currentInstPtr + 1 + clear == envPtr->codeNext) {
 	    envPtr->codeNext -= clear;
 	} else {
 	    while (clear --> 0) {
-		*(pc + 1 + clear) = INST_NOP;
+		*(currentInstPtr + 1 + clear) = INST_NOP;
 	    }
 	}
     }
-- 
cgit v0.12


From 68dfdc609ede987fc55db47adc64c8cd0f3204fa Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 6 Jun 2013 06:53:55 +0000
Subject: Split the optimizer up. Remove the dreaded 'goto' from which doesn't
 need it.

---
 generic/tclOptimize.c | 208 ++++++++++++++++++++++++++++++--------------------
 1 file changed, 127 insertions(+), 81 deletions(-)

diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
index 3e0d351..7d4226e 100644
--- a/generic/tclOptimize.c
+++ b/generic/tclOptimize.c
@@ -17,8 +17,11 @@
  * Forward declarations.
  */
 
+static void		AdvanceJumps(CompileEnv *envPtr);
+static void		ConvertZeroEffectToNOP(CompileEnv *envPtr);
 static void		LocateTargetAddresses(CompileEnv *envPtr,
 			    Tcl_HashTable *tablePtr);
+static void		TrimUnreachable(CompileEnv *envPtr);
 
 /*
  * Helper macros.
@@ -142,27 +145,67 @@ LocateTargetAddresses(
 /*
  * ----------------------------------------------------------------------
  *
- * TclOptimizeBytecode --
+ * TrimUnreachable --
  *
- *	A very simple peephole optimizer for bytecode.
+ *	Converts code that provably can't be executed into NOPs and reduces
+ *	the overall reported length of the bytecode where that is possible.
  *
  * ----------------------------------------------------------------------
  */
 
-void
-TclOptimizeBytecode(
+static void
+TrimUnreachable(
     CompileEnv *envPtr)
 {
     unsigned char *currentInstPtr;
-    int size;
     Tcl_HashTable targets;
 
-    /*
-     * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also replace
-     * PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an operation
-     * that guarantees the check for arithmeticity) and eliminate LNOT when we
-     * can invert the following JUMP condition.
-     */
+    LocateTargetAddresses(envPtr, &targets);
+
+    for (currentInstPtr = envPtr->codeStart ;
+	    currentInstPtr < envPtr->codeNext-1 ;
+	    currentInstPtr += AddrLength(currentInstPtr)) {
+	int clear = 0;
+
+	if (*currentInstPtr != INST_DONE) {
+	    continue;
+	}
+
+	while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) {
+	    clear += AddrLength(currentInstPtr + 1 + clear);
+	}
+	if (currentInstPtr + 1 + clear == envPtr->codeNext) {
+	    envPtr->codeNext -= clear;
+	} else {
+	    while (clear --> 0) {
+		*(currentInstPtr + 1 + clear) = INST_NOP;
+	    }
+	}
+    }
+
+    Tcl_DeleteHashTable(&targets);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ConvertZeroEffectToNOP --
+ *
+ *	Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also
+ *	replace PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an
+ *	operation that guarantees the check for arithmeticity) and eliminate
+ *	LNOT when we can invert the following JUMP condition.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ConvertZeroEffectToNOP(
+    CompileEnv *envPtr)
+{
+    unsigned char *currentInstPtr;
+    int size;
+    Tcl_HashTable targets;
 
     LocateTargetAddresses(envPtr, &targets);
     for (currentInstPtr = envPtr->codeStart ;
@@ -211,6 +254,7 @@ TclOptimizeBytecode(
 		}
 	    }
 	    break;
+
 	case INST_LNOT:
 	    switch (nextInst) {
 	    case INST_JUMP_TRUE1:
@@ -231,6 +275,7 @@ TclOptimizeBytecode(
 		break;
 	    }
 	    break;
+
 	case INST_TRY_CVT_TO_NUMERIC:
 	    switch (nextInst) {
 	    case INST_JUMP_TRUE1:
@@ -271,6 +316,7 @@ TclOptimizeBytecode(
 	    }
 	    break;
 	}
+
 	if (blank > 0) {
 	    for (i=0 ; i<blank ; i++) {
 		*(currentInstPtr + i) = INST_NOP;
@@ -279,10 +325,25 @@ TclOptimizeBytecode(
 	}
     }
     Tcl_DeleteHashTable(&targets);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AdvanceJumps --
+ *
+ *	Advance jumps past NOPs and chained JUMPs. After this runs, the only
+ *	JUMPs that jump to a NOP or a JUMP will be length-1 ones that run out
+ *	of room in their opcode to be targeted to where they really belong.
+ *
+ * ----------------------------------------------------------------------
+ */
 
-    /*
-     * Advance jumps past NOPs and chained JUMPs.
-     */
+static void
+AdvanceJumps(
+    CompileEnv *envPtr)
+{
+    unsigned char *currentInstPtr;
 
     for (currentInstPtr = envPtr->codeStart ;
 	    currentInstPtr < envPtr->codeNext-1 ;
@@ -294,82 +355,67 @@ TclOptimizeBytecode(
 	case INST_JUMP_TRUE1:
 	case INST_JUMP_FALSE1:
 	    offset = TclGetInt1AtPtr(currentInstPtr + 1);
-	    delta = 0;
-	advanceNext1:
-	    if (offset + delta == 0) {
-		continue;
-	    }	    
-	    if (offset + delta < -128 || offset + delta > 127) {
-		TclStoreInt1AtPtr(offset, currentInstPtr + 1);
-		continue;
-	    }
-	    offset += delta;
-	    switch (*(currentInstPtr + offset)) {
-	    case INST_NOP:
-		delta = InstLength(INST_NOP);
-		goto advanceNext1;
-	    case INST_JUMP1:
-		delta = TclGetInt1AtPtr(currentInstPtr + offset + 1);
-		goto advanceNext1;
-	    case INST_JUMP4:
-		delta = TclGetInt4AtPtr(currentInstPtr + offset + 1);
-		goto advanceNext1;
-	    default:
-		TclStoreInt1AtPtr(offset, currentInstPtr + 1);
-		continue;
+	    for (delta=0 ; offset+delta != 0 ;) {
+		if (offset + delta < -128 || offset + delta > 127) {
+		    break;
+		}
+		offset += delta;
+		switch (*(currentInstPtr + offset)) {
+		case INST_NOP:
+		    delta = InstLength(INST_NOP);
+		    continue;
+		case INST_JUMP1:
+		    delta = TclGetInt1AtPtr(currentInstPtr + offset + 1);
+		    continue;
+		case INST_JUMP4:
+		    delta = TclGetInt4AtPtr(currentInstPtr + offset + 1);
+		    continue;
+		}
+		break;
 	    }
+	    TclStoreInt1AtPtr(offset, currentInstPtr + 1);
+	    continue;
+
 	case INST_JUMP4:
 	case INST_JUMP_TRUE4:
 	case INST_JUMP_FALSE4:
-	    offset = TclGetInt4AtPtr(currentInstPtr + 1);
-	advanceNext4:
-	    if (offset == 0) {
-		continue;
-	    }
-	    switch (*(currentInstPtr + offset)) {
-	    case INST_NOP:
-		offset += InstLength(INST_NOP);
-		goto advanceNext4;
-	    case INST_JUMP1:
-		offset += TclGetInt1AtPtr(currentInstPtr + offset + 1);
-		goto advanceNext4;
-	    case INST_JUMP4:
-		offset += TclGetInt4AtPtr(currentInstPtr + offset + 1);
-		goto advanceNext4;
-	    default:
-		TclStoreInt4AtPtr(offset, currentInstPtr + 1);
-		continue;
+	    for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {
+		switch (*(currentInstPtr + offset)) {
+		case INST_NOP:
+		    offset += InstLength(INST_NOP);
+		    continue;
+		case INST_JUMP1:
+		    offset += TclGetInt1AtPtr(currentInstPtr + offset + 1);
+		    continue;
+		case INST_JUMP4:
+		    offset += TclGetInt4AtPtr(currentInstPtr + offset + 1);
+		    continue;
+		}
+		break;
 	    }
-	}
-    }
-
-    /*
-     * Trim unreachable instructions after a DONE.
-     */
-
-    LocateTargetAddresses(envPtr, &targets);
-    for (currentInstPtr = envPtr->codeStart ;
-	    currentInstPtr < envPtr->codeNext-1 ;
-	    currentInstPtr += AddrLength(currentInstPtr)) {
-	int clear = 0;
-
-	if (*currentInstPtr != INST_DONE) {
+	    TclStoreInt4AtPtr(offset, currentInstPtr + 1);
 	    continue;
 	}
-
-	while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) {
-	    clear += AddrLength(currentInstPtr + 1 + clear);
-	}
-	if (currentInstPtr + 1 + clear == envPtr->codeNext) {
-	    envPtr->codeNext -= clear;
-	} else {
-	    while (clear --> 0) {
-		*(currentInstPtr + 1 + clear) = INST_NOP;
-	    }
-	}
     }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOptimizeBytecode --
+ *
+ *	A very simple peephole optimizer for bytecode.
+ *
+ * ----------------------------------------------------------------------
+ */
 
-    Tcl_DeleteHashTable(&targets);
+void
+TclOptimizeBytecode(
+    CompileEnv *envPtr)
+{
+    ConvertZeroEffectToNOP(envPtr);
+    AdvanceJumps(envPtr);
+    TrimUnreachable(envPtr);
 }
 
 /*
-- 
cgit v0.12


From ab224ed8ee1ef3aa3094c0b648af2c73c707b277 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 6 Jun 2013 06:56:20 +0000
Subject: Minor grammar fix.

---
 generic/tclCompile.h | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index fdb281b..908dceb 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -122,9 +122,9 @@ typedef struct ExceptionAux {
 				 * 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. */
+				 * if there 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. */
-- 
cgit v0.12


From a989f1616a003dc369ba3623ec686c09575b314c Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 6 Jun 2013 14:24:35 +0000
Subject: 3614360 Repair stack demands of optimized compiled [return LITERAL].

---
 generic/tclCompCmdsGR.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index d101d82..5e3d456 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -2471,6 +2471,7 @@ TclCompileReturnCmd(
 
 	    Tcl_DecrRefCount(returnOpts);
 	    TclEmitOpcode(INST_DONE, envPtr);
+	    TclAdjustStackDepth(1, envPtr);
 	    return TCL_OK;
 	}
     }
-- 
cgit v0.12


From a8ee0b7831707680fc6fb80cb066c0bf7eb1991a Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 6 Jun 2013 16:55:08 +0000
Subject: 3614382 Fix stack management of compiled [dict for] by shifting
 limits of the catch range.

---
 generic/tclCompCmds.c | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 7324360..92dfcb4 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -1496,9 +1496,6 @@ CompileDictEachCmd(
      */
 
     CompileWord(envPtr, dictTokenPtr, interp, 3);
-    TclEmitInstInt4(	INST_DICT_FIRST, infoIndex,		envPtr);
-    emptyTargetOffset = CurrentOffset(envPtr);
-    TclEmitInstInt4(	INST_JUMP_TRUE4, 0,			envPtr);
 
     /*
      * Now we catch errors from here on so that we can finalize the search
@@ -1509,6 +1506,10 @@ CompileDictEachCmd(
     TclEmitInstInt4(	INST_BEGIN_CATCH4, catchRange,		envPtr);
     ExceptionRangeStarts(envPtr, catchRange);
 
+    TclEmitInstInt4(	INST_DICT_FIRST, infoIndex,		envPtr);
+    emptyTargetOffset = CurrentOffset(envPtr);
+    TclEmitInstInt4(	INST_JUMP_TRUE4, 0,			envPtr);
+
     /*
      * Inside the iteration, write the loop variables.
      */
-- 
cgit v0.12


From b5c0305e8b1bb9b81de47bddfc616f989e301597 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 6 Jun 2013 21:01:04 +0000
Subject: More efficient instruction sequence for [dict for] with correct
 exception depth handling.

---
 generic/tclCompCmds.c | 33 ++++++++++-----------------------
 tests/dict.test       | 18 ++++++++++++++++++
 2 files changed, 28 insertions(+), 23 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 92dfcb4..86e9987 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -1560,24 +1560,8 @@ CompileDictEachCmd(
     TclEmitInstInt4(	INST_DICT_NEXT, infoIndex,		envPtr);
     jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
     TclEmitInstInt4(	INST_JUMP_FALSE4, jumpDisplacement,	envPtr);
-    TclEmitOpcode(	INST_POP,				envPtr);
-    TclEmitOpcode(	INST_POP,				envPtr);
-
-    /*
-     * Now do the final cleanup for the no-error case (this is where we break
-     * out of the loop to) by force-terminating the iteration (if not already
-     * terminated), ditching the exception info and jumping to the last
-     * instruction for this command. In theory, this could be done using the
-     * "finally" clause (next generated) but this is faster.
-     */
-
-    ExceptionRangeTarget(envPtr, loopRange, breakOffset);
-    TclFinalizeLoopExceptionRange(envPtr, loopRange);
-    TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
-    TclEmitInt4(		infoIndex,			envPtr);
-    TclEmitOpcode(	INST_END_CATCH,				envPtr);
     endTargetOffset = CurrentOffset(envPtr);
-    TclEmitInstInt4(	INST_JUMP4, 0,				envPtr);
+    TclEmitInstInt1(	INST_JUMP1, 0,				envPtr);
 
     /*
      * Error handler "finally" clause, which force-terminates the iteration
@@ -1587,9 +1571,9 @@ CompileDictEachCmd(
     ExceptionRangeTarget(envPtr, catchRange, catchOffset);
     TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
     TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
+    TclEmitOpcode(	INST_END_CATCH,				envPtr);
     TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
     TclEmitInt4(		infoIndex,			envPtr);
-    TclEmitOpcode(	INST_END_CATCH,				envPtr);
     if (collect == TCL_EACH_COLLECT) {
 	TclEmitInstInt1(INST_UNSET_SCALAR, 0,			envPtr);
 	TclEmitInt4(		collectVar,			envPtr);
@@ -1606,10 +1590,14 @@ CompileDictEachCmd(
     jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
     TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
 	    envPtr->codeStart + emptyTargetOffset);
+    jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
+    TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement,
+	    envPtr->codeStart + endTargetOffset);
     TclEmitOpcode(	INST_POP,				envPtr);
     TclEmitOpcode(	INST_POP,				envPtr);
-    TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
-    TclEmitInt4(		infoIndex,			envPtr);
+    ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+    TclFinalizeLoopExceptionRange(envPtr, loopRange);
+    TclEmitOpcode(	INST_END_CATCH,				envPtr);
 
     /*
      * Final stage of the command (normal case) is that we push an empty
@@ -1617,9 +1605,8 @@ CompileDictEachCmd(
      * last to promote peephole optimization when it's dropped immediately.
      */
 
-    jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
-    TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
-	    envPtr->codeStart + endTargetOffset);
+    TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
+    TclEmitInt4(		infoIndex,			envPtr);
     if (collect == TCL_EACH_COLLECT) {
 	Emit14Inst(	INST_LOAD_SCALAR, collectVar,		envPtr);
 	TclEmitInstInt1(INST_UNSET_SCALAR, 0,			envPtr);
diff --git a/tests/dict.test b/tests/dict.test
index 72a336c..02c9050 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -668,6 +668,24 @@ test dict-14.20 {dict for stack space compilation: bug 1903325} {
 	concat "c=$y,$args"
     }} {} 1 2 3
 } {c=1,2 3}
+test dict-14.21 {compiled dict for and break} {
+    apply {{} {
+	dict for {a b} {c d e f} {
+	    lappend result $a,$b
+	    break
+	}
+	return $result
+    }}
+} c,d
+test dict-14.22 {dict for and exception range depths: Bug 3614382} {
+    apply {{} {
+	dict for {a b} {c d} {
+	    dict for {e f} {g h} {
+		return 5
+	    }
+	}
+    }}
+} 5
 # There's probably a lot more tests to add here. Really ought to use a
 # coverage tool for this job...
 
-- 
cgit v0.12


From 849acd6e9674a2eb0174d2d519c813c4d5d6778a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 7 Jun 2013 12:48:58 +0000
Subject: Simplify stack depth management.

---
 generic/tclCompCmds.c | 64 ++++++++++++++++++++++++++-------------------------
 1 file changed, 33 insertions(+), 31 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 86e9987..2c1198d 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -1630,7 +1630,6 @@ TclCompileDictUpdateCmd(
     const char *name;
     int i, nameChars, dictIndex, numVars, range, infoIndex;
     Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
-    int savedStackDepth = envPtr->currStackDepth;
     DictUpdateInfo *duiPtr;
     JumpFixup jumpFixup;
 
@@ -1660,16 +1659,16 @@ TclCompileDictUpdateCmd(
 
     dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
     if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+	goto issueFallback;
     }
     name = dictVarTokenPtr[1].start;
     nameChars = dictVarTokenPtr[1].size;
     if (!TclIsLocalScalar(name, nameChars)) {
-	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+	goto issueFallback;
     }
     dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
     if (dictIndex < 0) {
-	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+	goto issueFallback;
     }
 
     /*
@@ -1680,8 +1679,7 @@ TclCompileDictUpdateCmd(
 
     duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
     duiPtr->length = numVars;
-    keyTokenPtrs = TclStackAlloc(interp,
-	    sizeof(Tcl_Token *) * numVars);
+    keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
     tokenPtr = TokenAfter(dictVarTokenPtr);
 
     for (i=0 ; i<numVars ; i++) {
@@ -1717,10 +1715,7 @@ TclCompileDictUpdateCmd(
 	tokenPtr = TokenAfter(tokenPtr);
     }
     if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-    failedUpdateInfoAssembly:
-	ckfree(duiPtr);
-	TclStackFree(interp, keyTokenPtrs);
-	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+	goto failedUpdateInfoAssembly;
     }
     bodyTokenPtr = tokenPtr;
 
@@ -1736,16 +1731,14 @@ TclCompileDictUpdateCmd(
     }
     TclEmitInstInt4(	INST_LIST, numVars,			envPtr);
     TclEmitInstInt4(	INST_DICT_UPDATE_START, dictIndex,	envPtr);
-    TclEmitInt4(	infoIndex,				envPtr);
+    TclEmitInt4(		infoIndex,			envPtr);
 
     range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     TclEmitInstInt4(	INST_BEGIN_CATCH4, range,		envPtr);
 
     ExceptionRangeStarts(envPtr, range);
-    envPtr->currStackDepth++;
     SetLineInformation(parsePtr->numWords - 1);
     CompileBody(envPtr, bodyTokenPtr, interp);
-    envPtr->currStackDepth = savedStackDepth;
     ExceptionRangeEnds(envPtr, range);
 
     /*
@@ -1756,7 +1749,7 @@ TclCompileDictUpdateCmd(
     TclEmitOpcode(	INST_END_CATCH,				envPtr);
     TclEmitInstInt4(	INST_REVERSE, 2,			envPtr);
     TclEmitInstInt4(	INST_DICT_UPDATE_END, dictIndex,	envPtr);
-    TclEmitInt4(	infoIndex,				envPtr);
+    TclEmitInt4(		infoIndex,			envPtr);
 
     /*
      * Jump around the exceptional termination code.
@@ -1777,7 +1770,7 @@ TclCompileDictUpdateCmd(
     TclEmitInstInt4(	INST_REVERSE, 3,			envPtr);
 
     TclEmitInstInt4(	INST_DICT_UPDATE_END, dictIndex,	envPtr);
-    TclEmitInt4(	infoIndex,				envPtr);
+    TclEmitInt4(		infoIndex,			envPtr);
     TclEmitOpcode(	INST_RETURN_STK,			envPtr);
 
     if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
@@ -1785,8 +1778,17 @@ TclCompileDictUpdateCmd(
 		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
     }
     TclStackFree(interp, keyTokenPtrs);
-    envPtr->currStackDepth = savedStackDepth + 1;
     return TCL_OK;
+
+    /*
+     * Clean up after a failure to create the DictUpdateInfo structure.
+     */
+
+  failedUpdateInfoAssembly:
+    ckfree(duiPtr);
+    TclStackFree(interp, keyTokenPtrs);
+  issueFallback:
+    return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 }
 
 int
@@ -1875,6 +1877,10 @@ TclCompileDictLappendCmd(
 	return TCL_ERROR;
     }
 
+    /*
+     * Parse the arguments.
+     */
+
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
     keyTokenPtr = TokenAfter(varTokenPtr);
     valueTokenPtr = TokenAfter(keyTokenPtr);
@@ -1890,6 +1896,11 @@ TclCompileDictLappendCmd(
     if (dictVarIndex < 0) {
 	return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
     }
+
+    /*
+     * Issue the implementation.
+     */
+
     CompileWord(envPtr, keyTokenPtr, interp, 3);
     CompileWord(envPtr, valueTokenPtr, interp, 4);
     TclEmitInstInt4(	INST_DICT_LAPPEND, dictVarIndex,	envPtr);
@@ -1906,10 +1917,9 @@ TclCompileDictWithCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     DefineLineInformation;	/* TIP #280 */
-    int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1;
+    int i, range, varNameTmp = -1, pathTmp, keysTmp, gotPath, dictVar = -1;
     int bodyIsEmpty = 1;
     Tcl_Token *varTokenPtr, *tokenPtr;
-    int savedStackDepth = envPtr->currStackDepth;
     JumpFixup jumpFixup;
     const char *ptr, *end;
 
@@ -1988,7 +1998,6 @@ TclCompileDictWithCmd(
 		TclEmitInstInt4(INST_OVER, 1,			envPtr);
 		TclEmitOpcode(	INST_DICT_EXPAND,		envPtr);
 		TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
-		PushStringLiteral(envPtr, "");
 	    } else {
 		/*
 		 * Case: Direct dict in LVT with empty body.
@@ -1999,7 +2008,6 @@ TclCompileDictWithCmd(
 		PushStringLiteral(envPtr, "");
 		TclEmitOpcode(	INST_DICT_EXPAND,		envPtr);
 		TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
-		PushStringLiteral(envPtr, "");
 	    }
 	} else {
 	    if (gotPath) {
@@ -2018,7 +2026,6 @@ TclCompileDictWithCmd(
 		TclEmitInstInt4(INST_OVER, 1,			envPtr);
 		TclEmitOpcode(	INST_DICT_EXPAND,		envPtr);
 		TclEmitOpcode(	INST_DICT_RECOMBINE_STK,	envPtr);
-		PushStringLiteral(envPtr, "");
 	    } else {
 		/*
 		 * Case: Direct dict in non-simple var with empty body.
@@ -2032,10 +2039,9 @@ TclCompileDictWithCmd(
 		PushStringLiteral(envPtr, "");
 		TclEmitInstInt4(INST_REVERSE, 2,		envPtr);
 		TclEmitOpcode(	INST_DICT_RECOMBINE_STK,	envPtr);
-		PushStringLiteral(envPtr, "");
 	    }
 	}
-	envPtr->currStackDepth = savedStackDepth + 1;
+	PushStringLiteral(envPtr, "");
 	return TCL_OK;
     }
 
@@ -2049,8 +2055,6 @@ TclCompileDictWithCmd(
 
     if (dictVar == -1) {
 	varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-    } else {
-	varNameTmp = -1;
     }
     if (gotPath) {
 	pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
@@ -2063,7 +2067,7 @@ TclCompileDictWithCmd(
      * Issue instructions. First, the part to expand the dictionary.
      */
 
-    if (varNameTmp > -1) {
+    if (dictVar == -1) {
 	CompileWord(envPtr, varTokenPtr, interp, 0);
 	Emit14Inst(		INST_STORE_SCALAR, varNameTmp,	envPtr);
     }
@@ -2108,7 +2112,7 @@ TclCompileDictWithCmd(
      */
 
     TclEmitOpcode(		INST_END_CATCH,			envPtr);
-    if (varNameTmp > -1) {
+    if (dictVar == -1) {
 	Emit14Inst(		INST_LOAD_SCALAR, varNameTmp,	envPtr);
     }
     if (gotPath) {
@@ -2128,11 +2132,12 @@ TclCompileDictWithCmd(
      * Now fold the results back into the dictionary in the exception case.
      */
 
+    TclAdjustStackDepth(-1, envPtr);
     ExceptionRangeTarget(envPtr, range, catchOffset);
     TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
     TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
     TclEmitOpcode(		INST_END_CATCH,			envPtr);
-    if (varNameTmp > -1) {
+    if (dictVar == -1) {
 	Emit14Inst(		INST_LOAD_SCALAR, varNameTmp,	envPtr);
     }
     if (parsePtr->numWords > 3) {
@@ -2152,7 +2157,6 @@ TclCompileDictWithCmd(
      * Prepare for the start of the next command.
      */
 
-    envPtr->currStackDepth = savedStackDepth + 1;
     if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
 	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
 		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
@@ -2252,7 +2256,6 @@ TclCompileErrorCmd(
      * However, we only deal with the case where there is just a message.
      */
     Tcl_Token *messageTokenPtr;
-    int savedStackDepth = envPtr->currStackDepth;
     DefineLineInformation;	/* TIP #280 */
 
     if (parsePtr->numWords != 2) {
@@ -2263,7 +2266,6 @@ TclCompileErrorCmd(
     PushStringLiteral(envPtr, "-code error -level 0");
     CompileWord(envPtr, messageTokenPtr, interp, 1);
     TclEmitOpcode(INST_RETURN_STK, envPtr);
-    envPtr->currStackDepth = savedStackDepth + 1;
     return TCL_OK;
 }
 
-- 
cgit v0.12


From 854eec9e0feb5fc76d5cf1b8b372bd0118b0e454 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 8 Jun 2013 13:17:26 +0000
Subject: Factor out stereotypical ways of getting variable indices.

---
 generic/tclCompCmds.c   | 189 ++++++++++--------------------------------------
 generic/tclCompCmdsSZ.c |  20 +++--
 generic/tclCompile.h    |  14 ++++
 3 files changed, 63 insertions(+), 160 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 2c1198d..25c4bac 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -317,10 +317,10 @@ TclCompileArraySetCmd(
      * Prepare for the internal foreach.
      */
 
-    dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-    iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-    keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-    valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    dataVar = AnonymousLocal(envPtr);
+    iterVar = AnonymousLocal(envPtr);
+    keyVar = AnonymousLocal(envPtr);
+    valVar = AnonymousLocal(envPtr);
 
     infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
     infoPtr->numLists = 1;
@@ -543,8 +543,7 @@ TclCompileCatchCmd(
 {
     JumpFixup jumpFixup;
     Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
-    const char *name;
-    int resultIndex, optsIndex, nameChars, range;
+    int resultIndex, optsIndex, range;
     int initStackDepth = envPtr->currStackDepth;
     int savedStackDepth;
     DefineLineInformation;	/* TIP #280 */
@@ -577,17 +576,7 @@ TclCompileCatchCmd(
     if (parsePtr->numWords >= 3) {
 	resultNameTokenPtr = TokenAfter(cmdTokenPtr);
 	/* DGP */
-	if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	    return TCL_ERROR;
-	}
-
-	name = resultNameTokenPtr[1].start;
-	nameChars = resultNameTokenPtr[1].size;
-	if (!TclIsLocalScalar(name, nameChars)) {
-	    return TCL_ERROR;
-	}
-	resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
-		resultNameTokenPtr[1].size, /*create*/ 1, envPtr);
+	resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr);
 	if (resultIndex < 0) {
 	    return TCL_ERROR;
 	}
@@ -595,16 +584,7 @@ TclCompileCatchCmd(
 	/* DKF */
 	if (parsePtr->numWords == 4) {
 	    optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
-	    if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-		return TCL_ERROR;
-	    }
-	    name = optsNameTokenPtr[1].start;
-	    nameChars = optsNameTokenPtr[1].size;
-	    if (!TclIsLocalScalar(name, nameChars)) {
-		return TCL_ERROR;
-	    }
-	    optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
-		    optsNameTokenPtr[1].size, /*create*/ 1, envPtr);
+	    optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr);
 	    if (optsIndex < 0) {
 		return TCL_ERROR;
 	    }
@@ -871,11 +851,9 @@ TclCompileDictSetCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     Tcl_Token *tokenPtr;
-    int numWords, i;
+    int numWords, i, dictVarIndex;
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *varTokenPtr;
-    int dictVarIndex, nameChars;
-    const char *name;
 
     /*
      * There must be at least one argument after the command.
@@ -892,15 +870,7 @@ TclCompileDictSetCmd(
      */
 
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-    if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	return TCL_ERROR;
-    }
-    name = varTokenPtr[1].start;
-    nameChars = varTokenPtr[1].size;
-    if (!TclIsLocalScalar(name, nameChars)) {
-	return TCL_ERROR;
-    }
-    dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+    dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
     if (dictVarIndex < 0) {
 	return TCL_ERROR;
     }
@@ -937,8 +907,7 @@ TclCompileDictIncrCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *varTokenPtr, *keyTokenPtr;
-    int dictVarIndex, nameChars, incrAmount;
-    const char *name;
+    int dictVarIndex, incrAmount;
 
     /*
      * There must be at least two arguments after the command.
@@ -984,15 +953,7 @@ TclCompileDictIncrCmd(
      * discover what the index is.
      */
 
-    if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    }
-    name = varTokenPtr[1].start;
-    nameChars = varTokenPtr[1].size;
-    if (!TclIsLocalScalar(name, nameChars)) {
-	return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    }
-    dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+    dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
     if (dictVarIndex < 0) {
 	return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
     }
@@ -1092,8 +1053,7 @@ TclCompileDictUnsetCmd(
 {
     Tcl_Token *tokenPtr;
     DefineLineInformation;	/* TIP #280 */
-    int i, dictVarIndex, nameChars;
-    const char *name;
+    int i, dictVarIndex;
 
     /*
      * There must be at least one argument after the variable name for us to
@@ -1111,15 +1071,7 @@ TclCompileDictUnsetCmd(
      */
 
     tokenPtr = TokenAfter(parsePtr->tokenPtr);
-    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    }
-    name = tokenPtr[1].start;
-    nameChars = tokenPtr[1].size;
-    if (!TclIsLocalScalar(name, nameChars)) {
-	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    }
-    dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+    dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
     if (dictVarIndex < 0) {
 	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
     }
@@ -1210,7 +1162,7 @@ TclCompileDictCreateCmd(
      */
 
   nonConstant:
-    worker = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    worker = AnonymousLocal(envPtr);
     if (worker < 0) {
 	return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
     }
@@ -1271,11 +1223,11 @@ TclCompileDictMergeCmd(
      * command when there's an LVT present.
      */
 
-    workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    workerIndex = AnonymousLocal(envPtr);
     if (workerIndex < 0) {
 	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
     }
-    infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    infoIndex = AnonymousLocal(envPtr);
 
     /*
      * Get the first dictionary and verify that it is so.
@@ -1421,8 +1373,7 @@ CompileDictEachCmd(
      */
 
     if (collect == TCL_EACH_COLLECT) {
-	collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
-		envPtr);
+	collectVar = AnonymousLocal(envPtr);
 	if (collectVar < 0) {
 	    return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 	}
@@ -1447,18 +1398,9 @@ CompileDictEachCmd(
     }
 
     nameChars = strlen(argv[0]);
-    if (!TclIsLocalScalar(argv[0], nameChars)) {
-	ckfree(argv);
-	return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    }
-    keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr);
-
+    keyVarIndex = LocalScalar(argv[0], nameChars, envPtr);
     nameChars = strlen(argv[1]);
-    if (!TclIsLocalScalar(argv[1], nameChars)) {
-	ckfree(argv);
-	return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    }
-    valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr);
+    valueVarIndex = LocalScalar(argv[1], nameChars, envPtr);
     ckfree(argv);
 
     if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
@@ -1472,7 +1414,7 @@ CompileDictEachCmd(
      * (at which point it should also have been finished with).
      */
 
-    infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    infoIndex = AnonymousLocal(envPtr);
     if (infoIndex < 0) {
 	return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
     }
@@ -1627,8 +1569,7 @@ TclCompileDictUpdateCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     DefineLineInformation;	/* TIP #280 */
-    const char *name;
-    int i, nameChars, dictIndex, numVars, range, infoIndex;
+    int i, dictIndex, numVars, range, infoIndex;
     Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
     DictUpdateInfo *duiPtr;
     JumpFixup jumpFixup;
@@ -1658,15 +1599,7 @@ TclCompileDictUpdateCmd(
      */
 
     dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
-    if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	goto issueFallback;
-    }
-    name = dictVarTokenPtr[1].start;
-    nameChars = dictVarTokenPtr[1].size;
-    if (!TclIsLocalScalar(name, nameChars)) {
-	goto issueFallback;
-    }
-    dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+    dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr);
     if (dictIndex < 0) {
 	goto issueFallback;
     }
@@ -1688,27 +1621,14 @@ TclCompileDictUpdateCmd(
 	 */
 
 	keyTokenPtrs[i] = tokenPtr;
-
-	/*
-	 * Variables first need to be checked for sanity.
-	 */
-
 	tokenPtr = TokenAfter(tokenPtr);
-	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	    goto failedUpdateInfoAssembly;
-	}
-	name = tokenPtr[1].start;
-	nameChars = tokenPtr[1].size;
-	if (!TclIsLocalScalar(name, nameChars)) {
-	    goto failedUpdateInfoAssembly;
-	}
 
 	/*
-	 * Stash the index in the auxiliary data.
+	 * Stash the index in the auxiliary data (if it is indeed a local
+	 * scalar that is resolvable at compile-time).
 	 */
 
-	duiPtr->varIndices[i] =
-		TclFindCompiledLocal(name, nameChars, 1, envPtr);
+	duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr);
 	if (duiPtr->varIndices[i] < 0) {
 	    goto failedUpdateInfoAssembly;
 	}
@@ -1819,19 +1739,9 @@ TclCompileDictAppendCmd(
      */
 
     tokenPtr = TokenAfter(parsePtr->tokenPtr);
-    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    } else {
-	register const char *name = tokenPtr[1].start;
-	register int nameChars = tokenPtr[1].size;
-
-	if (!TclIsLocalScalar(name, nameChars)) {
-	    return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
-	}
-	dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
-	if (dictVarIndex < 0) {
-	    return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
-	}
+    dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
+    if (dictVarIndex < 0) {
+	return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
     }
 
     /*
@@ -1866,8 +1776,7 @@ TclCompileDictLappendCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
-    int dictVarIndex, nameChars;
-    const char *name;
+    int dictVarIndex;
 
     /*
      * There must be three arguments after the command.
@@ -1884,15 +1793,7 @@ TclCompileDictLappendCmd(
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
     keyTokenPtr = TokenAfter(varTokenPtr);
     valueTokenPtr = TokenAfter(keyTokenPtr);
-    if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    }
-    name = varTokenPtr[1].start;
-    nameChars = varTokenPtr[1].size;
-    if (!TclIsLocalScalar(name, nameChars)) {
-	return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-    }
-    dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+    dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
     if (dictVarIndex < 0) {
 	return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
     }
@@ -1917,8 +1818,8 @@ TclCompileDictWithCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     DefineLineInformation;	/* TIP #280 */
-    int i, range, varNameTmp = -1, pathTmp, keysTmp, gotPath, dictVar = -1;
-    int bodyIsEmpty = 1;
+    int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath;
+    int dictVar, bodyIsEmpty = 1;
     Tcl_Token *varTokenPtr, *tokenPtr;
     JumpFixup jumpFixup;
     const char *ptr, *end;
@@ -1967,11 +1868,7 @@ TclCompileDictWithCmd(
      */
 
     gotPath = (parsePtr->numWords > 3);
-    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD &&
-	    TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) {
-	dictVar = TclFindCompiledLocal(varTokenPtr[1].start,
-		varTokenPtr[1].size, 1, envPtr);
-    }
+    dictVar = LocalScalarFromToken(varTokenPtr, envPtr);
 
     /*
      * Special case: an empty body means we definitely have no need to issue
@@ -2054,14 +1951,12 @@ TclCompileDictWithCmd(
      */
 
     if (dictVar == -1) {
-	varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+	varNameTmp = AnonymousLocal(envPtr);
     }
     if (gotPath) {
-	pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-    } else {
-	pathTmp = -1;
+	pathTmp = AnonymousLocal(envPtr);
     }
-    keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    keysTmp = AnonymousLocal(envPtr);
 
     /*
      * Issue instructions. First, the part to expand the dictionary.
@@ -2696,8 +2591,7 @@ CompileEachloopCmd(
     }
 
     if (collect == TCL_EACH_COLLECT) {
-	collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
-		envPtr);
+	collectVar = AnonymousLocal(envPtr);
 	if (collectVar < 0) {
 	    return TCL_ERROR;
 	}
@@ -2716,14 +2610,12 @@ CompileEachloopCmd(
     code = TCL_OK;
     firstValueTemp = -1;
     for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
-	tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
-		/*create*/ 1, envPtr);
+	tempVar = AnonymousLocal(envPtr);
 	if (loopIndex == 0) {
 	    firstValueTemp = tempVar;
 	}
     }
-    loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
-	    /*create*/ 1, envPtr);
+    loopCtTemp = AnonymousLocal(envPtr);
 
     /*
      * Create and initialize the ForeachInfo and ForeachVarList data
@@ -3455,8 +3347,7 @@ TclPushVarName(
 	 */
 
 	if (!hasNsQualifiers) {
-	    localIndex = TclFindCompiledLocal(name, nameChars,
-		    1, envPtr);
+	    localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
 	    if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
 		/*
 		 * We'll push the name.
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 7831198..381703b 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -2159,12 +2159,11 @@ TclCompileTryCmd(
 		int len;
 		const char *varname = Tcl_GetStringFromObj(objv[0], &len);
 
-		if (!TclIsLocalScalar(varname, len)) {
+		resultVarIndices[i] = LocalScalar(varname, len, envPtr);
+		if (resultVarIndices[i] < 0) {
 		    TclDecrRefCount(tmpObj);
 		    goto failedToCompile;
 		}
-		resultVarIndices[i] =
-			TclFindCompiledLocal(varname, len, 1, envPtr);
 	    } else {
 		resultVarIndices[i] = -1;
 	    }
@@ -2172,12 +2171,11 @@ TclCompileTryCmd(
 		int len;
 		const char *varname = Tcl_GetStringFromObj(objv[1], &len);
 
-		if (!TclIsLocalScalar(varname, len)) {
+		optionVarIndices[i] = LocalScalar(varname, len, envPtr);
+		if (optionVarIndices[i] < 0) {
 		    TclDecrRefCount(tmpObj);
 		    goto failedToCompile;
 		}
-		optionVarIndices[i] =
-			TclFindCompiledLocal(varname, len, 1, envPtr);
 	    } else {
 		optionVarIndices[i] = -1;
 	    }
@@ -2289,8 +2287,8 @@ IssueTryInstructions(
     int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
     char buf[TCL_INTEGER_SPACE];
 
-    resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-    optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    resultVar = AnonymousLocal(envPtr);
+    optionsVar = AnonymousLocal(envPtr);
     if (resultVar < 0 || optionsVar < 0) {
 	return TCL_ERROR;
     }
@@ -2444,8 +2442,8 @@ IssueTryFinallyInstructions(
     int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
     char buf[TCL_INTEGER_SPACE];
 
-    resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-    optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    resultVar = AnonymousLocal(envPtr);
+    optionsVar = AnonymousLocal(envPtr);
     if (resultVar < 0 || optionsVar < 0) {
 	return TCL_ERROR;
     }
@@ -3141,7 +3139,7 @@ CompileComparisonOpCmd(
 
 	return TCL_ERROR;
     } else {
-	int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+	int tmpIndex = AnonymousLocal(envPtr);
 	int words;
 
 	tokenPtr = TokenAfter(parsePtr->tokenPtr);
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 908dceb..9af4911 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1559,6 +1559,20 @@ MODULE_SCOPE Tcl_Obj	*TclNewInstNameObj(unsigned char inst);
     }
 
 /*
+ * How to get an anonymous local variable (used for holding temporary values
+ * off the stack) or a local simple scalar.
+ */
+
+#define AnonymousLocal(envPtr) \
+    (TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, (envPtr)))
+#define LocalScalar(chars,len,envPtr) \
+    (!TclIsLocalScalar((chars), (len)) ? -1 : \
+	TclFindCompiledLocal((chars), (len), /*create*/ 1, (envPtr)))
+#define LocalScalarFromToken(tokenPtr,envPtr) \
+    ((tokenPtr)->type != TCL_TOKEN_SIMPLE_WORD ? -1 : \
+	LocalScalar((tokenPtr)[1].start, (tokenPtr)[1].size, (envPtr)))
+
+/*
  * Flags bits used by TclPushVarName.
  */
 
-- 
cgit v0.12


From 4e13219dfb9cec9a36faaffb93a2c70db6ecf0b9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 8 Jun 2013 23:35:02 +0000
Subject: More informative comment describing INST_SYNTAX.

---
 generic/tclCompile.c | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 572f660..c361430 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -383,7 +383,8 @@ InstructionDesc const tclInstructionTable[] = {
 	/* finds namespace and otherName in stack, links to local variable at
 	 * index op1. Leaves the namespace on stack. */
     {"syntax",		 9,   -1,         2,	{OPERAND_INT4, OPERAND_UINT4}},
-	/* Compiled bytecodes to signal syntax error. */
+	/* Compiled bytecodes to signal syntax error. Equivalent to returnImm
+	 * except for the ERR_ALREADY_LOGGED flag in the interpreter. */
     {"reverse",		 5,    0,         1,	{OPERAND_UINT4}},
 	/* Reverse the order of the arg elements at the top of stack */
 
-- 
cgit v0.12


From 41462bf4fa928176536e7305c35c1382d87db2e2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 8 Jun 2013 23:43:29 +0000
Subject: Working on a better compiler for [try]; found some bugs in previous
 compilation code which aren't resolved yet.

---
 generic/tclCompCmdsSZ.c | 146 ++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 123 insertions(+), 23 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 381703b..f166a7a 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -51,17 +51,20 @@ static void		IssueSwitchJumpTable(Tcl_Interp *interp,
 			    Tcl_Token *valueTokenPtr, int numWords,
 			    Tcl_Token **bodyToken, int *bodyLines,
 			    int **bodyContLines);
-static int		IssueTryFinallyInstructions(Tcl_Interp *interp,
+static int		IssueTryClausesInstructions(Tcl_Interp *interp,
 			    CompileEnv *envPtr, Tcl_Token *bodyToken,
 			    int numHandlers, int *matchCodes,
 			    Tcl_Obj **matchClauses, int *resultVarIndices,
-			    int *optionVarIndices, Tcl_Token **handlerTokens,
-			    Tcl_Token *finallyToken);
-static int		IssueTryInstructions(Tcl_Interp *interp,
+			    int *optionVarIndices, Tcl_Token **handlerTokens);
+static int		IssueTryClausesFinallyInstructions(Tcl_Interp *interp,
 			    CompileEnv *envPtr, Tcl_Token *bodyToken,
 			    int numHandlers, int *matchCodes,
 			    Tcl_Obj **matchClauses, int *resultVarIndices,
-			    int *optionVarIndices, Tcl_Token **handlerTokens);
+			    int *optionVarIndices, Tcl_Token **handlerTokens,
+			    Tcl_Token *finallyToken);
+static int		IssueTryFinallyInstructions(Tcl_Interp *interp,
+			    CompileEnv *envPtr, Tcl_Token *bodyToken,
+			    Tcl_Token *finallyToken);
 
 /*
  * The structures below define the AuxData types defined in this file.
@@ -2223,14 +2226,17 @@ TclCompileTryCmd(
      * Issue the bytecode.
      */
 
-    if (finallyToken) {
+    if (!finallyToken) {
+	result = IssueTryClausesInstructions(interp, envPtr, bodyToken,
+		numHandlers, matchCodes, matchClauses, resultVarIndices,
+		optionVarIndices, handlerTokens);
+    } else if (numHandlers == 0) {
 	result = IssueTryFinallyInstructions(interp, envPtr, bodyToken,
+		finallyToken);
+    } else {
+	result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken,
 		numHandlers, matchCodes, matchClauses, resultVarIndices,
 		optionVarIndices, handlerTokens, finallyToken);
-    } else {
-	result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers,
-		matchCodes, matchClauses, resultVarIndices, optionVarIndices,
-		handlerTokens);
     }
 
     /*
@@ -2256,12 +2262,13 @@ TclCompileTryCmd(
 /*
  *----------------------------------------------------------------------
  *
- * IssueTryInstructions, IssueTryFinallyInstructions --
+ * IssueTryClausesInstructions, IssueTryClausesFinallyInstructions,
+ * IssueTryFinallyInstructions --
  *
  *	The code generators for [try]. Split from the parsing engine for
- *	reasons of developer sanity, and also split between no-finally and
- *	with-finally cases because so many of the details of generation vary
- *	between the two.
+ *	reasons of developer sanity, and also split between no-finally,
+ *	just-finally and with-finally cases because so many of the details of
+ *	generation vary between the three.
  *
  *	The macros below make the instruction issuing easier to follow.
  *
@@ -2269,7 +2276,7 @@ TclCompileTryCmd(
  */
 
 static int
-IssueTryInstructions(
+IssueTryClausesInstructions(
     Tcl_Interp *interp,
     CompileEnv *envPtr,
     Tcl_Token *bodyToken,
@@ -2283,7 +2290,7 @@ IssueTryInstructions(
     DefineLineInformation;	/* TIP #280 */
     int range, resultVar, optionsVar;
     int savedStackDepth = envPtr->currStackDepth;
-    int i, j, len, forwardsNeedFixing = 0;
+    int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
     int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
     char buf[TCL_INTEGER_SPACE];
 
@@ -2294,6 +2301,18 @@ IssueTryInstructions(
     }
 
     /*
+     * Check if we're supposed to trap a normal TCL_OK completion of the body.
+     * If not, we can handle that case much more efficiently.
+     */
+
+    for (i=0 ; i<numHandlers ; i++) {
+	if (matchCodes[i] == 0) {
+	    trapZero = 1;
+	    break;
+	}
+    }
+
+    /*
      * Compile the body, trapping any error in it so that we can trap on it
      * and/or run a finally clause. Note that there must be at least one
      * on/trap clause; when none is present, this whole function is not called
@@ -2305,9 +2324,16 @@ IssueTryInstructions(
     ExceptionRangeStarts(envPtr, range);
     BODY(				bodyToken, 1);
     ExceptionRangeEnds(envPtr, range);
-    PUSH(				"0");
-    OP4(				REVERSE, 2);
-    OP1(				JUMP1, 4);
+    if (!trapZero) {
+	OP(				END_CATCH);
+	JUMP(afterBody,			JUMP4);
+	TclAdjustStackDepth(-1, envPtr);
+    } else {
+	PUSH(				"0");
+	OP4(				REVERSE, 2);
+	OP1(				JUMP1, 4);
+	TclAdjustStackDepth(-2, envPtr);
+    }
     ExceptionRangeTarget(envPtr, range, catchOffset);
     OP(					PUSH_RETURN_CODE);
     OP(					PUSH_RESULT);
@@ -2414,6 +2440,9 @@ IssueTryInstructions(
      * [try]).
      */
 
+    if (!trapZero) {
+	FIXJUMP(afterBody);
+    }
     for (i=0 ; i<numHandlers ; i++) {
 	FIXJUMP(addrsToFix[i]);
     }
@@ -2424,7 +2453,7 @@ IssueTryInstructions(
 }
 
 static int
-IssueTryFinallyInstructions(
+IssueTryClausesFinallyInstructions(
     Tcl_Interp *interp,
     CompileEnv *envPtr,
     Tcl_Token *bodyToken,
@@ -2439,6 +2468,7 @@ IssueTryFinallyInstructions(
     DefineLineInformation;	/* TIP #280 */
     int savedStackDepth = envPtr->currStackDepth;
     int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
+    int trapZero = 0, afterBody = 0;
     int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
     char buf[TCL_INTEGER_SPACE];
 
@@ -2449,6 +2479,18 @@ IssueTryFinallyInstructions(
     }
 
     /*
+     * Check if we're supposed to trap a normal TCL_OK completion of the body.
+     * If not, we can handle that case much more efficiently.
+     */
+
+    for (i=0 ; i<numHandlers ; i++) {
+	if (matchCodes[i] == 0) {
+	    trapZero = 1;
+	    break;
+	}
+    }
+
+    /*
      * Compile the body, trapping any error in it so that we can trap on it
      * (if any trap matches) and run a finally clause.
      */
@@ -2459,9 +2501,19 @@ IssueTryFinallyInstructions(
     envPtr->currStackDepth = savedStackDepth;
     BODY(				bodyToken, 1);
     ExceptionRangeEnds(envPtr, range);
-    PUSH(				"0");
-    OP4(				REVERSE, 2);
-    OP1(				JUMP1, 4);
+    if (!trapZero) {
+	OP(				END_CATCH);
+	STORE(				resultVar);
+	OP(				POP);
+	PUSH(				"-level 0 -code 0");
+	STORE(				optionsVar);
+	OP(				POP);
+	JUMP(afterBody,			JUMP4);
+    } else {
+	PUSH(				"0");
+	OP4(				REVERSE, 2);
+	OP1(				JUMP1, 4);
+    }
     ExceptionRangeTarget(envPtr, range, catchOffset);
     OP(					PUSH_RETURN_CODE);
     OP(					PUSH_RESULT);
@@ -2637,6 +2689,9 @@ IssueTryFinallyInstructions(
      * next command (or some inter-command manipulation).
      */
 
+    if (!trapZero) {
+	FIXJUMP(afterBody);
+    }
     envPtr->currStackDepth = savedStackDepth;
     BODY(				finallyToken, 3 + 4*numHandlers);
     OP(					POP);
@@ -2647,6 +2702,51 @@ IssueTryFinallyInstructions(
 
     return TCL_OK;
 }
+
+static int
+IssueTryFinallyInstructions(
+    Tcl_Interp *interp,
+    CompileEnv *envPtr,
+    Tcl_Token *bodyToken,
+    Tcl_Token *finallyToken)
+{
+    DefineLineInformation;	/* TIP #280 */
+    int range;
+
+    /*
+     * Note that this one is simple enough that we can issue it without
+     * needing a local variable table, making it a universal compilation.
+     */
+
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+    OP4(				BEGIN_CATCH4, range);
+    ExceptionRangeStarts(envPtr, range);
+    BODY(				bodyToken, 1);
+    ExceptionRangeEnds(envPtr, range);
+    OP1(				JUMP1, 3);
+    TclAdjustStackDepth(-1, envPtr);
+    ExceptionRangeTarget(envPtr, range, catchOffset);
+    OP(					PUSH_RESULT);
+    OP(					PUSH_RETURN_OPTIONS);
+    OP(					END_CATCH);
+
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+    OP4(				BEGIN_CATCH4, range);
+    ExceptionRangeStarts(envPtr, range);
+    BODY(				finallyToken, 3);
+    OP(					END_CATCH);
+    OP(					POP);
+    OP1(				JUMP1, 3);
+    TclAdjustStackDepth(-1, envPtr);
+    OP(					PUSH_RESULT);
+    OP(					PUSH_RETURN_OPTIONS);
+    OP(					PUSH_RETURN_CODE);
+    OP(					END_CATCH);
+    OP(					POP);
+    OP4(				REVERSE, 2);
+    OP(					RETURN_STK);
+    return TCL_OK;
+}
 
 /*
  *----------------------------------------------------------------------
-- 
cgit v0.12


From 18fcba4c826d31f34623566228d0baa30430eede Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 9 Jun 2013 08:15:43 +0000
Subject: Improving tests, fixed one case.

---
 generic/tclCompCmdsSZ.c |  71 ++++++++++++++---------
 tests/error.test        | 146 +++++++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 181 insertions(+), 36 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index f166a7a..cbe36d1 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -92,10 +92,14 @@ const AuxDataType tclJumptableInfoType = {
     SetLineInformation((index));CompileBody(envPtr,(token),interp)
 #define PUSH(str) \
     PushStringLiteral(envPtr, str)
-#define JUMP(var,name) \
-    (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr)
-#define FIXJUMP(var) \
+#define JUMP4(name,var) \
+    (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr)
+#define FIXJUMP4(var) \
     TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
+#define JUMP1(name,var) \
+    (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr)
+#define FIXJUMP1(var) \
+    TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
 #define LOAD(idx) \
     if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
 #define STORE(idx) \
@@ -2326,7 +2330,7 @@ IssueTryClausesInstructions(
     ExceptionRangeEnds(envPtr, range);
     if (!trapZero) {
 	OP(				END_CATCH);
-	JUMP(afterBody,			JUMP4);
+	JUMP4(				JUMP, afterBody);
 	TclAdjustStackDepth(-1, envPtr);
     } else {
 	PUSH(				"0");
@@ -2359,7 +2363,7 @@ IssueTryClausesInstructions(
 	OP(				DUP);
 	PushLiteral(envPtr, buf, strlen(buf));
 	OP(				EQ);
-	JUMP(notCodeJumpSource,		JUMP_FALSE4);
+	JUMP4(				JUMP_FALSE, notCodeJumpSource);
 	if (matchClauses[i]) {
 	    const char *p;
 	    Tcl_ListObjLength(NULL, matchClauses[i], &len);
@@ -2376,7 +2380,7 @@ IssueTryClausesInstructions(
 	    p = Tcl_GetStringFromObj(matchClauses[i], &len);
 	    PushLiteral(envPtr, p, len);
 	    OP(				STR_EQ);
-	    JUMP(notECJumpSource,	JUMP_FALSE4);
+	    JUMP4(			JUMP_FALSE, notECJumpSource);
 	} else {
 	    notECJumpSource = -1; /* LINT */
 	}
@@ -2400,7 +2404,7 @@ IssueTryClausesInstructions(
 	}
 	if (!handlerTokens[i]) {
 	    forwardsNeedFixing = 1;
-	    JUMP(forwardsToFix[i],	JUMP4);
+	    JUMP4(			JUMP, forwardsToFix[i]);
 	} else {
 	    forwardsToFix[i] = -1;
 	    if (forwardsNeedFixing) {
@@ -2409,7 +2413,7 @@ IssueTryClausesInstructions(
 		    if (forwardsToFix[j] == -1) {
 			continue;
 		    }
-		    FIXJUMP(forwardsToFix[j]);
+		    FIXJUMP4(forwardsToFix[j]);
 		    forwardsToFix[j] = -1;
 		}
 	    }
@@ -2417,11 +2421,11 @@ IssueTryClausesInstructions(
 	    BODY(			handlerTokens[i], 5+i*4);
 	}
 
-	JUMP(addrsToFix[i],		JUMP4);
+	JUMP4(				JUMP, addrsToFix[i]);
 	if (matchClauses[i]) {
-	    FIXJUMP(notECJumpSource);
+	    FIXJUMP4(	notECJumpSource);
 	}
-	FIXJUMP(notCodeJumpSource);
+	FIXJUMP4(	notCodeJumpSource);
     }
 
     /*
@@ -2441,10 +2445,10 @@ IssueTryClausesInstructions(
      */
 
     if (!trapZero) {
-	FIXJUMP(afterBody);
+	FIXJUMP4(afterBody);
     }
     for (i=0 ; i<numHandlers ; i++) {
-	FIXJUMP(addrsToFix[i]);
+	FIXJUMP4(addrsToFix[i]);
     }
     TclStackFree(interp, forwardsToFix);
     TclStackFree(interp, addrsToFix);
@@ -2508,7 +2512,7 @@ IssueTryClausesFinallyInstructions(
 	PUSH(				"-level 0 -code 0");
 	STORE(				optionsVar);
 	OP(				POP);
-	JUMP(afterBody,			JUMP4);
+	JUMP4(				JUMP, afterBody);
     } else {
 	PUSH(				"0");
 	OP4(				REVERSE, 2);
@@ -2542,7 +2546,7 @@ IssueTryClausesFinallyInstructions(
 	    OP(				DUP);
 	    PushLiteral(envPtr,	buf, strlen(buf));
 	    OP(				EQ);
-	    JUMP(notCodeJumpSource,	JUMP_FALSE4);
+	    JUMP4(			JUMP_FALSE, notCodeJumpSource);
 	    if (matchClauses[i]) {
 		const char *p;
 		Tcl_ListObjLength(NULL, matchClauses[i], &len);
@@ -2559,7 +2563,7 @@ IssueTryClausesFinallyInstructions(
 		p = Tcl_GetStringFromObj(matchClauses[i], &len);
 		PushLiteral(envPtr, p, len);
 		OP(			STR_EQ);
-		JUMP(notECJumpSource,	JUMP_FALSE4);
+		JUMP4(			JUMP_FALSE, notECJumpSource);
 	    } else {
 		notECJumpSource = -1; /* LINT */
 	    }
@@ -2596,7 +2600,7 @@ IssueTryClausesFinallyInstructions(
 		    ExceptionRangeEnds(envPtr, range);
 		    OP(			END_CATCH);
 		    forwardsNeedFixing = 1;
-		    JUMP(forwardsToFix[i], JUMP4);
+		    JUMP4(		JUMP, forwardsToFix[i]);
 		    goto finishTrapCatchHandling;
 		}
 	    } else if (!handlerTokens[i]) {
@@ -2606,7 +2610,7 @@ IssueTryClausesFinallyInstructions(
 		 */
 
 		forwardsNeedFixing = 1;
-		JUMP(forwardsToFix[i],	JUMP4);
+		JUMP4(			JUMP, forwardsToFix[i]);
 		goto endOfThisArm;
 	    }
 
@@ -2623,7 +2627,7 @@ IssueTryClausesFinallyInstructions(
 		    if (forwardsToFix[j] == -1) {
 			continue;
 		    }
-		    FIXJUMP(forwardsToFix[j]);
+		    FIXJUMP4(forwardsToFix[j]);
 		    forwardsToFix[j] = -1;
 		}
 		OP4(			BEGIN_CATCH4, range);
@@ -2655,12 +2659,12 @@ IssueTryClausesFinallyInstructions(
 
 	endOfThisArm:
 	    if (i+1 < numHandlers) {
-		JUMP(addrsToFix[i],	JUMP4);
+		JUMP4(			JUMP, addrsToFix[i]);
 	    }
 	    if (matchClauses[i]) {
-		FIXJUMP(notECJumpSource);
+		FIXJUMP4(notECJumpSource);
 	    }
-	    FIXJUMP(notCodeJumpSource);
+	    FIXJUMP4(notCodeJumpSource);
 	}
 
 	/*
@@ -2669,7 +2673,7 @@ IssueTryClausesFinallyInstructions(
 	 */
 
 	for (i=0 ; i<numHandlers-1 ; i++) {
-	    FIXJUMP(addrsToFix[i]);
+	    FIXJUMP4(addrsToFix[i]);
 	}
 	TclStackFree(interp, forwardsToFix);
 	TclStackFree(interp, addrsToFix);
@@ -2690,7 +2694,7 @@ IssueTryClausesFinallyInstructions(
      */
 
     if (!trapZero) {
-	FIXJUMP(afterBody);
+	FIXJUMP4(	afterBody);
     }
     envPtr->currStackDepth = savedStackDepth;
     BODY(				finallyToken, 3 + 4*numHandlers);
@@ -2711,7 +2715,7 @@ IssueTryFinallyInstructions(
     Tcl_Token *finallyToken)
 {
     DefineLineInformation;	/* TIP #280 */
-    int range;
+    int range, jumpOK, jumpSplice;
 
     /*
      * Note that this one is simple enough that we can issue it without
@@ -2734,15 +2738,28 @@ IssueTryFinallyInstructions(
     OP4(				BEGIN_CATCH4, range);
     ExceptionRangeStarts(envPtr, range);
     BODY(				finallyToken, 3);
+    ExceptionRangeEnds(envPtr, range);
     OP(					END_CATCH);
     OP(					POP);
-    OP1(				JUMP1, 3);
-    TclAdjustStackDepth(-1, envPtr);
+    JUMP1(				JUMP, jumpOK);
+    ExceptionRangeTarget(envPtr, range, catchOffset);
     OP(					PUSH_RESULT);
     OP(					PUSH_RETURN_OPTIONS);
     OP(					PUSH_RETURN_CODE);
     OP(					END_CATCH);
+    PUSH(				"1");
+    OP(					EQ);
+    JUMP1(				JUMP_FALSE, jumpSplice);
+    PUSH(				"-during");
+    OP4(				OVER, 3);
+    OP4(				LIST, 2);
+    OP(					LIST_CONCAT);
+    FIXJUMP1(		jumpSplice);
+    OP4(				REVERSE, 4);
+    OP(					POP);
     OP(					POP);
+    OP1(				JUMP1, 7);
+    FIXJUMP1(		jumpOK);
     OP4(				REVERSE, 2);
     OP(					RETURN_STK);
     return TCL_OK;
diff --git a/tests/error.test b/tests/error.test
index 97bcc0a..273577a 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 }
 
 testConstraint memory [llength [info commands memory]]
+customMatch pairwise {apply {{a b} {
+    string equal [lindex $b 0] [lindex $b 1]
+}}}
 namespace eval ::tcl::test::error {
 if {[testConstraint memory]} {
     proc getbytes {} {
@@ -601,21 +604,21 @@ test error-16.7 {try with variable assignment and propagation #2} {
     }
     list $em [dict get $opts -errorcode]
 } {bar FOO}
-test error-16.8 {exception chaining (try=ok, handler=error)} {
+test error-16.8 {exception chaining (try=ok, handler=error)} -body {
     #FIXME is the intent of this test correct?
     catch {
 	try { list a b c } on ok {em opts} { throw BAR baz }
     } tryem tryopts
-    string equal $opts [dict get $tryopts -during]
-} {1}
-test error-16.9 {exception chaining (try=error, handler=error)} {
+    list $opts [dict get $tryopts -during]
+} -match pairwise -result equal
+test error-16.9 {exception chaining (try=error, handler=error)} -body {
     # The exception off the handler should chain to the exception off the
     # try-body (using the -during option)
     catch {
 	try { throw FOO bar } trap {} {em opts} { throw BAR baz }
     } tryem tryopts
-    string equal $opts [dict get $tryopts -during]
-} {1}
+    list $opts [dict get $tryopts -during]
+} -match pairwise -result equal
 test error-16.10 {no exception chaining when handler is successful} {
     catch {
 	try { throw FOO bar } trap {} {em opts} { list d e f }
@@ -628,6 +631,131 @@ test error-16.11 {no exception chaining when handler is a non-error exception} {
     } tryem tryopts
     dict exists $tryopts -during
 } {0}
+test error-16.12 {compiled try with successfully executed handler} {
+    apply {{} {
+	try { throw FOO bar } trap FOO {} { list a b c }
+    }}
+} {a b c}
+test error-16.13 {compiled try with exception (error) in handler} -body {
+    apply {{} {
+	try { throw FOO bar } trap FOO {} { throw BAR foo }
+    }}
+} -returnCodes error -result {foo}
+test error-16.14 {compiled try with exception (return) in handler} -body {
+    apply {{} {
+	list [catch {
+	    try { throw FOO bar } trap FOO {} { return BAR }
+	} msg] $msg
+    }}
+} -result {2 BAR}
+test error-16.15 {compiled try with exception (break) in handler} {
+    apply {{} {
+	for { set i 5 } { $i < 10 } { incr i } {
+	    try { throw FOO bar } trap FOO {} { break }
+	}
+	return $i
+    }}
+} {5}
+test error-16.16 {compiled try with exception (continue) in handler} {
+    apply {{} {
+	for { set i 5 } { $i < 10 } { incr i } {
+	    try { throw FOO bar } trap FOO {} { continue }
+	    incr i 20
+	}
+	return $i
+    }}
+} {10}
+test error-16.17 {compiled try with variable assignment and propagation #1} {
+    # Ensure that the handler variables preserve the exception off the
+    # try-body, and are not modified by the exception off the handler
+    apply {{} {
+	catch {
+	    try { throw FOO bar } trap FOO {em} { throw BAR baz }
+	}
+	return $em
+    }}
+} {bar}
+test error-16.18 {compiled try with variable assignment and propagation #2} {
+    apply {{} {
+	catch {
+	    try { throw FOO bar } trap FOO {em opts} { throw BAR baz }
+	}
+	list $em [dict get $opts -errorcode]
+    }}
+} {bar FOO}
+test error-16.19 {compiled try exception chaining (try=ok, handler=error)} -body {
+    #FIXME is the intent of this test correct?
+    apply {{} {
+	catch {
+	    try { list a b c } on ok {em opts} { throw BAR baz }
+	} tryem tryopts
+	list $opts [dict get $tryopts -during]
+    }}
+} -match pairwise -result equal
+test error-16.20 {compiled try exception chaining (try=error, handler=error)} -body {
+    # The exception off the handler should chain to the exception off the
+    # try-body (using the -during option)
+    apply {{} {
+	catch {
+	    try { throw FOO bar } trap {} {em opts} { throw BAR baz }
+	} tryem tryopts
+	list $opts [dict get $tryopts -during]
+    }}
+} -match pairwise -result equal
+test error-16.21 {compiled try exception chaining (try=error, finally=error)} {
+    # The exception off the handler should chain to the exception off the
+    # try-body (using the -during option)
+    apply {{} {
+	catch {
+	    try { throw FOO bar } finally { throw BAR baz }
+	} tryem tryopts
+	dict get $tryopts -during -errorcode
+    }}
+} FOO
+test error-16.22 {compiled try: no exception chaining when handler is successful} {
+    apply {{} {
+	catch {
+	    try { throw FOO bar } trap {} {em opts} { list d e f }
+	} tryem tryopts
+	dict exists $tryopts -during
+    }}
+} {0}
+test error-16.23 {compiled try: no exception chaining when handler is a non-error exception} {
+    apply {{} {
+	catch {
+	    try { throw FOO bar } trap {} {em opts} { break }
+	} tryem tryopts
+	dict exists $tryopts -during
+    }}
+} {0}
+test error-16.24 {compiled try exception chaining (try=ok, handler=error, finally=error)} -body {
+    apply {{} {
+	catch {
+	    try {
+		list a b c
+	    } on ok {em opts} {
+		throw BAR baz
+	    } finally {
+		throw DING dong
+	    }
+	} tryem tryopts
+	list $opts [dict get $tryopts -during -during]
+    }}
+} -match pairwise -result equal
+test error-16.25 {compiled try exception chaining (all errors)} -body {
+    apply {{} {
+	catch {
+	    try {
+		throw FOO bar
+	    } on error {em opts} {
+		throw BAR baz
+	    } finally {
+		throw DING dong
+	    }
+	} tryem tryopts
+	list $opts [dict get $tryopts -during -during]
+    }}
+} -match pairwise -result equal
 
 # try tests - finally
 
@@ -709,15 +837,15 @@ test error-18.5 {exception in finally doesn't affect variable assignment} {
     }
     list $em [dict get $opts -errorcode]
 } {bar FOO}
-test error-18.6 {exception chaining in finally (try=ok)} {
+test error-18.6 {exception chaining in finally (try=ok)} -body {
     catch {
 	list a b c
     } em expopts
     catch {
 	try { list a b c } finally { throw BAR foo }
     } em opts
-    string equal $expopts [dict get $opts -during]
-} {1}
+    list $expopts [dict get $opts -during]
+} -match pairwise -result equal
 test error-18.7 {exception chaining in finally (try=error)} {
     catch {
 	try { throw FOO bar } finally { throw BAR baz }
-- 
cgit v0.12


From 41da12e756dca7431f8524a205099cc030333c0a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 9 Jun 2013 17:21:07 +0000
Subject: Fix the problems with code generation; behavior now appears correct.

---
 generic/tclCompCmdsSZ.c | 333 +++++++++++++++++++++++++++++-------------------
 1 file changed, 204 insertions(+), 129 deletions(-)

diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index cbe36d1..5d67166 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -2293,9 +2293,9 @@ IssueTryClausesInstructions(
 {
     DefineLineInformation;	/* TIP #280 */
     int range, resultVar, optionsVar;
-    int savedStackDepth = envPtr->currStackDepth;
     int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
     int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
+    int *noError;
     char buf[TCL_INTEGER_SPACE];
 
     resultVar = AnonymousLocal(envPtr);
@@ -2357,8 +2357,10 @@ IssueTryClausesInstructions(
 
     addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
     forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+    noError = TclStackAlloc(interp, sizeof(int)*numHandlers);
 
     for (i=0 ; i<numHandlers ; i++) {
+	noError[i] = -1;
 	sprintf(buf, "%d", matchCodes[i]);
 	OP(				DUP);
 	PushLiteral(envPtr, buf, strlen(buf));
@@ -2406,6 +2408,8 @@ IssueTryClausesInstructions(
 	    forwardsNeedFixing = 1;
 	    JUMP4(			JUMP, forwardsToFix[i]);
 	} else {
+	    int dontChangeOptions;
+
 	    forwardsToFix[i] = -1;
 	    if (forwardsNeedFixing) {
 		forwardsNeedFixing = 0;
@@ -2417,8 +2421,33 @@ IssueTryClausesInstructions(
 		    forwardsToFix[j] = -1;
 		}
 	    }
-	    envPtr->currStackDepth = savedStackDepth;
+	    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+	    OP4(			BEGIN_CATCH4, range);
+	    ExceptionRangeStarts(envPtr, range);
 	    BODY(			handlerTokens[i], 5+i*4);
+	    ExceptionRangeEnds(envPtr, range);
+	    OP(				END_CATCH);
+	    JUMP4(			JUMP, noError[i]);
+	    ExceptionRangeTarget(envPtr, range, catchOffset);
+	    TclAdjustStackDepth(-1, envPtr);
+	    OP(				PUSH_RESULT);
+	    OP(				PUSH_RETURN_OPTIONS);
+	    OP(				PUSH_RETURN_CODE);
+	    OP(				END_CATCH);
+	    PUSH(			"1");
+	    OP(				EQ);
+	    JUMP1(			JUMP_FALSE, dontChangeOptions);
+	    LOAD(			optionsVar);
+	    OP4(			REVERSE, 2);
+	    STORE(			optionsVar);
+	    OP(				POP);
+	    PUSH(			"-during");
+	    OP4(			REVERSE, 2);
+	    OP44(			DICT_SET, 1, optionsVar);
+	    TclAdjustStackDepth(-1, envPtr);
+	    FIXJUMP1(		dontChangeOptions);
+	    OP4(			REVERSE, 2);
+	    OP(				RETURN_STK);
 	}
 
 	JUMP4(				JUMP, addrsToFix[i]);
@@ -2449,10 +2478,13 @@ IssueTryClausesInstructions(
     }
     for (i=0 ; i<numHandlers ; i++) {
 	FIXJUMP4(addrsToFix[i]);
+	if (noError[i] != -1) {
+	    FIXJUMP4(noError[i]);
+	}
     }
+    TclStackFree(interp, noError);
     TclStackFree(interp, forwardsToFix);
     TclStackFree(interp, addrsToFix);
-    envPtr->currStackDepth = savedStackDepth + 1;
     return TCL_OK;
 }
 
@@ -2470,9 +2502,8 @@ IssueTryClausesFinallyInstructions(
     Tcl_Token *finallyToken)	/* Not NULL */
 {
     DefineLineInformation;	/* TIP #280 */
-    int savedStackDepth = envPtr->currStackDepth;
     int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
-    int trapZero = 0, afterBody = 0;
+    int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
     int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
     char buf[TCL_INTEGER_SPACE];
 
@@ -2502,7 +2533,6 @@ IssueTryClausesFinallyInstructions(
     range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
     OP4(				BEGIN_CATCH4, range);
     ExceptionRangeStarts(envPtr, range);
-    envPtr->currStackDepth = savedStackDepth;
     BODY(				bodyToken, 1);
     ExceptionRangeEnds(envPtr, range);
     if (!trapZero) {
@@ -2517,6 +2547,7 @@ IssueTryClausesFinallyInstructions(
 	PUSH(				"0");
 	OP4(				REVERSE, 2);
 	OP1(				JUMP1, 4);
+	TclAdjustStackDepth(-2, envPtr);
     }
     ExceptionRangeTarget(envPtr, range, catchOffset);
     OP(					PUSH_RETURN_CODE);
@@ -2527,163 +2558,178 @@ IssueTryClausesFinallyInstructions(
     OP(					POP);
     STORE(				resultVar);
     OP(					POP);
-    envPtr->currStackDepth = savedStackDepth + 1;
 
     /*
      * Now we handle all the registered 'on' and 'trap' handlers in order.
+     *
+     * Slight overallocation, but reduces size of this function.
      */
 
-    if (numHandlers) {
-	/*
-	 * Slight overallocation, but reduces size of this function.
-	 */
-
-	addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
-	forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
-
-	for (i=0 ; i<numHandlers ; i++) {
-	    sprintf(buf, "%d", matchCodes[i]);
-	    OP(				DUP);
-	    PushLiteral(envPtr,	buf, strlen(buf));
-	    OP(				EQ);
-	    JUMP4(			JUMP_FALSE, notCodeJumpSource);
-	    if (matchClauses[i]) {
-		const char *p;
-		Tcl_ListObjLength(NULL, matchClauses[i], &len);
+    addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+    forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
 
-		/*
-		 * Match the errorcode according to try/trap rules.
-		 */
+    for (i=0 ; i<numHandlers ; i++) {
+	int noTrapError, trapError;
+	const char *p;
 
-		LOAD(			optionsVar);
-		PUSH(			"-errorcode");
-		OP4(			DICT_GET, 1);
-		TclAdjustStackDepth(-1, envPtr);
-		OP44(			LIST_RANGE_IMM, 0, len-1);
-		p = Tcl_GetStringFromObj(matchClauses[i], &len);
-		PushLiteral(envPtr, p, len);
-		OP(			STR_EQ);
-		JUMP4(			JUMP_FALSE, notECJumpSource);
-	    } else {
-		notECJumpSource = -1; /* LINT */
-	    }
+	sprintf(buf, "%d", matchCodes[i]);
+	OP(				DUP);
+	PushLiteral(envPtr, buf, strlen(buf));
+	OP(				EQ);
+	JUMP4(				JUMP_FALSE, notCodeJumpSource);
+	if (matchClauses[i]) {
+	    Tcl_ListObjLength(NULL, matchClauses[i], &len);
 
 	    /*
-	     * There is a finally clause, so we need a fairly complex sequence
-	     * of instructions to deal with an on/trap handler because we must
-	     * call the finally handler *and* we need to substitute the result
-	     * from a failed trap for the result from the main script.
+	     * Match the errorcode according to try/trap rules.
 	     */
 
-	    if (resultVars[i] >= 0 || handlerTokens[i]) {
-		range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
-		OP4(			BEGIN_CATCH4, range);
-		ExceptionRangeStarts(envPtr, range);
-	    }
-	    if (resultVars[i] >= 0) {
-		LOAD(			resultVar);
-		STORE(			resultVars[i]);
-		OP(			POP);
-		if (optionVars[i] >= 0) {
-		    LOAD(		optionsVar);
-		    STORE(		optionVars[i]);
-		    OP(			POP);
-		}
+	    LOAD(			optionsVar);
+	    PUSH(			"-errorcode");
+	    OP4(			DICT_GET, 1);
+	    TclAdjustStackDepth(-1, envPtr);
+	    OP44(			LIST_RANGE_IMM, 0, len-1);
+	    p = Tcl_GetStringFromObj(matchClauses[i], &len);
+	    PushLiteral(envPtr, p, len);
+	    OP(				STR_EQ);
+	    JUMP4(			JUMP_FALSE, notECJumpSource);
+	} else {
+	    notECJumpSource = -1; /* LINT */
+	}
+	OP(				POP);
 
-		if (!handlerTokens[i]) {
-		    /*
-		     * No handler. Will not be the last handler (that is a
-		     * condition that is checked by the caller). Chain to the
-		     * next one.
-		     */
+	/*
+	 * There is a finally clause, so we need a fairly complex sequence of
+	 * instructions to deal with an on/trap handler because we must call
+	 * the finally handler *and* we need to substitute the result from a
+	 * failed trap for the result from the main script.
+	 */
 
-		    ExceptionRangeEnds(envPtr, range);
-		    OP(			END_CATCH);
-		    forwardsNeedFixing = 1;
-		    JUMP4(		JUMP, forwardsToFix[i]);
-		    goto finishTrapCatchHandling;
-		}
-	    } else if (!handlerTokens[i]) {
+	if (resultVars[i] >= 0 || handlerTokens[i]) {
+	    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+	    OP4(			BEGIN_CATCH4, range);
+	    ExceptionRangeStarts(envPtr, range);
+	}
+	if (resultVars[i] >= 0) {
+	    LOAD(			resultVar);
+	    STORE(			resultVars[i]);
+	    OP(				POP);
+	    if (optionVars[i] >= 0) {
+		LOAD(			optionsVar);
+		STORE(			optionVars[i]);
+		OP(			POP);
+	    }
+
+	    if (!handlerTokens[i]) {
 		/*
-		 * No handler. Will not be the last handler (that condition is
-		 * checked by the caller). Chain to the next one.
+		 * No handler. Will not be the last handler (that is a
+		 * condition that is checked by the caller). Chain to the next
+		 * one.
 		 */
 
+		ExceptionRangeEnds(envPtr, range);
+		OP(			END_CATCH);
 		forwardsNeedFixing = 1;
 		JUMP4(			JUMP, forwardsToFix[i]);
-		goto endOfThisArm;
+		goto finishTrapCatchHandling;
 	    }
-
+	} else if (!handlerTokens[i]) {
 	    /*
-	     * Got a handler. Make sure that any pending patch-up actions from
-	     * previous unprocessed handlers are dealt with now that we know
-	     * where they are to jump to.
+	     * No handler. Will not be the last handler (that condition is
+	     * checked by the caller). Chain to the next one.
 	     */
 
-	    if (forwardsNeedFixing) {
-		forwardsNeedFixing = 0;
-		OP1(			JUMP1, 7);
-		for (j=0 ; j<i ; j++) {
-		    if (forwardsToFix[j] == -1) {
-			continue;
-		    }
-		    FIXJUMP4(forwardsToFix[j]);
-		    forwardsToFix[j] = -1;
-		}
-		OP4(			BEGIN_CATCH4, range);
-	    }
-	    envPtr->currStackDepth = savedStackDepth;
-	    BODY(			handlerTokens[i], 5+i*4);
-	    ExceptionRangeEnds(envPtr, range);
-	    OP(				PUSH_RETURN_OPTIONS);
-	    OP4(			REVERSE, 2);
-	    OP1(			JUMP1, 4);
-	    forwardsToFix[i] = -1;
-
-	    /*
-	     * Error in handler or setting of variables; replace the stored
-	     * exception with the new one. Note that we only push this if we
-	     * have either a body or some variable setting here. Otherwise
-	     * this code is unreachable.
-	     */
+	    forwardsNeedFixing = 1;
+	    JUMP4(			JUMP, forwardsToFix[i]);
+	    goto endOfThisArm;
+	}
 
-	finishTrapCatchHandling:
-	    ExceptionRangeTarget(envPtr, range, catchOffset);
-	    OP(				PUSH_RETURN_OPTIONS);
-	    OP(				PUSH_RESULT);
-	    OP(				END_CATCH);
-	    STORE(			resultVar);
-	    OP(				POP);
-	    STORE(			optionsVar);
-	    OP(				POP);
+	/*
+	 * Got a handler. Make sure that any pending patch-up actions from
+	 * previous unprocessed handlers are dealt with now that we know where
+	 * they are to jump to.
+	 */
 
-	endOfThisArm:
-	    if (i+1 < numHandlers) {
-		JUMP4(			JUMP, addrsToFix[i]);
-	    }
-	    if (matchClauses[i]) {
-		FIXJUMP4(notECJumpSource);
+	if (forwardsNeedFixing) {
+	    forwardsNeedFixing = 0;
+	    OP1(			JUMP1, 7);
+	    for (j=0 ; j<i ; j++) {
+		if (forwardsToFix[j] == -1) {
+		    continue;
+		}
+		FIXJUMP4(	forwardsToFix[j]);
+		forwardsToFix[j] = -1;
 	    }
-	    FIXJUMP4(notCodeJumpSource);
+	    OP4(			BEGIN_CATCH4, range);
 	}
+	BODY(				handlerTokens[i], 5+i*4);
+	ExceptionRangeEnds(envPtr, range);
+	PUSH(				"0");
+	OP(				PUSH_RETURN_OPTIONS);
+	OP4(				REVERSE, 3);
+	OP1(				JUMP1, 5);
+	TclAdjustStackDepth(-3, envPtr);
+	forwardsToFix[i] = -1;
 
 	/*
-	 * Fix all the jumps from taken clauses to here (the start of the
-	 * finally clause).
+	 * Error in handler or setting of variables; replace the stored
+	 * exception with the new one. Note that we only push this if we have
+	 * either a body or some variable setting here. Otherwise this code is
+	 * unreachable.
 	 */
 
-	for (i=0 ; i<numHandlers-1 ; i++) {
-	    FIXJUMP4(addrsToFix[i]);
+    finishTrapCatchHandling:
+	ExceptionRangeTarget(envPtr, range, catchOffset);
+	OP(				PUSH_RETURN_OPTIONS);
+	OP(				PUSH_RETURN_CODE);
+	OP(				PUSH_RESULT);
+	OP(				END_CATCH);
+	STORE(				resultVar);
+	OP(				POP);
+	PUSH(				"1");
+	OP(				EQ);
+	JUMP1(				JUMP_FALSE, noTrapError);
+	LOAD(				optionsVar);
+	PUSH(				"-during");
+	OP4(				REVERSE, 3);
+	STORE(				optionsVar);
+	OP(				POP);
+	OP44(				DICT_SET, 1, optionsVar);
+	TclAdjustStackDepth(-1, envPtr);
+	JUMP1(				JUMP, trapError);
+	FIXJUMP1(		noTrapError);
+	STORE(				optionsVar);
+	FIXJUMP1(		trapError);
+	/* Skip POP at end; can clean up with subsequent POP */
+	if (i+1 < numHandlers) {
+	    OP(				POP);
+	} else {
+	    TclAdjustStackDepth(-1, envPtr);
+	}
+
+    endOfThisArm:
+	if (i+1 < numHandlers) {
+	    JUMP4(			JUMP, addrsToFix[i]);
 	}
-	TclStackFree(interp, forwardsToFix);
-	TclStackFree(interp, addrsToFix);
+	TclAdjustStackDepth(1, envPtr);
+	if (matchClauses[i]) {
+	    FIXJUMP4(		notECJumpSource);
+	}
+	FIXJUMP4(		notCodeJumpSource);
     }
 
     /*
-     * Drop the result code.
+     * Drop the result code, and fix all the jumps from taken clauses - which
+     * drop the result code as their first action - to point straight after
+     * (i.e., to the start of the finally clause).
      */
 
     OP(					POP);
+    for (i=0 ; i<numHandlers-1 ; i++) {
+	FIXJUMP4(		addrsToFix[i]);
+    }
+    TclStackFree(interp, forwardsToFix);
+    TclStackFree(interp, addrsToFix);
 
     /*
      * Process the finally clause (at last!) Note that we do not wrap this in
@@ -2694,15 +2740,44 @@ IssueTryClausesFinallyInstructions(
      */
 
     if (!trapZero) {
-	FIXJUMP4(	afterBody);
+	FIXJUMP4(		afterBody);
     }
-    envPtr->currStackDepth = savedStackDepth;
+    range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+    OP4(				BEGIN_CATCH4, range);
+    ExceptionRangeStarts(envPtr, range);
     BODY(				finallyToken, 3 + 4*numHandlers);
+    ExceptionRangeEnds(envPtr, range);
+    OP(					END_CATCH);
     OP(					POP);
+    JUMP1(				JUMP, finalOK);
+    ExceptionRangeTarget(envPtr, range, catchOffset);
+    OP(					PUSH_RESULT);
+    OP(					PUSH_RETURN_OPTIONS);
+    OP(					PUSH_RETURN_CODE);
+    OP(					END_CATCH);
+    PUSH(				"1");
+    OP(					EQ);
+    JUMP1(				JUMP_FALSE, noFinalError);
+    LOAD(				optionsVar);
+    PUSH(				"-during");
+    OP4(				REVERSE, 3);
+    STORE(				optionsVar);
+    OP(					POP);
+    OP44(				DICT_SET, 1, optionsVar);
+    TclAdjustStackDepth(-1, envPtr);
+    OP(					POP);
+    JUMP1(				JUMP, finalError);
+    TclAdjustStackDepth(1, envPtr);
+    FIXJUMP1(			noFinalError);
+    STORE(				optionsVar);
+    OP(					POP);
+    FIXJUMP1(			finalError);
+    STORE(				resultVar);
+    OP(					POP);
+    FIXJUMP1(			finalOK);
     LOAD(				optionsVar);
     LOAD(				resultVar);
     OP(					RETURN_STK);
-    envPtr->currStackDepth = savedStackDepth + 1;
 
     return TCL_OK;
 }
-- 
cgit v0.12