diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclBasic.c | 69 | ||||
| -rw-r--r-- | generic/tclCompile.h | 4 | ||||
| -rw-r--r-- | generic/tclExecute.c | 91 | ||||
| -rw-r--r-- | generic/tclTest.c | 15 | ||||
| -rw-r--r-- | tests/NRE.test | 114 |
6 files changed, 179 insertions, 120 deletions
@@ -1,5 +1,11 @@ 2008-07-30 Miguel Sofer <msofer@users.sf.net> + * generic/tclBasic.c: Improved tailcalls. + * generic/tclCompile.h: + * generic/tclExecute.c: + * generic/tclTest.c: + * tests/NRE.test: + * generic/tclBasic.c (TclNREvalObjEx): new comments and code reorg to clarify what is happening. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fd93641..fa42894 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.338 2008/07/30 17:54:23 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.339 2008/07/31 00:43:09 msofer Exp $ */ #include "tclInt.h" @@ -130,7 +130,8 @@ static Tcl_NRPostProc TEOEx_ByteCodeCallback; static Tcl_NRPostProc NRCommand; static Tcl_NRPostProc NRRunObjProc; -static Tcl_NRPostProc EvalTailcall; +static Tcl_NRPostProc TailcallEval; +static Tcl_NRPostProc TailcallCleanup; #define NR_IS_COMMAND(callbackPtr) \ (callbackPtr \ @@ -4180,7 +4181,7 @@ TclNRRunCallbacks( if (tebcCall) { if ((callbackPtr->procPtr == NRRunBytecode) || - (callbackPtr->procPtr == NRDropCommand)) { + (callbackPtr->procPtr == NRDoTailcall)) { /* * TEBC pass thru: let the caller tebc handle and get rid of * this callback. @@ -4190,6 +4191,16 @@ TclNRRunCallbacks( } } + if (callbackPtr->procPtr == NRDoTailcall) { + /* + * It is an error to schedule a tailcall in this situation. + */ + + Tcl_SetResult(interp, + "tailcall can only be called from a proc or lambda", TCL_STATIC); + result = TCL_ERROR; + } + /* * IMPLEMENTATION REMARKS (FIXME) * @@ -4273,7 +4284,7 @@ NRRunBytecode( } int -NRDropCommand( +NRDoTailcall( ClientData data[], Tcl_Interp *interp, int result) @@ -5666,7 +5677,7 @@ TclNREvalObjEx( * evaluation of canonical lists, compileation and bytecode execution and * finally direct evaluation. Precisely one of these blocks will be run. */ - + if ((objPtr->typePtr == &tclListType) && /* is a list... */ ((objPtr->bytes == NULL || /* ...without a string rep */ listRepPtr->canonicalFlag))) { /* ...or that is canonical */ @@ -5810,7 +5821,7 @@ TclNREvalObjEx( * the easy dynamic branch. No need to perform more complex * invokations. */ - + int pc = 0; CmdFrame *ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); @@ -5841,7 +5852,7 @@ TclNREvalObjEx( /* * Absolute context to reuse. */ - + iPtr->invokeCmdFramePtr = ctxPtr; iPtr->evalFlags |= TCL_EVAL_CTX; @@ -5862,7 +5873,7 @@ TclNREvalObjEx( return result; } } - + static int TEOEx_ByteCodeCallback( ClientData data[], @@ -7886,26 +7897,11 @@ TclTailcallObjCmd( count += NR_IS_COMMAND(tailPtr); } -#if 1 if (!iPtr->varFramePtr->isProcCallFrame) { - /* FIXME! Why error? Just look if we have a TEOV above! */ Tcl_SetResult(interp, "tailcall can only be called from a proc or lambda", TCL_STATIC); return TCL_ERROR; } -#else - if (!tailPtr->nextPtr) { - /* FIXME! Is this the behaviour we want? */ - Tcl_SetResult(interp, - "cannot tailcall: not running a command", TCL_STATIC); - return TCL_ERROR; - } -#endif - - /* - * Temporarily put NULL as the TOP_BC, register a callback, then - * replug things back the way they were. - */ nsPtr->activationCount++; if (objc == 2) { @@ -7913,18 +7909,22 @@ TclTailcallObjCmd( } else { scriptPtr = Tcl_NewListObj(objc-1, objv+1); } + Tcl_IncrRefCount(scriptPtr); + + /* + * Add two callbacks: first the one to actually evaluate the tailcalled + * command, then the one that signals TEBC to stash the first at its + * proper place. + */ - TOP_CB(iPtr) = tailPtr->nextPtr; - TclNRAddCallback(interp, EvalTailcall, scriptPtr, nsPtr, NULL, NULL); - tailPtr->nextPtr = TOP_CB(iPtr); - TOP_CB(iPtr) = rootPtr; + TclNRAddCallback(interp, TailcallEval, scriptPtr, nsPtr, NULL, NULL); + TclNRAddCallback(interp, NRDoTailcall, NULL, NULL, NULL, NULL); - TclNRAddCallback(interp, NRDropCommand, NULL, NULL, NULL, NULL); return TCL_OK; } static int -EvalTailcall( +TailcallEval( ClientData data[], Tcl_Interp *interp, int result) @@ -7933,6 +7933,7 @@ EvalTailcall( Tcl_Obj *scriptPtr = data[0]; Namespace *nsPtr = data[1]; + TclNRAddCallback(interp, TailcallCleanup, scriptPtr, NULL, NULL, NULL); if (result == TCL_OK) { iPtr->lookupNsPtr = nsPtr; result = TclNREvalObjEx(interp, scriptPtr, 0, NULL, 0); @@ -7950,6 +7951,16 @@ EvalTailcall( } return result; } + +static int +TailcallCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_DecrRefCount((Tcl_Obj *) data[0]); + return result; +} void Tcl_NRAddCallback( diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c5ab71d..8d1db2c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.97 2008/07/29 05:30:25 msofer Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.98 2008/07/31 00:43:09 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -838,7 +838,7 @@ typedef struct { */ MODULE_SCOPE Tcl_NRPostProc NRRunBytecode; -MODULE_SCOPE Tcl_NRPostProc NRDropCommand; +MODULE_SCOPE Tcl_NRPostProc NRDoTailcall; /* *---------------------------------------------------------------- diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9574e0f..2a1d232 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.390 2008/07/29 20:53:21 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.391 2008/07/31 00:43:09 msofer Exp $ */ #include "tclInt.h" @@ -1815,28 +1815,59 @@ TclExecuteByteCode( TCLNR_FREE(interp, callbackPtr); if (procPtr == NRRunBytecode) { - NR_DATA_BURY(); /* this level's state variables */ + /* + * A request to run a bytecode: record this level's state + * variables, swap codePtr and start running the new one. + */ + + NR_DATA_BURY(); codePtr = newCodePtr; - } else if (procPtr == NRDropCommand) { + } else if (procPtr == NRDoTailcall) { /* - * A request to perform a tailcall: just drop this - * bytecode as it is; the tailCall has been scheduled in - * the callbacks. + * A request to perform a tailcall: schedule the tailcall callback + * at its proper place, then just drop the present bytecode. */ + + TEOV_callback *tailcallPtr = TOP_CB(interp); + TEOV_callback *tmpPtr = tailcallPtr; + + if (catchTop != initCatchTop) { + /* FIXME!! If we catch it, the tailcall callback is still in + * and will be run when we return! Should we fish it out? */ + + result = TCL_ERROR; + Tcl_SetResult(interp,"Tailcall called from within a catch environment", + TCL_STATIC); + goto checkForCatch; + } + + TOP_CB(interp) = tailcallPtr->nextPtr; #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { fprintf(stdout, " Tailcall: request received\n"); } #endif - if (catchTop != initCatchTop) { + if (bottomPtr->prevBottomPtr) { + while (tmpPtr->nextPtr != bottomPtr->prevBottomPtr->rootPtr) { + tmpPtr = tmpPtr->nextPtr; + } + tailcallPtr->nextPtr = tmpPtr->nextPtr; + tmpPtr->nextPtr = tailcallPtr; + goto abnormalReturn; /* drop a level */ + } else { + /* + * This will fall off TEBC; how do we know where to put it? It + * should be after all cleanup of the current command is done, + * but we do not know where that is. + */ + + Tcl_SetResult(interp, + "tailcall would fall off tebc!", TCL_STATIC); result = TCL_ERROR; - Tcl_SetResult(interp,"Tailcall called from within a catch environment", - TCL_STATIC); goto checkForCatch; } - goto abnormalReturn; /* drop a level */ } else { - Tcl_Panic("TEBC: TRCB sent us a record we cannot handle! (1)"); + Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle! (1)"); } } nested = 1; @@ -7661,8 +7692,8 @@ TclExecuteByteCode( DECACHE_STACK_INFO(); if (TOP_CB(interp) == bottomPtr->rootPtr) { /* - * The bytecode is returning, remove the caller's arguments and - * keep processing the caller. + * The bytecode is returning, all callbacks were run. Remove the + * caller's arguments and keep processing the caller. */ while (cleanup--) { @@ -7672,32 +7703,20 @@ TclExecuteByteCode( goto nonRecursiveCallReturn; } else { /* - * A request for a new execution: a tailcall. Remove the caller's - * arguments and start the new bytecode. - * - * FIXME KNOWNBUG: we get a pointer smash if we do remove the - * arguments, a leak otherwise: tailcalls are not yet quite - * there. Chose to leave the leak for now. + * One of the callbacks requested a new execution: a tailcall! + * Start the new bytecode. */ - TEOV_callback *callbackPtr = TOP_CB(interp); - Tcl_NRPostProc *procPtr = callbackPtr->procPtr; - - if (procPtr == NRRunBytecode) { - goto nonRecursiveCallStart; - } else if (procPtr == NRDropCommand) { - /* FIXME: 'tailcall tailcall' not yet working */ - Tcl_Panic("Tailcalls from within tailcalls are not yet implemented"); - if (catchTop != initCatchTop) { - result = TCL_ERROR; - Tcl_SetResult(interp,"Tailcall called from within a catch environment", - TCL_STATIC); - goto checkForCatch; - } - goto abnormalReturn; /* drop a level */ - } else { - Tcl_Panic("TEBC: TEOV sent us a record we cannot handle! (2)"); + if (TOP_CB(interp)->procPtr == NRDoTailcall) { +#if 1 + Tcl_Panic("'tailcall tailcall' not yet implemented");// +#endif + Tcl_SetResult(interp,"'tailcall tailcall' not yet implemented", + TCL_STATIC); + result = TCL_ERROR; + goto checkForCatch; } + goto nonRecursiveCallStart; } } return result; diff --git a/generic/tclTest.c b/generic/tclTest.c index 4ce4277..1cb6714 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,11 +14,12 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.119 2008/07/29 05:30:38 msofer Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.120 2008/07/31 00:43:10 msofer Exp $ */ #define TCL_TEST #include "tclInt.h" +#include "tclNRE.h" /* * Required for Testregexp*Cmd @@ -6545,7 +6546,9 @@ TestNRELevels( static ptrdiff_t *refDepth = NULL; ptrdiff_t depth; Tcl_Obj *levels[5]; - + int i = 0; + TEOV_callback *cbPtr = ((Interp *) interp)->execEnvPtr->callbackPtr; + if (refDepth == NULL) { refDepth = &depth; } @@ -6558,8 +6561,14 @@ TestNRELevels( levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); levels[4] = Tcl_NewIntObj((iPtr->execEnvPtr->execStackPtr->tosPtr - iPtr->execEnvPtr->execStackPtr->stackWords)); + + while (cbPtr) { + i++; + cbPtr = cbPtr->nextPtr; + } + levels[5] = Tcl_NewIntObj(i); - Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels)); + Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels)); return TCL_OK; } diff --git a/tests/NRE.test b/tests/NRE.test index bc0801a..dc306c7 100644 --- a/tests/NRE.test +++ b/tests/NRE.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: NRE.test,v 1.6 2008/07/29 23:18:07 msofer Exp $ +# RCS: @(#) $Id: NRE.test,v 1.7 2008/07/31 00:43:10 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -31,8 +31,8 @@ if {[testConstraint teststacklimit]} { namespace eval testnre { # - # [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level and tosPtr + # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, + # cmdFrame level, callFrame level, tosPtr and callback depth # variable last [testnrelevels] proc depthDiff {} { @@ -102,6 +102,20 @@ test NRE-1.2 {self-recursive lambdas} -setup { unset a } -result {0 20001} +test NRE-1.2a {self-recursive lambdas} -setup { + set a [list i { + set x [depthDiff] + if {[incr i] > 10} { + return [lrange $x 0 3] + } + apply $::a $i + }] +} -body { + apply $a 0 +} -cleanup { + unset a +} -result {0 1 1 1} + test NRE-1.2.1 {self-recursive lambdas} -setup { set a [list {} { if {[incr ::i] > 20000} { @@ -152,6 +166,22 @@ test NRE-2.1 {alias is not recursive} -setup { rename b {} } -result {0 {20001 20001}} +test NRE-2.1a {alias is not recursive} -setup { + proc a i { + set x [depthDiff] + if {[incr i] > 10} { + return [lrange $x 0 3] + } + b $i + } + interp alias {} b {} a +} -body { + list [a 0] [b 0] +} -cleanup { + rename a {} + rename b {} +} -result {{0 2 1 1} {0 2 1 1}} + # # Test that imports are non-recursive # @@ -159,8 +189,9 @@ test NRE-2.1 {alias is not recursive} -setup { test NRE-3.1 {imports are not recursive} -setup { namespace eval foo { proc a i { - if {[incr i] > 20000} { - return $i + set x [depthDiff] + if {[incr i] > 10} { + return [lrange $x 0 3] } ::a $i } @@ -169,17 +200,18 @@ test NRE-3.1 {imports are not recursive} -setup { namespace import foo::a a 1 } -body { - list [catch {a 0} msg] $msg + a 0 } -cleanup { rename a {} namespace delete ::foo -} -result {0 20001} +} -result {0 2 1 1} test NRE-4.1 {ensembles are not recursive} -setup { proc a i { - if {[incr i] > 20000} { - return $i + set x [depthDiff] + if {[incr i] > 10} { + return [lrange $x 0 3] } b foo $i } @@ -187,27 +219,28 @@ test NRE-4.1 {ensembles are not recursive} -setup { -command b \ -map [list foo a] } -body { - list [catch {list [a 0] [b foo 0]} msg] $msg + list [a 0] [b foo 0] } -cleanup { rename a {} rename b {} -} -result {0 {20001 20001}} +} -result {{0 2 1 1} {0 2 1 1}} test NRE-5.1 {[namespace eval] is not recursive} -setup { namespace eval ::foo { proc a i { - if {[incr i] > 20000} { - return $i + set x [depthDiff] + if {[incr i] > 10} { + return [lrange $x 0 3] } namespace eval ::foo [list a $i] } } } -body { - list [catch {::foo::a 0} msg] $msg + ::foo::a 0 } -cleanup { namespace delete ::foo -} -result {0 20001} +} -result {0 2 2 2} test NRE-5.2 {[namespace eval] is not recursive} -setup { namespace eval ::foo { @@ -227,16 +260,17 @@ test NRE-5.2 {[namespace eval] is not recursive} -setup { test NRE-6.1 {[uplevel] is not recursive} -setup { proc a i { - if {[incr i] > 20000} { - return $i + set x [depthDiff] + if {[incr i] > 10} { + return [lrange $x 0 3] } uplevel 1 [list a $i] } } -body { - list [catch {a 0} msg] $msg + a 0 } -cleanup { rename a {} -} -result {0 20001} +} -result {0 2 2 0} test NRE-6.2 {[uplevel] is not recursive} -setup { proc a i { @@ -366,7 +400,7 @@ test NRE-X.1 {eval in wrong interp} { namespace eval tcl::unsupported namespace export tailcall namespace import tcl::unsupported::tailcall -test NRE-T.0 {tailcall is constant space} -constraints {tailcall knownbug} -setup { +test NRE-T.0 {tailcall is constant space} -constraints {tailcall} -setup { proc a i { if {[incr i] > 10} { return [depthDiff] @@ -378,7 +412,7 @@ test NRE-T.0 {tailcall is constant space} -constraints {tailcall knownbug} -setu a 0 } -cleanup { rename a {} -} -result {0 0 0 0 0} +} -result {0 0 0 0 0 0} test NRE-T.1 {tailcall} -constraints {tailcall} -body { namespace eval a { @@ -593,39 +627,19 @@ test NRE-T.10 {tailcall tailcall} -constraints {tailcall knownbug} -setup { namespace delete ::foo } -result dcbacd -test NRE-T.11 {tailcall tailcall} -constraints {tailcall knownbug} -setup { - namespace eval ::foo { - variable res {} - proc a {} { - variable res - append res a - tailcall {tailcall {set x 1}} - append res a - } - proc b {} { - variable res - append res b - a - append res b - } - proc c {} { - variable res - append res c - b - append res c - } - proc d {} { - variable res - append res d - c - append res d + +test NRE-T.11 {tailcall factorial} -constraints {tailcall} -setup { + proc fact {n {b 1}} { + if {$n == 1} { + return $b } + tailcall fact [expr {$n-1}] [expr {$n*$b}] } } -body { - namespace eval ::foo d + list [fact 1] [fact 5] [fact 10] [fact 15] } -cleanup { - namespace delete ::foo -} -result dcbacd + rename fact {} +} -result {1 120 3628800 1307674368000} namespace forget tcl::unsupported::tailcall |