diff options
| -rw-r--r-- | generic/tclBasic.c | 3 | ||||
| -rw-r--r-- | generic/tclCompCmdsSZ.c | 53 | ||||
| -rw-r--r-- | generic/tclCompile.c | 5 | ||||
| -rw-r--r-- | generic/tclCompile.h | 1 | ||||
| -rw-r--r-- | generic/tclExecute.c | 49 | ||||
| -rw-r--r-- | tests/tailcall.test | 70 |
6 files changed, 177 insertions, 4 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index afc17c5..0d9cd89 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -363,7 +363,7 @@ static const CmdInfo builtInCmds[] = { {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE}, {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE}, {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE}, - {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE}, + {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE}, {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE}, {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, @@ -8817,6 +8817,7 @@ TclNRTailcallObjCmd( listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj(nsPtr)); + Tcl_IncrRefCount(listPtr); iPtr->varFramePtr->tailcallPtr = listPtr; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 41bc866..da6d2d0 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2697,11 +2697,64 @@ TclCompileTailcallCmd( OP( NS_CURRENT); for (i=1 ; i<numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + goto tailcallExpanded; + } + } + tokenPtr = parsePtr->tokenPtr; + + for (i=1 ; i<numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); // TODO: If the first token is a literal, add LITERAL_CMD_NAME to its flags PUSH_TOKEN( tokenPtr, i); } OP4( TAILCALL, numWords); return TCL_OK; + + tailcallExpanded: + { + Tcl_Size build = 0; + int concat = 0; + + tokenPtr = parsePtr->tokenPtr; + for (i = 1; i < numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + PUSH_TOKEN( tokenPtr, i); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + if (concat) { + OP( LIST_CONCAT); + } else { + concat = 1; + } + } else { + build++; + } + if (build > (1 << 12)) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + } + if (build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + } + } + OP( TAILCALL_LIST); + return TCL_OK; } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a3008c5..6e2a161 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -955,6 +955,11 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... value => ... * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ + TCL_INSTRUCTION_ENTRY( + "tailcallList", -1), + /* Do a tailcall with the words from wordList as the thing to + * tailcall to, and currNs is the namespace scope. + * Stack: ... currNs wordList => ...[NOT REACHED] */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1c184d3..4d68732 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -931,6 +931,7 @@ enum TclInstruction { INST_DICT_REMOVE, INST_IS_EMPTY, INST_JUMP_TABLE_NUM, + INST_TAILCALL_LIST, /* The last opcode */ LAST_INST_OPCODE diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9a1d8cb..d3712bd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2576,8 +2576,7 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG - /* FIXME: What is the right thing to trace? */ - { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { Tcl_Size i; TRACE(("%u [", (unsigned) numArgs)); @@ -2587,7 +2586,7 @@ TEBCresume( TRACE_APPEND((" ")); } } - TRACE_APPEND(("] => RETURN...\n")); + TRACE_APPEND(("] => REGISTERED TAILCALL...\n")); } #endif @@ -2609,12 +2608,56 @@ TEBCresume( Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); } iPtr->varFramePtr->tailcallPtr = listPtr; + Tcl_IncrRefCount(listPtr); result = TCL_RETURN; cleanup = numArgs; goto processExceptionReturn; } + case INST_TAILCALL_LIST: + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { + TRACE((" => ERROR: tailcall in non-proc context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (char *)NULL); + CACHE_STACK_INFO(); + goto gotError; + } + + { + Tcl_Obj *listPtr = OBJ_AT_TOS; + // nsPtr = OBJ_UNDER_TOS; // Don't need this variable +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { + TRACE(("%s [", O2S(OBJ_UNDER_TOS))); + TclPrintObject(stdout, listPtr, 40); + TRACE_APPEND(("] => REGISTERED TAILCALL...\n")); + } +#endif + + /* + * Push the evaluation of the called command into the NR callback + * stack. + */ + + if (iPtr->varFramePtr->tailcallPtr) { + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); + } + if (Tcl_IsShared(listPtr)) { + listPtr = Tcl_DuplicateObj(listPtr); + } + // TODO: Consider requiring a blank or the NS at the start of the list. + Tcl_ListObjReplace(NULL, listPtr, 0, 0, 1, &OBJ_UNDER_TOS); + Tcl_IncrRefCount(listPtr); + iPtr->varFramePtr->tailcallPtr = listPtr; + + result = TCL_RETURN; + cleanup = 2; + goto processExceptionReturn; + } + case INST_DONE: if (tosPtr > initTosPtr) { diff --git a/tests/tailcall.test b/tests/tailcall.test index 0016845..6edf8b8 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -49,6 +49,24 @@ if {[testConstraint testnrelevels]} { proc errorcode options { dict get [dict merge {-errorcode NONE} $options] -errorcode } + +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup { proc a i { @@ -708,6 +726,58 @@ test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body { } } -returnCodes 1 -result {namespace "::ns" not found} +test tailcall-15.1 {tailcall memory leak check} -constraints memory -setup { + proc foo {args} {llength $args} +} -body { + list [ + apply {cmd { + $cmd foo 1 2 3 4 5 + }} tailcall + ] [ + leaktest { + apply {cmd { + $cmd foo 1 2 3 4 5 + }} tailcall + } + ] +} -cleanup { + rename foo {} +} -result {5 0} +test tailcall-15.2 {tailcall memory leak check} -constraints memory -setup { + proc foo {args} {llength $args} +} -body { + list [ + apply {{} { + tailcall foo 1 2 3 4 5 + }} + ] [ + leaktest { + apply {{} { + tailcall foo 1 2 3 4 5 + }} + } + ] +} -cleanup { + rename foo {} +} -result {5 0} +test tailcall-15.3 {tailcall memory leak check} -constraints memory -setup { + proc foo {args} {llength $args} +} -body { + list [ + apply {args { + tailcall foo 1 2 {*}$args 3 4 {*}$args 5 + }} a b c + ] [ + leaktest { + apply {args { + tailcall foo 1 2 {*}$args 3 4 {*}$args 5 + }} a b c + } + ] +} -cleanup { + rename foo {} +} -result {11 0} + test tailcall-bug-784befb0ba {tailcall crash with 254 args} -body { proc tccrash args {llength $args} # Must be EXACTLY 254 for crash |