diff options
| -rw-r--r-- | generic/tclExecute.c | 30 | ||||
| -rw-r--r-- | generic/tclTest.c | 21 | ||||
| -rw-r--r-- | tests/execute.test | 81 |
3 files changed, 116 insertions, 16 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 832054e..779f4a2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2168,7 +2168,7 @@ TEBCresume( int cleanup = PTR2INT(data[2]); Tcl_Obj *objResultPtr; - int checkInterp; /* Indicates when a check of interp readyness + int checkInterp = 0; /* Indicates when a check of interp readyness * is necessary. Set by CACHE_STACK_INFO() */ /* @@ -2203,7 +2203,6 @@ TEBCresume( if (!pc) { /* bytecode is starting from scratch */ - checkInterp = 0; pc = codePtr->codeStart; goto cleanup0; } else { @@ -2225,8 +2224,9 @@ TEBCresume( goto abnormalReturn; } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { - iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; + checkInterp = 1; + iPtr->flags |= ERR_ALREADY_LOGGED; } if (result != TCL_OK) { @@ -2400,12 +2400,12 @@ TEBCresume( iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); if (checkInterp) { - checkInterp = 0; if (((codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto instStartCmdFailed; } + checkInterp = 0; } inst = *(pc += 9); goto peepholeStart; @@ -2975,15 +2975,18 @@ TEBCresume( * INVOCATION BLOCK */ - instEvalStk: case INST_EVAL_STK: + instEvalStk: bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; cleanup = 1; pc += 1; + /* yield next instruction */ TEBC_YIELD(); - return TclNREvalObjEx(interp, OBJ_AT_TOS, 0, NULL, 0); + /* add TEBCResume for object at top of stack */ + return TclNRExecuteByteCode(interp, + TclCompileObj(interp, OBJ_AT_TOS, NULL, 0)); case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); @@ -8157,19 +8160,22 @@ TEBCresume( { const char *bytes; - checkInterp = 1; length = 0; + if (TclInterpReady(interp) == TCL_ERROR) { + goto gotError; + } + /* * We used to switch to direct eval; for NRE-awareness we now * compile and eval the command so that this evaluation does not - * add a new TEBC instance. [Bug 2910748] + * add a new TEBC instance. Bug [2910748], bug [fa6bf38d07] + * + * TODO: recompile, search this command and eval a code starting from, + * so that this evaluation does not add a new TEBC instance without + * NRE-trampoline. */ - if (TclInterpReady(interp) == TCL_ERROR) { - goto gotError; - } - codePtr->flags |= TCL_BYTECODE_RECOMPILE; bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); diff --git a/generic/tclTest.c b/generic/tclTest.c index 473368c..5e807d4 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -220,6 +220,9 @@ static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static int TestasyncCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestbumpinterpepochObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestpurebytesobjObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -584,6 +587,8 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", TestGetIndexFromObjStructObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testbumpinterpepoch", + TestbumpinterpepochObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testchannel", TestChannelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd, @@ -1022,6 +1027,22 @@ AsyncThreadProc( } #endif +static int +TestbumpinterpepochObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *)interp; + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + iPtr->compileEpoch++; + return TCL_OK; +} + /* *---------------------------------------------------------------------- * diff --git a/tests/execute.test b/tests/execute.test index e9668a9..72d79fd 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -37,6 +37,11 @@ testConstraint testobj [expr { testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] + +if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } +} + # Tests for the omnibus TclExecuteByteCode function: # INST_DONE not tested @@ -933,8 +938,7 @@ test execute-8.3 {Stack restoration} -setup { proc f {args} "f $arglst" proc run {} { # bump the interp's epoch - rename ::set ::dummy - rename ::dummy ::set + testbumpinterpepoch catch f msg set msg } @@ -948,8 +952,7 @@ test execute-8.4 {Compile epoch bump effect on stack trace} -setup { } proc FOO {} { catch {error bar} m o - rename ::set ::dummy - rename ::dummy ::set + testbumpinterpepoch return -options $o $m } } -body { @@ -978,6 +981,76 @@ test execute-8.5 {Bug 2038069} -setup { invoked from within "catch \[list error FOO\] m o"} -errorline 2} +test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup { + interp create slave + slave eval { + package require tcltest + catch [list package require -exact Tcltest [info patchlevel]] + ::tcltest::loadTestedCommands + if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } + } + } +} -body { + slave eval { + lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; + } + slave eval { + set i 0; while {[incr i] < 3} { + lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; + } + } + slave eval { + set i 0; while {[incr i] < 3} { + lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; + } + } + slave eval { + catch { + lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; + } + } + slave eval {set res} +} -cleanup { + interp delete slave +} -result [lrepeat 4 A B] +test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup { + interp create slave + slave eval { + package require tcltest + catch [list package require -exact Tcltest [info patchlevel]] + ::tcltest::loadTestedCommands + if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } + } + } +} -body { + set res {} + lappend res [catch { + slave eval { + lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C; + } + } e] $e + lappend res [catch { + slave eval { + lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; + } + } e] $e + lappend res [catch { + slave eval { + lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C; + } + } e] $e + lappend res [catch { + slave eval { + lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; + } + } e] $e + list $res [slave eval {set res}] +} -cleanup { + interp delete slave +} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]] + test execute-9.1 {Interp result resetting [Bug 1522803]} { set c 0 catch { |