diff options
| -rw-r--r-- | generic/tclCmdMZ.c | 21 | ||||
| -rw-r--r-- | generic/tclExecute.c | 18 | ||||
| -rw-r--r-- | generic/tclInt.h | 1 | ||||
| -rw-r--r-- | tests/cmdMZ.test | 43 |
4 files changed, 63 insertions, 20 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d36b0f0..255fca1 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4009,7 +4009,6 @@ Tcl_TimeRateObjCmd( TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST }; ByteCode *codePtr = NULL; - int codeOptimized = 0; for (i = 1; i < objc - 1; i++) { int index; @@ -4194,15 +4193,6 @@ Tcl_TimeRateObjCmd( } codePtr = TclCompileObj(interp, objPtr, NULL, 0); TclPreserveByteCode(codePtr); - /* - * Replace last compiled done instruction with continue: it's a part of - * iteration, this way evaluation will be more similar to a cycle (also - * avoids extra overhead to set result to interp, etc.) - */ - if (codePtr->codeStart[codePtr->numCodeBytes-1] == INST_DONE) { - codePtr->codeStart[codePtr->numCodeBytes-1] = INST_CONTINUE; - codeOptimized = 1; - } } /* @@ -4243,6 +4233,12 @@ Tcl_TimeRateObjCmd( count++; if (!direct) { /* precompiled */ + /* + * Use loop optimized TEBC call (TCL_EVAL_DISCARD_RESULT): it's a part of + * iteration, this way evaluation will be more similar to a cycle (also + * avoids extra overhead to set result to interp, etc.) + */ + ((Interp *)interp)->evalFlags |= TCL_EVAL_DISCARD_RESULT; result = TclExecuteByteCode(interp, codePtr); } else { /* eval */ result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); @@ -4492,11 +4488,6 @@ Tcl_TimeRateObjCmd( done: if (codePtr != NULL) { - if ( codeOptimized - && codePtr->codeStart[codePtr->numCodeBytes-1] == INST_CONTINUE - ) { - codePtr->codeStart[codePtr->numCodeBytes-1] = INST_DONE; - } TclReleaseByteCode(codePtr); } return result; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0c2baab..7a8bf39 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1790,6 +1790,7 @@ TclExecuteByteCode( Tcl_Obj *expandNestList = NULL; int checkInterp = 0; /* Indicates when a check of interp readyness * is necessary. Set by CACHE_STACK_INFO() */ + int curEvalFlags = iPtr->evalFlags; /* * Transfer variables - needed only between opcodes, but not while @@ -1819,6 +1820,12 @@ TclExecuteByteCode( const char *curInstName = NULL; /* + * Reset discard result flag - because it is applicable for this call only, + * and should not affect all the nested invocations may return result. + */ + iPtr->evalFlags &= ~TCL_EVAL_DISCARD_RESULT; + + /* * The execution uses a unified stack: first the catch stack, immediately * above it a CmdFrame, then the execution stack. * @@ -2051,6 +2058,15 @@ TclExecuteByteCode( case INST_DONE: if (tosPtr > initTosPtr) { + + if ((curEvalFlags & TCL_EVAL_DISCARD_RESULT) && (result == TCL_OK)) { + /* simulate pop & fast done (like it does continue in loop) */ + Tcl_Obj *objPtr; + TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); + goto abnormalReturn; + } /* * Set the interpreter's object result to point to the topmost * object from the stack, and check for a possible [catch]. The @@ -7403,7 +7419,7 @@ TclExecuteByteCode( */ /* - * Abnormal return code. Restore the stack to state it had when + * Done or abnormal return code. Restore the stack to state it had when * starting to execute the ByteCode. Panic if the stack is below the * initial level. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 974dd0d..12634f9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1979,6 +1979,7 @@ typedef struct Interp { #define TCL_ALLOW_EXCEPTIONS 4 #define TCL_EVAL_FILE 2 #define TCL_EVAL_CTX 8 +#define TCL_EVAL_DISCARD_RESULT 0X40 /* * Flag bits for Interp structures: diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index e7c8e6c..45d68b3 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -358,6 +358,24 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { "error foo" invoked from within "time {error foo}"}} +test cmdMZ-5.7.1 {Tcl_TimeObjCmd: return from time} { + set x 0 + proc r1 {} {upvar x x; time {incr x; return "r1"; incr x} 10} + list [r1] $x +} {r1 1} +test cmdMZ-5.8 {Tcl_TimeObjCmd: done optimization: nested call of self inside time (if compiled)} { + set x [set y 0] + set m1 { + if {[incr x] <= 5} { + # nested call should return result, so covering that: + if {![string is integer -strict [eval $m1]]} {error unexpected} + } + # increase again (no "continue" from nested call): + incr x + } + time {incr y; eval $m1} 5 + list $y $x +} {5 20} test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} { list [catch {timerate} msg] $msg @@ -404,6 +422,11 @@ test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} { "error foo" invoked from within "timerate {error foo} 1"}} +test cmdMZ-6.7.1 {Tcl_TimeRateObjCmd: return from timerate} { + set x 0 + proc r1 {} {upvar x x; timerate {incr x; return "r1"; incr x} 1000 10} + list [r1] $x +} {r1 1} test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} { set m1 [timerate {break}] list \ @@ -415,10 +438,10 @@ test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} { test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} { set m1 [timerate {continue; return -code error "unexpected"} 1000 10] list \ - [expr {[lindex $m1 0] < 1000}] \ - [expr {[lindex $m1 2] == 10}] \ - [expr {[lindex $m1 4] > 1000}] \ - [expr {[lindex $m1 6] < 100}] + [expr {[lindex $m1 0] < 1000}] \ + [expr {[lindex $m1 2] == 10}] \ + [expr {[lindex $m1 4] > 1000}] \ + [expr {[lindex $m1 6] < 100}] } {1 1 1 1} test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} { set m1 [timerate {} 1000 5]; # max-count wins @@ -439,6 +462,18 @@ test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} { timerate $m1 1000 10 if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop } ok +test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self inside timerate} { + set x 0 + set m1 { + if {[incr x] <= 5} { + # nested call should return result, so covering that: + if {![string is integer -strict [eval $m1]]} {error unexpected} + } + # increase again (no "continue" from nested call): + incr x + } + list [lindex [timerate $m1 1000 5] 2] $x +} {5 20} # The tests for Tcl_WhileObjCmd are in while.test |