From 4f20c3d555d869755b8fbe5cf295f4898929c8a3 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 26 Oct 2012 13:13:27 +0000 Subject: Working towards a BCCed [yield]; this doesn't work right now. --- generic/tclAssembly.c | 9 +++++---- generic/tclBasic.c | 15 +++++++-------- generic/tclCompCmdsSZ.c | 43 +++++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 12 +++++++++--- generic/tclCompile.h | 17 ++++++++++------- generic/tclExecute.c | 26 ++++++++++++++++++++++++++ generic/tclInt.h | 4 ++++ 7 files changed, 104 insertions(+), 22 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 27720c7..5ff96fd 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -370,6 +370,7 @@ static const TalInstDesc TalInstructionTable[] = { {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, + {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, @@ -452,7 +453,6 @@ static const TalInstDesc TalInstructionTable[] = { {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, - {"nscurrent", ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, @@ -487,6 +487,7 @@ static const TalInstDesc TalInstructionTable[] = { {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1}, {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0}, + {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1}, {NULL, 0, 0, 0, 0} }; @@ -506,10 +507,10 @@ static const unsigned char NonThrowingByteCodes[] = { INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ INST_NOP, /* 132 */ - INST_NS_CURRENT, /* 141 */ INST_COROUTINE_NAME, /* 142 */ - INST_INFO_LEVEL_NUM, /* 143 */ - INST_RESOLVE_COMMAND /* 145 */ + INST_NS_CURRENT, /* 143 */ + INST_INFO_LEVEL_NUM, /* 144 */ + INST_RESOLVE_COMMAND /* 146 */ }; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3848d5b..ab087e6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -131,7 +131,6 @@ static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); -static Tcl_NRPostProc NRCoroutineActivateCallback; static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); @@ -258,7 +257,7 @@ static const CmdInfo builtInCmds[] = { {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - {"yield", NULL, NULL, TclNRYieldObjCmd, 1}, + {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1}, {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, /* @@ -8495,7 +8494,7 @@ TclNRYieldObjCmd( } NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, clientData, NULL, NULL); return TCL_OK; } @@ -8712,7 +8711,7 @@ NRCoroutineExitCallback( /* *---------------------------------------------------------------------- * - * NRCoroutineActivateCallback -- + * TclNRCoroutineActivateCallback -- * * This is the workhorse for coroutines: it implements both yield and * resume. @@ -8726,8 +8725,8 @@ NRCoroutineExitCallback( *---------------------------------------------------------------------- */ -static int -NRCoroutineActivateCallback( +int +TclNRCoroutineActivateCallback( ClientData data[], Tcl_Interp *interp, int result) @@ -8902,7 +8901,7 @@ TclNRInterpCoroutine( break; } - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, NULL, NULL, NULL); return TCL_OK; } @@ -9059,7 +9058,7 @@ TclNRCoroutineObjCmd( * Now just resume the coroutine. */ - TclNRAddCallback(interp, NRCoroutineActivateCallback, corPtr, + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, NULL, NULL, NULL); return TCL_OK; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8ed3a95..d7dd58e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2752,6 +2752,49 @@ TclCompileWhileCmd( /* *---------------------------------------------------------------------- * + * TclCompileYieldCmd -- + * + * Procedure called to compile the "yield" 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 "yield" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileYieldCmd( + 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. */ +{ + if (parsePtr->numWords < 1 || parsePtr->numWords > 2) { + return TCL_ERROR; + } + + if (parsePtr->numWords == 1) { + PushLiteral(envPtr, "", 0); + } else { + DefineLineInformation; /* TIP #280 */ + Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, valueTokenPtr, interp, 1); + } + TclEmitOpcode(INST_YIELD, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * PushVarName -- * * Procedure used in the compiling where pushing a variable name is diff --git a/generic/tclCompile.c b/generic/tclCompile.c index b331551..1924334 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -435,12 +435,18 @@ InstructionDesc const tclInstructionTable[] = { * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ - {"nscurrent", 1, +1, 0, {OPERAND_NONE}}, - /* Push the name of the interpreter's current namespace as an object - * on the stack. */ + {"yield", 1, 0, 0, {OPERAND_NONE}}, + /* Makes the current coroutine yield the value at the top of the + * stack, and places the response back on top of the stack when it + * resumes. + * Stack: ... valueToYield => ... resumeValue */ {"coroName", 1, +1, 0, {OPERAND_NONE}}, /* Push the name of the interpreter's current coroutine as an object * on the stack. */ + + {"currentNamespace", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current namespace as an object + * on the stack. */ {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}}, /* Push the stack depth (i.e., [info level]) of the interpreter as an * object on the stack. */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 86a0f77..fcff46c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -681,16 +681,19 @@ typedef struct ByteCode { #define INST_DICT_RECOMBINE_STK 139 #define INST_DICT_RECOMBINE_IMM 140 -/* For compilation of basic information operations */ -#define INST_NS_CURRENT 141 +/* For operations to do with coroutines */ +#define INST_YIELD 141 #define INST_COROUTINE_NAME 142 -#define INST_INFO_LEVEL_NUM 143 -#define INST_INFO_LEVEL_ARGS 144 -#define INST_RESOLVE_COMMAND 145 -#define INST_TCLOO_SELF 146 + +/* For compilation of basic information operations */ +#define INST_NS_CURRENT 143 +#define INST_INFO_LEVEL_NUM 144 +#define INST_INFO_LEVEL_ARGS 145 +#define INST_RESOLVE_COMMAND 146 +#define INST_TCLOO_SELF 147 /* The last opcode */ -#define LAST_INST_OPCODE 146 +#define LAST_INST_OPCODE 147 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a24c806..30f8d77 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2332,6 +2332,32 @@ TEBCresume( cleanup = 1; goto processExceptionReturn; + case INST_YIELD: { + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); + if (!corPtr) { + TRACE_APPEND(("ERROR: yield outside coroutine\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yield can only be called in a coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", + NULL); + goto gotError; + } + + Tcl_SetObjResult(interp, OBJ_AT_TOS); + TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, + INT2PTR(0), NULL, NULL); + +#ifdef TCL_COMPILE_DEBUG + TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); + if (traceInstructions) { + fprintf(stdout, "\n"); + } +#endif + goto checkForCatch; + } + case INST_DONE: if (tosPtr > initTosPtr) { /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 448a7cd..865378e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2797,6 +2797,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; +MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; @@ -3654,6 +3655,9 @@ MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, -- cgit v0.12