From a7dc229d16889c9f6f66d197d4e0bf1afbec5578 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 Nov 2012 18:06:09 +0000 Subject: Added compilation of [tailcall]. Not a particularly efficient compilation though; it does not detect tailcall-of-self as a special case. --- generic/tclAssembly.c | 6 +++--- generic/tclBasic.c | 11 +++++------ generic/tclCompCmdsSZ.c | 44 ++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 4 ++++ generic/tclCompile.h | 15 ++++++++------- generic/tclExecute.c | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 4 ++++ 7 files changed, 117 insertions(+), 16 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index eacaafe..f5f2469 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -514,9 +514,9 @@ static const unsigned char NonThrowingByteCodes[] = { INST_STR_MAP, /* 143 */ INST_STR_FIND, /* 144 */ INST_COROUTINE_NAME, /* 147 */ - INST_NS_CURRENT, /* 148 */ - INST_INFO_LEVEL_NUM, /* 149 */ - INST_RESOLVE_COMMAND /* 151 */ + INST_NS_CURRENT, /* 149 */ + INST_INFO_LEVEL_NUM, /* 150 */ + INST_RESOLVE_COMMAND /* 152 */ }; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6e60aee..bce6479 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -136,7 +136,6 @@ static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); static Tcl_NRPostProc NRRunObjProc; -static Tcl_NRPostProc NRTailcallEval; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -248,7 +247,7 @@ static const CmdInfo builtInCmds[] = { {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, - {"tailcall", NULL, NULL, TclNRTailcallObjCmd, 1}, + {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1}, {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, @@ -8322,7 +8321,7 @@ TclNRTailcallObjCmd( return TCL_ERROR; } - if (!iPtr->varFramePtr->isProcCallFrame) { /* or is upleveled */ + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); @@ -8362,7 +8361,7 @@ TclNRTailcallObjCmd( } Tcl_IncrRefCount(nsObjPtr); - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, NULL, NULL); tailcallPtr = TOP_CB(interp); TOP_CB(interp) = tailcallPtr->nextPtr; @@ -8372,7 +8371,7 @@ TclNRTailcallObjCmd( } int -NRTailcallEval( +TclNRTailcallEval( ClientData data[], Tcl_Interp *interp, int result) @@ -8566,7 +8565,7 @@ YieldToCallback( * yieldTo: invoke the command using tailcall tech. */ - TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr, NULL, NULL); + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL); cbPtr = TOP_CB(interp); TOP_CB(interp) = cbPtr->nextPtr; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 12396fe..57cb992 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1987,6 +1987,50 @@ PrintJumptableInfo( /* *---------------------------------------------------------------------- * + * TclCompileTailcallCmd -- + * + * Procedure called to compile the "tailcall" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "tailcall" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileTailcallCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 256 + || envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + for (i=1 ; inumWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords-1, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileThrowCmd -- * * Procedure called to compile the "throw" command. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f979fa3..ee8511c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -464,6 +464,10 @@ InstructionDesc const tclInstructionTable[] = { {"coroName", 1, +1, 0, {OPERAND_NONE}}, /* Push the name of the interpreter's current coroutine as an object * on the stack. */ + {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Do a tailcall with the opnd items on the stack as the thing to + * tailcall to; opnd must be greater than 0 for the semantics to work + * right. */ {"currentNamespace", 1, +1, 0, {OPERAND_NONE}}, /* Push the name of the interpreter's current namespace as an object diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 85d282f..08d59fd 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -688,19 +688,20 @@ typedef struct ByteCode { #define INST_STR_FIND 144 #define INST_STR_RANGE_IMM 145 -/* For operations to do with coroutines */ +/* For operations to do with coroutines and other NRE-manipulators */ #define INST_YIELD 146 #define INST_COROUTINE_NAME 147 +#define INST_TAILCALL 148 /* For compilation of basic information operations */ -#define INST_NS_CURRENT 148 -#define INST_INFO_LEVEL_NUM 149 -#define INST_INFO_LEVEL_ARGS 150 -#define INST_RESOLVE_COMMAND 151 -#define INST_TCLOO_SELF 152 +#define INST_NS_CURRENT 149 +#define INST_INFO_LEVEL_NUM 150 +#define INST_INFO_LEVEL_ARGS 151 +#define INST_RESOLVE_COMMAND 152 +#define INST_TCLOO_SELF 153 /* The last opcode */ -#define LAST_INST_OPCODE 152 +#define LAST_INST_OPCODE 153 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bbee81d..1e24cb3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2374,6 +2374,55 @@ TEBCresume( return TCL_OK; } + case INST_TAILCALL: { + Tcl_Obj *listPtr, *nsObjPtr; + NRE_callback *tailcallPtr; + + opnd = TclGetUInt1AtPtr(pc+1); + + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { + TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + TRACE(("%d [", opnd)); + for (i=opnd-1 ; i>=0 ; i++) { + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); + if (i > 0) { + TRACE_APPEND((" ")); + } + } + TRACE_APPEND(("] => RETURN...")); +#endif + + /* + * Push the evaluation of the called command into the NR callback + * stack. + */ + + listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); + Tcl_IncrRefCount(listPtr); + Tcl_IncrRefCount(nsObjPtr); + TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, + NULL, NULL); + + /* + * Unstitch ourselves and do a [return]. + */ + + tailcallPtr = TOP_CB(interp); + TOP_CB(interp) = tailcallPtr->nextPtr; + iPtr->varFramePtr->tailcallPtr = tailcallPtr; + result = TCL_RETURN; + cleanup = opnd; + goto processExceptionReturn; + } + case INST_DONE: if (tosPtr > initTosPtr) { /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 49298b3..1fffa1f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2799,6 +2799,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; +MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; @@ -3664,6 +3665,9 @@ MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12