summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCmdMZ.c21
-rw-r--r--generic/tclExecute.c20
-rw-r--r--generic/tclInt.h1
-rw-r--r--tests/cmdMZ.test43
4 files changed, 64 insertions, 21 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index cdc1e28..a754a09 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -4188,7 +4188,6 @@ Tcl_TimeRateObjCmd(
};
NRE_callback *rootPtr;
ByteCode *codePtr = NULL;
- int codeOptimized = 0;
for (i = 1; i < objc - 1; i++) {
int index;
@@ -4373,15 +4372,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;
- }
}
/*
@@ -4423,6 +4413,12 @@ Tcl_TimeRateObjCmd(
count++;
if (!direct) { /* precompiled */
rootPtr = TOP_CB(interp);
+ /*
+ * 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 = TclNRExecuteByteCode(interp, codePtr);
result = TclNRRunCallbacks(interp, result, rootPtr);
} else { /* eval */
@@ -4675,11 +4671,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 520c2ee..faf5865 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1981,7 +1981,14 @@ TclNRExecuteByteCode(
*/
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
- /* cleanup */ INT2PTR(0), NULL);
+ /* cleanup */ INT2PTR(0), INT2PTR(iPtr->evalFlags));
+
+ /*
+ * 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;
+
return TCL_OK;
}
@@ -2043,6 +2050,7 @@ TEBCresume(
#define auxObjList (TD->auxObjList)
#define catchTop (TD->catchTop)
#define codePtr (TD->codePtr)
+#define curEvalFlags PTR2INT(data[3]) /* calling iPtr->evalFlags */
/*
* Globals: variables that store state, must remain valid at all times.
@@ -2526,6 +2534,14 @@ TEBCresume(
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) */
+ 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
@@ -7695,7 +7711,7 @@ TEBCresume(
*/
/*
- * 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 7029173..adb4244 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2259,6 +2259,7 @@ typedef struct Interp {
#define TCL_EVAL_FILE 0x02
#define TCL_EVAL_SOURCE_IN_FRAME 0x10
#define TCL_EVAL_NORESOLVE 0x20
+#define TCL_EVAL_DISCARD_RESULT 0x40
/*
* Flag bits for Interp structures:
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index 60b104f..e4db915 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -349,6 +349,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
@@ -395,6 +413,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 \
@@ -406,10 +429,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
@@ -430,6 +453,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}
test cmdMZ-try-1.0 {
generated by cgit v0.12 at 2025-12-12 02:09:20 (GMT)