summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2013-10-15 00:27:56 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2013-10-15 00:27:56 (GMT)
commit21e6601f4971f249f7681508432b98605729fb9d (patch)
tree7ee2b0d64d3baf69e1ed93317f150a8d59b9b25f
parent9adfa74f671acd5bcc33247b07176d117eda3357 (diff)
downloadtcl-21e6601f4971f249f7681508432b98605729fb9d.zip
tcl-21e6601f4971f249f7681508432b98605729fb9d.tar.gz
tcl-21e6601f4971f249f7681508432b98605729fb9d.tar.bz2
Do jump generation at places where INST_RETURN_IMM might occur.
-rw-r--r--generic/tclCompCmdsGR.c18
-rw-r--r--generic/tclCompile.c6
-rw-r--r--generic/tclOptimize.c18
-rw-r--r--tests/compile.test64
4 files changed, 99 insertions, 7 deletions
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 3efcba7..5513b01 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -2480,7 +2480,6 @@ TclCompileReturnCmd(
* emit the INST_RETURN_IMM instruction with code and level as operands.
*/
- // TODO: when (code==TCL_BREAK || code==TCL_CONTINUE)&&(level==0&&size==0), check for stack balance and jump opportunities
CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
return TCL_OK;
@@ -2522,6 +2521,23 @@ CompileReturnInternal(
int level,
Tcl_Obj *returnOpts)
{
+ if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) {
+ ExceptionRange *rangePtr;
+ ExceptionAux *exceptAux;
+
+ rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ TclCleanupStackForBreakContinue(envPtr, exceptAux);
+ if (code == TCL_BREAK) {
+ TclAddLoopBreakFixup(envPtr, exceptAux);
+ } else {
+ TclAddLoopContinueFixup(envPtr, exceptAux);
+ }
+ Tcl_DecrRefCount(returnOpts);
+ return;
+ }
+ }
+
TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
TclEmitInstInt4(op, code, envPtr);
TclEmitInt4(level, envPtr);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 68b7649..427ccab 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -3931,8 +3931,7 @@ TclEmitInvoke(
va_list argList;
ExceptionRange *rangePtr;
ExceptionAux *auxBreakPtr, *auxContinuePtr;
- int arg1, arg2, wordCount = 0, loopRange, predictedDepth;
- int breakRange = -1, continueRange = -1;
+ int arg1, arg2, wordCount = 0, loopRange, breakRange, continueRange;
/*
* Parse the arguments.
@@ -3995,7 +3994,6 @@ TclEmitInvoke(
loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
ExceptionRangeStarts(envPtr, loopRange);
}
- predictedDepth = envPtr->currStackDepth - wordCount;
/*
* Issue the invoke itself.
@@ -4047,7 +4045,6 @@ TclEmitInvoke(
if (auxBreakPtr != NULL) {
TclAdjustStackDepth(-1, envPtr);
- assert(envPtr->currStackDepth == predictedDepth);
exceptAux->stackDepth = auxBreakPtr->stackDepth;
exceptAux->expandTarget = auxBreakPtr->expandTarget;
@@ -4061,7 +4058,6 @@ TclEmitInvoke(
if (auxContinuePtr != NULL) {
TclAdjustStackDepth(-1, envPtr);
- assert(envPtr->currStackDepth == predictedDepth);
exceptAux->stackDepth = auxContinuePtr->stackDepth;
exceptAux->expandTarget = auxContinuePtr->expandTarget;
diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
index b7f4173..3b16e6e 100644
--- a/generic/tclOptimize.c
+++ b/generic/tclOptimize.c
@@ -344,21 +344,28 @@ AdvanceJumps(
CompileEnv *envPtr)
{
unsigned char *currentInstPtr;
+ Tcl_HashTable jumps;
for (currentInstPtr = envPtr->codeStart ;
currentInstPtr < envPtr->codeNext-1 ;
currentInstPtr += AddrLength(currentInstPtr)) {
- int offset, delta;
+ int offset, delta, isNew;
switch (*currentInstPtr) {
case INST_JUMP1:
case INST_JUMP_TRUE1:
case INST_JUMP_FALSE1:
offset = TclGetInt1AtPtr(currentInstPtr + 1);
+ Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS);
for (delta=0 ; offset+delta != 0 ;) {
if (offset + delta < -128 || offset + delta > 127) {
break;
}
+ Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
+ if (!isNew) {
+ offset = TclGetInt1AtPtr(currentInstPtr + 1);
+ break;
+ }
offset += delta;
switch (*(currentInstPtr + offset)) {
case INST_NOP:
@@ -373,13 +380,21 @@ AdvanceJumps(
}
break;
}
+ Tcl_DeleteHashTable(&jumps);
TclStoreInt1AtPtr(offset, currentInstPtr + 1);
continue;
case INST_JUMP4:
case INST_JUMP_TRUE4:
case INST_JUMP_FALSE4:
+ Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS);
+ Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew);
for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {
+ Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
+ if (!isNew) {
+ offset = TclGetInt4AtPtr(currentInstPtr + 1);
+ break;
+ }
switch (*(currentInstPtr + offset)) {
case INST_NOP:
offset += InstLength(INST_NOP);
@@ -393,6 +408,7 @@ AdvanceJumps(
}
break;
}
+ Tcl_DeleteHashTable(&jumps);
TclStoreInt4AtPtr(offset, currentInstPtr + 1);
continue;
}
diff --git a/tests/compile.test b/tests/compile.test
index 51db0a2..36e24de 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -713,6 +713,70 @@ test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
apply {{} {list [if 1]}}
} -returnCodes error -match glob -result *
+test compile-20.1 {ensure there are no infinite loops in optimizing} {
+ tcl::unsupported::disassemble script {
+ while 1 {
+ return -code continue -level 0
+ }
+ }
+ return
+} {}
+test compile-20.2 {ensure there are no infinite loops in optimizing} {
+ tcl::unsupported::disassemble script {
+ while 1 {
+ while 1 {
+ return -code break -level 0
+ }
+ }
+ }
+ return
+} {}
+
+test compile-21.1 {stack balance management} {
+ apply {{} {
+ set result {}
+ while 1 {
+ lappend result a
+ lappend result [list b [break]]
+ lappend result c
+ }
+ return $result
+ }}
+} a
+test compile-21.2 {stack balance management} {
+ apply {{} {
+ set result {}
+ while {[incr i] <= 10} {
+ lappend result $i
+ lappend result [list b [continue] c]
+ lappend result c
+ }
+ return $result
+ }}
+} {1 2 3 4 5 6 7 8 9 10}
+test compile-21.3 {stack balance management} {
+ apply {args {
+ set result {}
+ while 1 {
+ lappend result a
+ lappend result [concat {*}$args [break]]
+ lappend result c
+ }
+ return $result
+ }} P Q R S T
+} a
+test compile-21.4 {stack balance management} {
+ apply {args {
+ set result {}
+ while {[incr i] <= 10} {
+ lappend result $i
+ lappend result [concat {*}$args [continue] c]
+ lappend result c
+ }
+ return $result
+ }} P Q R S T
+} {1 2 3 4 5 6 7 8 9 10}
+
# TODO sometime - check that bytecode from tbcload is *not* disassembled.
# cleanup