From c8b1fb73cd6a3182fa40f521132f234a47eb3bcf Mon Sep 17 00:00:00 2001 From: mig Date: Sat, 19 Jan 2013 04:02:51 +0000 Subject: isolate the compiler/engine subsystem - preparing to move them out of generic and permit plugging in other compiler/engines --- generic/tclAssembly.c | 3 +- generic/tclBasic.c | 114 +---- generic/tclCompCmds.c | 3 +- generic/tclCompCmdsSZ.c | 3 +- generic/tclCompEnsemble.c | 802 ++++++++++++++++++++++++++++++ generic/tclCompExpr.c | 3 +- generic/tclCompile.c | 14 +- generic/tclEngine.h | 432 ++++++++++++++++ generic/tclEngineInt.h | 1215 +++++++++++++++++++++++++++++++++++++++++++++ generic/tclEnsemble.c | 809 ------------------------------ generic/tclExecute.c | 3 +- generic/tclInt.decls | 8 +- generic/tclInt.h | 183 +++---- generic/tclIntDecls.h | 10 +- generic/tclLiteral.c | 3 +- generic/tclNRE.h | 49 -- generic/tclNamesp.c | 1 - generic/tclOOMethod.c | 7 +- generic/tclProc.c | 231 +-------- generic/tclStubInit.c | 2 +- generic/tclTest.c | 2 +- tests/compile.test | 84 ---- unix/Makefile.in | 37 +- 23 files changed, 2565 insertions(+), 1453 deletions(-) create mode 100644 generic/tclCompEnsemble.c create mode 100644 generic/tclEngine.h create mode 100644 generic/tclEngineInt.h diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index d805bd1..f54da6d 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -28,8 +28,7 @@ *- returnCodeBranch */ -#include "tclInt.h" -#include "tclCompile.h" +#include "tclEngineInt.h" #include "tclOOInt.h" /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c2a21b6..9d041a0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -18,8 +18,9 @@ */ #include "tclInt.h" +#include "tclEngine.h" + #include "tclOOInt.h" -#include "tclCompile.h" #include "tommath.h" #include #include "tclNRE.h" @@ -128,9 +129,6 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); static int NRRoot(ClientData data[], Tcl_Interp *interp, int result); -#if !NRE_STACK_DEBUG -static Tcl_NRPostProc NRStackBottom; -#endif static Tcl_NRPostProc NRRunObjProc; static Tcl_ObjCmdProc OldMathFuncProc; @@ -814,8 +812,6 @@ Tcl_CreateInterp(void) * Create unsupported commands for debugging bytecode and objects. */ - Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", - Tcl_DisassembleObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); @@ -4242,13 +4238,7 @@ void TclNRSetRoot( Tcl_Interp *interp) { -#if NRE_STACK_DEBUG int first = (TOP_CB(interp) == NULL); -#else - int first = ((TOP_CB(interp) == NULL) || - ((TOP_CB(interp)->procPtr == NRStackBottom) && - (TOP_CB(interp)->data[0] == NULL))); -#endif if (!first) { TclNRAddCallback(interp, NRRoot, NULL, NULL, NULL, NULL); @@ -7338,106 +7328,6 @@ TclPushTailcallPoint( ((Interp *) interp)->numLevels++; } -#if !NRE_STACK_DEBUG -static int -NRStackBottom( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - NRE_stack *this = eePtr->NRStack; - NRE_stack *prev = data[0]; - - if (!prev) { - /* empty stack, free it */ - ckfree(this); - eePtr->NRStack = NULL; - TOP_CB(interp) = NULL; - return result; - } - - /* - * Go back to the previous stack. - */ - - eePtr->NRStack = prev; - eePtr->callbackPtr = &prev->items[NRE_STACK_SIZE-1]; - - /* - * Keep this stack in reserve. If this one had a successor, free that one: - * we always keep just one in reserve. - */ - - if (this->next) { - ckfree (this->next); - this->next = NULL; - } - - return result; -} - -int level = 0; - -NRE_callback * -TclNewCallback( - Tcl_Interp *interp) -{ - Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr = iPtr->execEnvPtr; - NRE_stack *this = eePtr->NRStack, *orig; - - if (eePtr->callbackPtr && - (eePtr->callbackPtr < &this->items[NRE_STACK_SIZE-1])) { - stackReady: - return ++eePtr->callbackPtr; - } - - if (!eePtr->callbackPtr) { - this = NULL; - } - orig = this; - - if (this && this->next) { - this = this->next; - } else { - this = (NRE_stack *) ckalloc(sizeof(NRE_stack)); - this->next = NULL; - } - eePtr->NRStack = this; - eePtr->callbackPtr = &this->items[-1]; - TclNRAddCallback(interp, NRStackBottom, orig, NULL, NULL, NULL); - - NRE_ASSERT(eePtr->callbackPtr == &this->items[0]); - - goto stackReady; -} - -NRE_callback * -TclPopCallback( - Tcl_Interp *interp) -{ - return ((Interp *)interp)->execEnvPtr->callbackPtr--; -} - -NRE_callback * -TclNextCallback( - NRE_callback *cbPtr) -{ - - if (cbPtr->procPtr == NRStackBottom) { - NRE_stack *prev = cbPtr->data[0]; - - if (!prev) { - return NULL; - } - cbPtr = &prev->items[NRE_STACK_SIZE]; - } - return --cbPtr; -} - -#endif void TclSetTailcall( Tcl_Interp *interp, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 912269e..ab65772 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -13,8 +13,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" -#include "tclCompile.h" +#include "tclEngineInt.h" #include /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index ba94b27..2ecfe22 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -15,8 +15,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" -#include "tclCompile.h" +#include "tclEngineInt.h" /* * Prototypes for procedures defined later in this file: diff --git a/generic/tclCompEnsemble.c b/generic/tclCompEnsemble.c new file mode 100644 index 0000000..2c2c15f --- /dev/null +++ b/generic/tclCompEnsemble.c @@ -0,0 +1,802 @@ +#include "tclEngineInt.h" + +/* + * How to compile a subcommand using its own command compiler. To do that, we + * have to perform some trickery to rewrite the arguments, as compilers *must* + * have parse tokens that refer to addresses in the original script. + */ + +int +TclCompileToCompiledCommand( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + int depth, + Command *cmdPtr, + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Parse synthetic; + Tcl_Token *tokenPtr; + int result, i; + int savedNumCmds = envPtr->numCommands; + int savedStackDepth = envPtr->currStackDepth; + unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + + if (cmdPtr->compileProc == NULL) { + return TCL_ERROR; + } + + TclParseInit(interp, NULL, 0, &synthetic); + synthetic.numWords = parsePtr->numWords - depth + 1; + TclGrowParseTokenArray(&synthetic, 2); + synthetic.numTokens = 2; + + /* + * Now we have the space to work in, install something rewritten. The + * first word will "officially" be the bytes of the structured ensemble + * name. That's technically wrong, but nobody will care; we just need + * *something* here... + */ + + synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; + synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; + synthetic.tokenPtr[0].numComponents = 1; + synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; + synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; + synthetic.tokenPtr[1].numComponents = 0; + for (i=0,tokenPtr=parsePtr->tokenPtr ; istart - synthetic.tokenPtr[0].start) + + tokenPtr->size; + + synthetic.tokenPtr[0].size = sclen; + synthetic.tokenPtr[1].size = sclen; + tokenPtr = TokenAfter(tokenPtr); + } + + /* + * Copy over the real argument tokens. + */ + + for (i=1; inumComponents + 1; + TclGrowParseTokenArray(&synthetic, toCopy); + memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, + sizeof(Tcl_Token) * toCopy); + synthetic.numTokens += toCopy; + tokenPtr = TokenAfter(tokenPtr); + } + + /* + * Hand off compilation to the subcommand compiler. At last! + */ + + result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + + /* + * If our target fails to compile, revert the number of commands and the + * pointer to the place to issue the next instruction. [Bug 3600328] + */ + + if (result != TCL_OK) { + envPtr->numCommands = savedNumCmds; + envPtr->currStackDepth = savedStackDepth; + envPtr->codeNext = envPtr->codeStart + savedCodeNext; + } + + /* + * Clean up if necessary. + */ + + Tcl_FreeParse(&synthetic); + return result; +} + +/* + * How to compile a subcommand to a _replacing_ invoke of its implementation + * command. + */ + +void +TclCompileToInvokedCommand( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Tcl_Obj *replacements, + Command *cmdPtr, + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokPtr; + Tcl_Obj *objPtr, **words; + char *bytes; + int length, i, numWords, cmdLit; + + /* + * Push the words of the command. Take care; the command words may be + * scripts that have backslashes in them, and [info frame 0] can see the + * difference. Hence the call to TclContinuationsEnterDerived... + */ + + Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); + for (i=0,tokPtr=parsePtr->tokenPtr ; inumWords ; i++) { + if (i > 0 && i < numWords+1) { + bytes = Tcl_GetStringFromObj(words[i-1], &length); + PushLiteral(envPtr, bytes, length); + } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { + int literal = TclRegisterNewLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size); + + TclEmitPush(literal, envPtr); + } else { + CompileTokens(envPtr, tokPtr, interp); + } + tokPtr = TokenAfter(tokPtr); + } + + /* + * Push the name of the command we're actually dispatching to as part of + * the implementation. + */ + + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + bytes = Tcl_GetStringFromObj(objPtr, &length); + cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); + TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr); + TclEmitPush(cmdLit, envPtr); + TclDecrRefCount(objPtr); + + /* + * Do the replacing dispatch. + */ + + TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); + TclEmitInt1(numWords+1, envPtr); + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */ +} + +/* + * Helpers that do issuing of instructions for commands that "don't have + * compilers" (well, they do; these). They all work by just generating base + * code to invoke the command; they're intended for ensemble subcommands so + * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out + * that they're not needed. + * + * Note that these are NOT suitable for commands where there's an argument + * that is a script, as an [info level] or [info frame] in the inner context + * can see the difference. + */ + +int +TclCompileBasicNArgCommand( + 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. */ +{ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + char *bytes; + int length, i, literal; + + /* + * Push the name of the command we're actually dispatching to as part of + * the implementation. + */ + + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + bytes = Tcl_GetStringFromObj(objPtr, &length); + literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); + TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr); + TclEmitPush(literal, envPtr); + TclDecrRefCount(objPtr); + + /* + * Push the words of the command. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i=1 ; inumWords ; i++) { + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); + } else { + CompileTokens(envPtr, tokenPtr, interp); + } + tokenPtr = TokenAfter(tokenPtr); + } + + /* + * Do the standard dispatch. + */ + + if (i <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); + } + return TCL_OK; +} + +int +TclCompileBasic0ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic2ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic3ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic0Or1ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1Or2ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic2Or3ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic0To2ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 1 || parsePtr->numWords > 3) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1To3ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin0ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 1) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin1ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin2ArgCmd( + 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. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + return TclCompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * TclCompileEnsemble -- + * + * Procedure called to compile an ensemble command. Note that most + * ensembles are not compiled, since modifying a compiled ensemble causes + * a invalidation of all existing bytecode (expensive!) which is not + * normally warranted. + * + * 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 subcommands of the + * ensemble at runtime if a compile-time mapping is possible. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileEnsemble( + 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. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; + Tcl_Obj *replaced = Tcl_NewObj(), *replacement; + Tcl_Command ensemble = (Tcl_Command) cmdPtr; + Command *oldCmdPtr = cmdPtr, *newCmdPtr; + int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; + int ourResult = TCL_ERROR; + unsigned numBytes; + const char *word; + + Tcl_IncrRefCount(replaced); + + /* + * This is where we return to if we are parsing multiple nested compiled + * ensembles. [info object] is such a beast. + */ + + checkNextWord: + if (parsePtr->numWords < depth + 1) { + goto failed; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Too hard. + */ + + goto failed; + } + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + + /* + * There's a sporting chance we'll be able to compile this. But now we + * must check properly. To do that, check that we're compiling an ensemble + * that has a compilable command as its appropriate subcommand. + */ + + if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK + || mapObj == NULL) { + /* + * Either not an ensemble or a mapping isn't installed. Crud. Too hard + * to proceed. + */ + + goto failed; + } + + /* + * Also refuse to compile anything that uses a formal parameter list for + * now, on the grounds that it is too complex. + */ + + if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK + || listObj != NULL) { + /* + * Figuring out how to compile this has become too much. Bail out. + */ + + goto failed; + } + + /* + * Next, get the flags. We need them on several code paths so that we can + * know whether we're to do prefix matching. + */ + + (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags); + + /* + * Check to see if there's also a subcommand list; must check to see if + * the subcommand we are calling is in that list if it exists, since that + * list filters the entries in the map. + */ + + (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj); + if (listObj != NULL) { + int sclen; + const char *str; + Tcl_Obj *matchObj = NULL; + + if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { + goto failed; + } + for (i=0 ; insPtr->flags & NS_SUPPRESS_COMPILATION + || newCmdPtr->flags & CMD_HAS_EXEC_TRACES + || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { + /* + * Maps to an undefined command or a command without a compiler. + * Cannot compile. + */ + + goto cleanup; + } + cmdPtr = newCmdPtr; + depth++; + + /* + * See whether we have a nested ensemble. If we do, we can go round the + * mulberry bush again, consuming the next word. + */ + + if (cmdPtr->compileProc == TclCompileEnsemble) { + tokenPtr = TokenAfter(tokenPtr); + ensemble = (Tcl_Command) cmdPtr; + goto checkNextWord; + } + + /* + * Now we've done the mapping process, can now actually try to compile. + * If there is a subcommand compiler and that successfully produces code, + * we'll use that. Otherwise, we fall back to generating opcodes to do the + * invoke at runtime. + */ + + invokeAnyway = 1; + if (TclCompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, + envPtr) == TCL_OK) { + ourResult = TCL_OK; + goto cleanup; + } + + /* + * Failed to do a full compile for some reason. Try to do a direct invoke + * instead of going through the ensemble lookup process again. + */ + + failed: + if (depth < 250) { + if (depth > 1) { + if (!invokeAnyway) { + cmdPtr = oldCmdPtr; + depth--; + } + (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL); + } + TclCompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); + ourResult = TCL_OK; + } + + /* + * Release the memory we allocated. If we've got here, we've either done + * something useful or we're in a case that we can't compile at all and + * we're just giving up. + */ + + cleanup: + Tcl_DecrRefCount(replaced); + return ourResult; +} + diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 46b652c..bf724bb 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -11,8 +11,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" -#include "tclCompile.h" /* CompileEnv */ +#include "tclEngineInt.h" /* CompileEnv */ /* * Expression parsing takes place in the routine ParseExpr(). It takes a diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2f6b166..0102f16 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -12,8 +12,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" -#include "tclCompile.h" +#include "tclEngineInt.h" /* * Table of all AuxData types. @@ -590,6 +589,17 @@ static const Tcl_ObjType substCodeType = { NULL, /* setFromAnyProc */ }; + +void TclForceBodyNS( + Tcl_Obj *bodyPtr, + Namespace *nsPtr) +{ + if (bodyPtr->typePtr == &tclByteCodeType) { + ((ByteCode *)bodyPtr->internalRep.otherValuePtr)->nsPtr = nsPtr; + } +} + + /* *---------------------------------------------------------------------- diff --git a/generic/tclEngine.h b/generic/tclEngine.h new file mode 100644 index 0000000..acdbcd3 --- /dev/null +++ b/generic/tclEngine.h @@ -0,0 +1,432 @@ +#ifndef _TCLENGINE +#define _TCLENGINE 1 + +/* + * ClientData type used by the math operator commands. + */ + +typedef struct { + const char *op; /* Do not call it 'operator': C++ reserved */ + const char *expected; + union { + int numArgs; + int identity; + } i; +} TclOpCmdClientData; + +MODULE_SCOPE int TclSingleOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclSortingOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, + int length, unsigned int hash, int *newPtr, + Namespace *nsPtr, int flags, + LiteralEntry **globalPtrPtr); + +/* + * The structure defining the bytecode instructions resulting from compiling a + * Tcl script. Note that this structure is variable length: a single heap + * object is allocated to hold the ByteCode structure immediately followed by + * the code bytes, the literal object array, the ExceptionRange array, the + * CmdLocation map, and the compilation AuxData array. + */ + +/* + * A PRECOMPILED bytecode struct is one that was generated from a compiled + * image rather than implicitly compiled from source + */ + +#define TCL_BYTECODE_PRECOMPILED 0x0001 + +/* + * When a bytecode is compiled, interp or namespace resolvers have not been + * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. + */ + +#define TCL_BYTECODE_RESOLVE_VARS 0x0002 + +#define TCL_BYTECODE_RECOMPILE 0x0004 + +typedef struct ByteCode { + TclHandle interpHandle; /* Handle for interpreter containing the + * compiled code. Commands and their compile + * procs are specific to an interpreter so the + * code emitted will depend on the + * interpreter. */ + int compileEpoch; /* Value of iPtr->compileEpoch when this + * ByteCode was compiled. Used to invalidate + * code when, e.g., commands with compile + * procs are redefined. */ + Namespace *nsPtr; /* Namespace context in which this code was + * compiled. If the code is executed if a + * different namespace, it must be + * recompiled. */ + int nsEpoch; /* Value of nsPtr->resolverEpoch when this + * ByteCode was compiled. Used to invalidate + * code when new namespace resolution rules + * are put into effect. */ + int refCount; /* Reference count: set 1 when created plus 1 + * for each execution of the code currently + * active. This structure can be freed when + * refCount becomes zero. */ + unsigned int flags; /* flags describing state for the codebyte. + * this variable holds ORed values from the + * TCL_BYTECODE_ masks defined above */ + const char *source; /* The source string from which this ByteCode + * was compiled. Note that this pointer is not + * owned by the ByteCode and must not be freed + * or modified by it. */ + Proc *procPtr; /* If the ByteCode was compiled from a + * procedure body, this is a pointer to its + * Proc structure; otherwise NULL. This + * pointer is also not owned by the ByteCode + * and must not be freed by it. */ + LocalCache *localCachePtr; /* Pointer to the start of the cached variable + * names and initialisation data for local + * variables. */ +#ifdef TCL_COMPILE_STATS + Tcl_Time createTime; /* Absolute time when the ByteCode was + * created. */ +#endif /* TCL_COMPILE_STATS */ + size_t structureSize; /* Number of bytes in the ByteCode structure + * itself. Does not include heap space for + * literal Tcl objects or storage referenced + * by AuxData entries. */ + int numCommands; /* Number of commands compiled. */ + int numSrcBytes; /* Number of source bytes compiled. */ + int numCodeBytes; /* Number of code bytes. */ + int numLitObjects; /* Number of objects in literal array. */ + int numExceptRanges; /* Number of ExceptionRange array elems. */ + int numAuxDataItems; /* Number of AuxData items. */ + int numCmdLocBytes; /* Number of bytes needed for encoded command + * location information. */ + int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; + * -1 if no ranges were compiled. */ + int maxStackDepth; /* Maximum number of stack elements needed to + * execute the code. */ + unsigned char *codeStart; /* Points to the first byte of the code. This + * is just after the final ByteCode member + * cmdMapPtr. */ + Tcl_Obj **objArrayPtr; /* Points to the start of the literal object + * array. This is just after the last code + * byte. */ + struct ExceptionRange *exceptArrayPtr; + /* Points to the start of the ExceptionRange + * array. This is just after the last object + * in the object array. */ + struct AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data + * array. This is just after the last entry in + * the ExceptionRange array. */ + unsigned char *codeDeltaStart; + /* Points to the first of a sequence of bytes + * that encode the change in the starting + * offset of each command's code. If -127 <= + * delta <= 127, it is encoded as 1 byte, + * otherwise 0xFF (128) appears and the delta + * is encoded by the next 4 bytes. Code deltas + * are always positive. This sequence is just + * after the last entry in the AuxData + * array. */ + unsigned char *codeLengthStart; + /* Points to the first of a sequence of bytes + * that encode the length of each command's + * code. The encoding is the same as for code + * deltas. Code lengths are always positive. + * This sequence is just after the last entry + * in the code delta sequence. */ + unsigned char *srcDeltaStart; + /* Points to the first of a sequence of bytes + * that encode the change in the starting + * offset of each command's source. The + * encoding is the same as for code deltas. + * Source deltas can be negative. This + * sequence is just after the last byte in the + * code length sequence. */ + unsigned char *srcLengthStart; + /* Points to the first of a sequence of bytes + * that encode the length of each command's + * source. The encoding is the same as for + * code deltas. Source lengths are always + * positive. This sequence is just after the + * last byte in the source delta sequence. */ +} ByteCode; + +/* + * The type of procedure called from the compilation hook point in + * SetByteCodeFromAny. + */ +typedef struct CompileEnv CompileEnv; +typedef int (CompileHookProc)(Tcl_Interp *interp, + CompileEnv *compEnvPtr, ClientData clientData); + +MODULE_SCOPE int TclCompileToCompiledCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE void TclCompileToInvokedCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Tcl_Obj *replacements, + Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasicNArgCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); + +typedef struct ByteCode ByteCode; /* Forward declaration. */ + +MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, + ByteCode *codePtr); + +MODULE_SCOPE int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, + CompileHookProc *hookProc, ClientData clientData); + +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); +MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, + CompileEnv *envPtr, const char *string, + int numBytes); +MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); + +MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, + const char *name, Namespace *nsPtr); +MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); +MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, + LiteralTable *tablePtr); +/* + *---------------------------------------------------------------- + * Procedures exported by the engine to be used by tclBasic.c + *---------------------------------------------------------------- + */ + +MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr); + + +#ifdef TCL_COMPILE_STATS +MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); +MODULE_SCOPE int TclLog2(int value); +#endif + +/* + * DTrace probe macros (NOPs if DTrace support is not enabled). + */ + +/* + * Define the following macros to enable debug logging of the DTrace proc, + * cmd, and inst probes. Note that this does _not_ require a platform with + * DTrace, it simply logs all probe output to /tmp/tclDTraceDebug-[pid].log. + * + * If the second macro is defined, logging to file starts immediately, + * otherwise only after the first call to [tcl::dtrace]. Note that the debug + * probe data is always computed, even when it is not logged to file. + * + * Defining the third macro enables debug logging of inst probes (disabled + * by default due to the significant performance impact). + */ + +/* +#define TCL_DTRACE_DEBUG 1 +#define TCL_DTRACE_DEBUG_LOG_ENABLED 1 +#define TCL_DTRACE_DEBUG_INST_PROBES 1 +*/ + +#if !(defined(TCL_DTRACE_DEBUG) && defined(__GNUC__)) + +#ifdef USE_DTRACE + +#if defined(__GNUC__) && __GNUC__ > 2 +/* + * Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks. + */ +#define unlikely(x) (__builtin_expect((x), 0)) +#else +#define unlikely(x) (x) +#endif + +#define TCL_DTRACE_PROC_ENTRY_ENABLED() unlikely(TCL_PROC_ENTRY_ENABLED()) +#define TCL_DTRACE_PROC_RETURN_ENABLED() unlikely(TCL_PROC_RETURN_ENABLED()) +#define TCL_DTRACE_PROC_RESULT_ENABLED() unlikely(TCL_PROC_RESULT_ENABLED()) +#define TCL_DTRACE_PROC_ARGS_ENABLED() unlikely(TCL_PROC_ARGS_ENABLED()) +#define TCL_DTRACE_PROC_INFO_ENABLED() unlikely(TCL_PROC_INFO_ENABLED()) +#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) TCL_PROC_ENTRY(a0, a1, a2) +#define TCL_DTRACE_PROC_RETURN(a0, a1) TCL_PROC_RETURN(a0, a1) +#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) TCL_PROC_RESULT(a0, a1, a2, a3) +#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + TCL_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) +#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ + TCL_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) + +#define TCL_DTRACE_CMD_ENTRY_ENABLED() unlikely(TCL_CMD_ENTRY_ENABLED()) +#define TCL_DTRACE_CMD_RETURN_ENABLED() unlikely(TCL_CMD_RETURN_ENABLED()) +#define TCL_DTRACE_CMD_RESULT_ENABLED() unlikely(TCL_CMD_RESULT_ENABLED()) +#define TCL_DTRACE_CMD_ARGS_ENABLED() unlikely(TCL_CMD_ARGS_ENABLED()) +#define TCL_DTRACE_CMD_INFO_ENABLED() unlikely(TCL_CMD_INFO_ENABLED()) +#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) TCL_CMD_ENTRY(a0, a1, a2) +#define TCL_DTRACE_CMD_RETURN(a0, a1) TCL_CMD_RETURN(a0, a1) +#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) TCL_CMD_RESULT(a0, a1, a2, a3) +#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + TCL_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) +#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ + TCL_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) + +#define TCL_DTRACE_INST_START_ENABLED() unlikely(TCL_INST_START_ENABLED()) +#define TCL_DTRACE_INST_DONE_ENABLED() unlikely(TCL_INST_DONE_ENABLED()) +#define TCL_DTRACE_INST_START(a0, a1, a2) TCL_INST_START(a0, a1, a2) +#define TCL_DTRACE_INST_DONE(a0, a1, a2) TCL_INST_DONE(a0, a1, a2) + +#define TCL_DTRACE_TCL_PROBE_ENABLED() unlikely(TCL_TCL_PROBE_ENABLED()) +#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) + +#define TCL_DTRACE_DEBUG_LOG() + +MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, + int *argsi); + +#else /* USE_DTRACE */ + +#define TCL_DTRACE_PROC_ENTRY_ENABLED() 0 +#define TCL_DTRACE_PROC_RETURN_ENABLED() 0 +#define TCL_DTRACE_PROC_RESULT_ENABLED() 0 +#define TCL_DTRACE_PROC_ARGS_ENABLED() 0 +#define TCL_DTRACE_PROC_INFO_ENABLED() 0 +#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {if (a0) {}} +#define TCL_DTRACE_PROC_RETURN(a0, a1) {if (a0) {}} +#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {if (a0) {}; if (a3) {}} +#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} +#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {} + +#define TCL_DTRACE_CMD_ENTRY_ENABLED() 0 +#define TCL_DTRACE_CMD_RETURN_ENABLED() 0 +#define TCL_DTRACE_CMD_RESULT_ENABLED() 0 +#define TCL_DTRACE_CMD_ARGS_ENABLED() 0 +#define TCL_DTRACE_CMD_INFO_ENABLED() 0 +#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) {} +#define TCL_DTRACE_CMD_RETURN(a0, a1) {} +#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) {} +#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} +#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {} + +#define TCL_DTRACE_INST_START_ENABLED() 0 +#define TCL_DTRACE_INST_DONE_ENABLED() 0 +#define TCL_DTRACE_INST_START(a0, a1, a2) {} +#define TCL_DTRACE_INST_DONE(a0, a1, a2) {} + +#define TCL_DTRACE_TCL_PROBE_ENABLED() 0 +#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} + +#define TclDTraceInfo(info, args, argsi) {*args = ""; *argsi = 0;} + +#endif /* USE_DTRACE */ + +#else /* TCL_DTRACE_DEBUG */ + +#define USE_DTRACE 1 + +#if !defined(TCL_DTRACE_DEBUG_LOG_ENABLED) || !(TCL_DTRACE_DEBUG_LOG_ENABLED) +#undef TCL_DTRACE_DEBUG_LOG_ENABLED +#define TCL_DTRACE_DEBUG_LOG_ENABLED 0 +#endif + +#if !defined(TCL_DTRACE_DEBUG_INST_PROBES) || !(TCL_DTRACE_DEBUG_INST_PROBES) +#undef TCL_DTRACE_DEBUG_INST_PROBES +#define TCL_DTRACE_DEBUG_INST_PROBES 0 +#endif + +MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent; +MODULE_SCOPE FILE *tclDTraceDebugLog; +MODULE_SCOPE void TclDTraceOpenDebugLog(void); +MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); + +#define TCL_DTRACE_DEBUG_LOG() \ + int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \ + int tclDTraceDebugIndent = 0; \ + FILE *tclDTraceDebugLog = NULL; \ + void TclDTraceOpenDebugLog(void) { \ + char n[35]; \ + sprintf(n, "/tmp/tclDTraceDebug-%lu.log", \ + (unsigned long) getpid()); \ + tclDTraceDebugLog = fopen(n, "a"); \ + } + +#define TclDTraceDbgMsg(p, m, ...) \ + do { \ + if (tclDTraceDebugEnabled) { \ + int _l, _t = 0; \ + if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \ + fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", \ + strrchr(__FILE__, '/')+1, __LINE__, &_l); _t += _l; \ + fprintf(tclDTraceDebugLog, " %.*s():%n", \ + (_t < 18 ? 18 - _t : 0) + 18, __func__, &_l); _t += _l; \ + fprintf(tclDTraceDebugLog, "%*s" p "%n", \ + (_t < 40 ? 40 - _t : 0) + 2 * tclDTraceDebugIndent, \ + "", &_l); _t += _l; \ + fprintf(tclDTraceDebugLog, "%*s" m "\n", \ + (_t < 64 ? 64 - _t : 1), "", ##__VA_ARGS__); \ + fflush(tclDTraceDebugLog); \ + } \ + } while (0) + +#define TCL_DTRACE_PROC_ENTRY_ENABLED() 1 +#define TCL_DTRACE_PROC_RETURN_ENABLED() 1 +#define TCL_DTRACE_PROC_RESULT_ENABLED() 1 +#define TCL_DTRACE_PROC_ARGS_ENABLED() 1 +#define TCL_DTRACE_PROC_INFO_ENABLED() 1 +#define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \ + tclDTraceDebugIndent++; \ + TclDTraceDbgMsg("-> proc-entry", "%s %d %p", a0, a1, a2) +#define TCL_DTRACE_PROC_RETURN(a0, a1) \ + TclDTraceDbgMsg("<- proc-return", "%s %d", a0, a1); \ + tclDTraceDebugIndent-- +#define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) \ + TclDTraceDbgMsg(" | proc-result", "%s %d %s %p", a0, a1, a2, a3) +#define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + TclDTraceDbgMsg(" | proc-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ + a1, a2, a3, a4, a5, a6, a7, a8, a9) +#define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ + TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d %s %s", a0, a1, \ + a2, a3, a4, a5, a6, a7) + +#define TCL_DTRACE_CMD_ENTRY_ENABLED() 1 +#define TCL_DTRACE_CMD_RETURN_ENABLED() 1 +#define TCL_DTRACE_CMD_RESULT_ENABLED() 1 +#define TCL_DTRACE_CMD_ARGS_ENABLED() 1 +#define TCL_DTRACE_CMD_INFO_ENABLED() 1 +#define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) \ + tclDTraceDebugIndent++; \ + TclDTraceDbgMsg("-> cmd-entry", "%s %d %p", a0, a1, a2) +#define TCL_DTRACE_CMD_RETURN(a0, a1) \ + TclDTraceDbgMsg("<- cmd-return", "%s %d", a0, a1); \ + tclDTraceDebugIndent-- +#define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) \ + TclDTraceDbgMsg(" | cmd-result", "%s %d %s %p", a0, a1, a2, a3) +#define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ + a1, a2, a3, a4, a5, a6, a7, a8, a9) +#define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ + TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d %s %s", a0, a1, \ + a2, a3, a4, a5, a6, a7) + +#define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES +#define TCL_DTRACE_INST_DONE_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES +#define TCL_DTRACE_INST_START(a0, a1, a2) \ + TclDTraceDbgMsg(" | inst-start", "%s %d %p", a0, a1, a2) +#define TCL_DTRACE_INST_DONE(a0, a1, a2) \ + TclDTraceDbgMsg(" | inst-end", "%s %d %p", a0, a1, a2) + +#define TCL_DTRACE_TCL_PROBE_ENABLED() 1 +#define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ + do { \ + tclDTraceDebugEnabled = 1; \ + TclDTraceDbgMsg(" | tcl-probe", "%s %s %s %s %s %s %s %s %s %s", a0, \ + a1, a2, a3, a4, a5, a6, a7, a8, a9); \ + } while (0) + +#endif /* TCL_DTRACE_DEBUG */ + +#endif diff --git a/generic/tclEngineInt.h b/generic/tclEngineInt.h new file mode 100644 index 0000000..bcd97ef --- /dev/null +++ b/generic/tclEngineInt.h @@ -0,0 +1,1215 @@ +#ifndef _TCLENGINEINT +#define _TCLENGINEINT 1 + + +#include "tclInt.h" +#include "tclEngine.h" + +/* + * tclCompile.h -- + * + * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 by Scriptics Corporation. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Daniel A. Steffen + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +/* + *---------------------------------------------------------------- + * Data structures related to bytecode compilation and execution. These are + * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. + *---------------------------------------------------------------- + */ + +/* + * Forward declaration to prevent errors when the forward references to + * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc + * declared below. + */ + +struct CompileEnv; + +/* + * The type of procedures called by the Tcl bytecode compiler to compile + * commands. Pointers to these procedures are kept in the Command structure + * describing each command. The integer value returned by a CompileProc must + * be one of the following: + * + * TCL_OK Compilation completed normally. + * TCL_ERROR Compilation could not be completed. This can be just a + * judgment by the CompileProc that the command is too + * complex to compile effectively, or it can indicate + * that in the current state of the interp, the command + * would raise an error. The bytecode compiler will not + * do any error reporting at compiler time. Error + * reporting is deferred until the actual runtime, + * because by then changes in the interp state may allow + * the command to be successfully evaluated. + * TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the + * sake of old code only. + */ + +#define TCL_OUT_LINE_COMPILE TCL_ERROR + +/* + * The data structure for a (linked list of) execution stacks. + */ + +typedef struct ExecStack { + struct ExecStack *prevPtr; + struct ExecStack *nextPtr; + Tcl_Obj **markerPtr; + Tcl_Obj **endPtr; + Tcl_Obj **tosPtr; + Tcl_Obj *stackWords[1]; +} ExecStack; + +/* + *------------------------------------------------------------------------ + * Variables related to compilation. These are used in tclCompile.c, + * tclExecute.c, tclBasic.c, and their clients. + *------------------------------------------------------------------------ + */ + +#ifdef TCL_COMPILE_DEBUG +/* + * Variable that controls whether compilation tracing is enabled and, if so, + * what level of tracing is desired: + * 0: no compilation tracing + * 1: summarize compilation of top level cmds and proc bodies + * 2: display all instructions of each ByteCode compiled + * This variable is linked to the Tcl variable "tcl_traceCompile". + */ + +MODULE_SCOPE int tclTraceCompile; + +/* + * Variable that controls whether execution tracing is enabled and, if so, + * what level of tracing is desired: + * 0: no execution tracing + * 1: trace invocations of Tcl procs only + * 2: trace invocations of all (not compiled away) commands + * 3: display each instruction executed + * This variable is linked to the Tcl variable "tcl_traceExec". + */ + +MODULE_SCOPE int tclTraceExec; +#endif + +/* + *------------------------------------------------------------------------ + * Data structures related to compilation. + *------------------------------------------------------------------------ + */ + +/* + * The structure used to implement Tcl "exceptions" (exceptional returns): for + * example, those generated in loops by the break and continue commands, and + * those generated by scripts and caught by the catch command. This + * ExceptionRange structure describes a range of code (e.g., a loop body), the + * kind of exceptions (e.g., a break or continue) that might occur, and the PC + * offsets to jump to if a matching exception does occur. Exception ranges can + * nest so this structure includes a nesting level that is used at runtime to + * find the closest exception range surrounding a PC. For example, when a + * break command is executed, the ExceptionRange structure for the most deeply + * nested loop, if any, is found and used. These structures are also generated + * for the "next" subcommands of for loops since a break there terminates the + * for command. This means a for command actually generates two LoopInfo + * structures. + */ + +typedef enum { + LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. Break + * and continue "exceptions" cause jumps to + * appropriate PC offsets. */ + CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch + * command. Errors in the range cause a jump + * to a catch PC offset. */ +} ExceptionRangeType; + +typedef struct ExceptionRange { + ExceptionRangeType type; /* The kind of ExceptionRange. */ + int nestingLevel; /* Static depth of the exception range. Used + * to find the most deeply-nested range + * surrounding a PC at runtime. */ + int codeOffset; /* Offset of the first instruction byte of the + * code range. */ + int numCodeBytes; /* Number of bytes in the code range. */ + int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC + * offset for a break command in the range. */ + int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the + * target PC offset for a continue command in + * the code range. Otherwise, ignore this + * range when processing a continue + * command. */ + int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC + * offset for any "exception" in range. */ +} ExceptionRange; + +/* + * Structure used to map between instruction pc and source locations. It + * defines for each compiled Tcl command its code's starting offset and its + * source's starting offset and length. Note that the code offset increases + * monotonically: that is, the table is sorted in code offset order. The + * source offset is not monotonic. + */ + +typedef struct CmdLocation { + int codeOffset; /* Offset of first byte of command code. */ + int numCodeBytes; /* Number of bytes for command's code. */ + int srcOffset; /* Offset of first char of the command. */ + int numSrcBytes; /* Number of command source chars. */ +} CmdLocation; + +/* + * CompileProcs need the ability to record information during compilation that + * can be used by bytecode instructions during execution. The AuxData + * structure provides this "auxiliary data" mechanism. An arbitrary number of + * these structures can be stored in the ByteCode record (during compilation + * they are stored in a CompileEnv structure). Each AuxData record holds one + * word of client-specified data (often a pointer) and is given an index that + * instructions can later use to look up the structure and its data. + * + * The following definitions declare the types of procedures that are called + * to duplicate or free this auxiliary data when the containing ByteCode + * objects are duplicated and freed. Pointers to these procedures are kept in + * the AuxData structure. + */ + +typedef ClientData (AuxDataDupProc) (ClientData clientData); +typedef void (AuxDataFreeProc) (ClientData clientData); +typedef void (AuxDataPrintProc)(ClientData clientData, + Tcl_Obj *appendObj, struct ByteCode *codePtr, + unsigned int pcOffset); + +/* + * We define a separate AuxDataType struct to hold type-related information + * for the AuxData structure. This separation makes it possible for clients + * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for + * example, it makes it possible to pickle and unpickle AuxData structs. + */ + +typedef struct AuxDataType { + const char *name; /* The name of the type. Types can be + * registered and found by name */ + AuxDataDupProc *dupProc; /* Callback procedure to invoke when the aux + * data is duplicated (e.g., when the ByteCode + * structure containing the aux data is + * duplicated). NULL means just copy the + * source clientData bits; no proc need be + * called. */ + AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the aux + * data is freed. NULL means no proc need be + * called. */ + AuxDataPrintProc *printProc;/* Callback function to invoke when printing + * the aux data as part of debugging. NULL + * means that the data can't be printed. */ +} AuxDataType; + +/* + * The definition of the AuxData structure that holds information created + * during compilation by CompileProcs and used by instructions during + * execution. + */ + +typedef struct AuxData { + const AuxDataType *type; /* Pointer to the AuxData type associated with + * this ClientData. */ + ClientData clientData; /* The compilation data itself. */ +} AuxData; + +/* + * Structure defining the compilation environment. After compilation, fields + * describing bytecode instructions are copied out into the more compact + * ByteCode structure defined below. + */ + +#define COMPILEENV_INIT_CODE_BYTES 250 +#define COMPILEENV_INIT_NUM_OBJECTS 60 +#define COMPILEENV_INIT_EXCEPT_RANGES 5 +#define COMPILEENV_INIT_CMD_MAP_SIZE 40 +#define COMPILEENV_INIT_AUX_DATA_SIZE 5 + +typedef struct CompileEnv { + Interp *iPtr; /* Interpreter containing the code being + * compiled. Commands and their compile procs + * are specific to an interpreter so the code + * emitted will depend on the interpreter. */ + const char *source; /* The source string being compiled by + * SetByteCodeFromAny. This pointer is not + * owned by the CompileEnv and must not be + * freed or changed by it. */ + int numSrcBytes; /* Number of bytes in source. */ + Proc *procPtr; /* If a procedure is being compiled, a pointer + * to its Proc structure; otherwise NULL. Used + * to compile local variables. Set from + * information provided by ObjInterpProc in + * tclProc.c. */ + int numCommands; /* Number of commands compiled. */ + int exceptDepth; /* Current exception range nesting level; -1 + * if not in any range currently. */ + int maxExceptDepth; /* Max nesting level of exception ranges; -1 + * if no ranges have been compiled. */ + int maxStackDepth; /* Maximum number of stack elements needed to + * execute the code. Set by compilation + * procedures before returning. */ + int currStackDepth; /* Current stack depth. */ + LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl + * objects referenced by this compiled code. + * Indexed by the string representations of + * the literals. Used to avoid creating + * duplicate objects. */ + unsigned char *codeStart; /* Points to the first byte of the code. */ + unsigned char *codeNext; /* Points to next code array byte to use. */ + unsigned char *codeEnd; /* Points just after the last allocated code + * array byte. */ + int mallocedCodeArray; /* Set 1 if code array was expanded and + * codeStart points into the heap.*/ + LiteralEntry *literalArrayPtr; + /* Points to start of LiteralEntry array. */ + int literalArrayNext; /* Index of next free object array entry. */ + int literalArrayEnd; /* Index just after last obj array entry. */ + int mallocedLiteralArray; /* 1 if object array was expanded and objArray + * points into the heap, else 0. */ + ExceptionRange *exceptArrayPtr; + /* Points to start of the ExceptionRange + * array. */ + int exceptArrayNext; /* Next free ExceptionRange array index. + * exceptArrayNext is the number of ranges and + * (exceptArrayNext-1) is the index of the + * current range's array entry. */ + int exceptArrayEnd; /* Index after the last ExceptionRange array + * entry. */ + int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and + * exceptArrayPtr points in heap, else 0. */ + CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. + * numCommands is the index of the next entry + * to use; (numCommands-1) is the entry index + * for the last command. */ + int cmdMapEnd; /* Index after last CmdLocation entry. */ + int mallocedCmdMap; /* 1 if command map array was expanded and + * cmdMapPtr points in the heap, else 0. */ + AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ + int auxDataArrayNext; /* Next free compile aux data array index. + * auxDataArrayNext is the number of aux data + * items and (auxDataArrayNext-1) is index of + * current aux data array entry. */ + int auxDataArrayEnd; /* Index after last aux data array entry. */ + int mallocedAuxDataArray; /* 1 if aux data array was expanded and + * auxDataArrayPtr points in heap else 0. */ + unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; + /* Initial storage for code. */ + LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; + /* Initial storage of LiteralEntry array. */ + ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; + /* Initial ExceptionRange array storage. */ + CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; + /* Initial storage for cmd location map. */ + AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; + /* Initial storage for aux data array. */ + int atCmdStart; /* Flag to say whether an INST_START_CMD + * should be issued; they should never be + * issued repeatedly, as that is significantly + * inefficient. */ +} CompileEnv; + +/* + * Opcodes for the Tcl bytecode instructions. These must correspond to the + * entries in the table of instruction descriptions, tclInstructionTable, in + * tclCompile.c. Also, the order and number of the expression opcodes (e.g., + * INST_LOR) must match the entries in the array operatorStrings in + * tclExecute.c. + */ + +/* Opcodes 0 to 9 */ +#define INST_DONE 0 +#define INST_PUSH1 1 +#define INST_PUSH4 2 +#define INST_POP 3 +#define INST_DUP 4 +#define INST_CONCAT1 5 +#define INST_INVOKE_STK1 6 +#define INST_INVOKE_STK4 7 +#define INST_EVAL_STK 8 +#define INST_EXPR_STK 9 + +/* Opcodes 10 to 23 */ +#define INST_LOAD_SCALAR1 10 +#define INST_LOAD_SCALAR4 11 +#define INST_LOAD_SCALAR_STK 12 +#define INST_LOAD_ARRAY1 13 +#define INST_LOAD_ARRAY4 14 +#define INST_LOAD_ARRAY_STK 15 +#define INST_LOAD_STK 16 +#define INST_STORE_SCALAR1 17 +#define INST_STORE_SCALAR4 18 +#define INST_STORE_SCALAR_STK 19 +#define INST_STORE_ARRAY1 20 +#define INST_STORE_ARRAY4 21 +#define INST_STORE_ARRAY_STK 22 +#define INST_STORE_STK 23 + +/* Opcodes 24 to 33 */ +#define INST_INCR_SCALAR1 24 +#define INST_INCR_SCALAR_STK 25 +#define INST_INCR_ARRAY1 26 +#define INST_INCR_ARRAY_STK 27 +#define INST_INCR_STK 28 +#define INST_INCR_SCALAR1_IMM 29 +#define INST_INCR_SCALAR_STK_IMM 30 +#define INST_INCR_ARRAY1_IMM 31 +#define INST_INCR_ARRAY_STK_IMM 32 +#define INST_INCR_STK_IMM 33 + +/* Opcodes 34 to 39 */ +#define INST_JUMP1 34 +#define INST_JUMP4 35 +#define INST_JUMP_TRUE1 36 +#define INST_JUMP_TRUE4 37 +#define INST_JUMP_FALSE1 38 +#define INST_JUMP_FALSE4 39 + +/* Opcodes 40 to 64 */ +#define INST_LOR 40 +#define INST_LAND 41 +#define INST_BITOR 42 +#define INST_BITXOR 43 +#define INST_BITAND 44 +#define INST_EQ 45 +#define INST_NEQ 46 +#define INST_LT 47 +#define INST_GT 48 +#define INST_LE 49 +#define INST_GE 50 +#define INST_LSHIFT 51 +#define INST_RSHIFT 52 +#define INST_ADD 53 +#define INST_SUB 54 +#define INST_MULT 55 +#define INST_DIV 56 +#define INST_MOD 57 +#define INST_UPLUS 58 +#define INST_UMINUS 59 +#define INST_BITNOT 60 +#define INST_LNOT 61 +#define INST_CALL_BUILTIN_FUNC1 62 +#define INST_CALL_FUNC1 63 +#define INST_TRY_CVT_TO_NUMERIC 64 + +/* Opcodes 65 to 66 */ +#define INST_BREAK 65 +#define INST_CONTINUE 66 + +/* Opcodes 67 to 68 */ +#define INST_FOREACH_START4 67 +#define INST_FOREACH_STEP4 68 + +/* Opcodes 69 to 72 */ +#define INST_BEGIN_CATCH4 69 +#define INST_END_CATCH 70 +#define INST_PUSH_RESULT 71 +#define INST_PUSH_RETURN_CODE 72 + +/* Opcodes 73 to 78 */ +#define INST_STR_EQ 73 +#define INST_STR_NEQ 74 +#define INST_STR_CMP 75 +#define INST_STR_LEN 76 +#define INST_STR_INDEX 77 +#define INST_STR_MATCH 78 + +/* Opcodes 78 to 81 */ +#define INST_LIST 79 +#define INST_LIST_INDEX 80 +#define INST_LIST_LENGTH 81 + +/* Opcodes 82 to 87 */ +#define INST_APPEND_SCALAR1 82 +#define INST_APPEND_SCALAR4 83 +#define INST_APPEND_ARRAY1 84 +#define INST_APPEND_ARRAY4 85 +#define INST_APPEND_ARRAY_STK 86 +#define INST_APPEND_STK 87 + +/* Opcodes 88 to 93 */ +#define INST_LAPPEND_SCALAR1 88 +#define INST_LAPPEND_SCALAR4 89 +#define INST_LAPPEND_ARRAY1 90 +#define INST_LAPPEND_ARRAY4 91 +#define INST_LAPPEND_ARRAY_STK 92 +#define INST_LAPPEND_STK 93 + +/* TIP #22 - LINDEX operator with flat arg list */ + +#define INST_LIST_INDEX_MULTI 94 + +/* + * TIP #33 - 'lset' command. Code gen also required a Forth-like + * OVER operation. + */ + +#define INST_OVER 95 +#define INST_LSET_LIST 96 +#define INST_LSET_FLAT 97 + +/* TIP#90 - 'return' command. */ + +#define INST_RETURN_IMM 98 + +/* TIP#123 - exponentiation operator. */ + +#define INST_EXPON 99 + +/* TIP #157 - {*}... (word expansion) language syntax support. */ + +#define INST_EXPAND_START 100 +#define INST_EXPAND_STKTOP 101 +#define INST_INVOKE_EXPANDED 102 + +/* + * TIP #57 - 'lassign' command. Code generation requires immediate + * LINDEX and LRANGE operators. + */ + +#define INST_LIST_INDEX_IMM 103 +#define INST_LIST_RANGE_IMM 104 + +#define INST_START_CMD 105 + +#define INST_LIST_IN 106 +#define INST_LIST_NOT_IN 107 + +#define INST_PUSH_RETURN_OPTIONS 108 +#define INST_RETURN_STK 109 + +/* + * Dictionary (TIP#111) related commands. + */ + +#define INST_DICT_GET 110 +#define INST_DICT_SET 111 +#define INST_DICT_UNSET 112 +#define INST_DICT_INCR_IMM 113 +#define INST_DICT_APPEND 114 +#define INST_DICT_LAPPEND 115 +#define INST_DICT_FIRST 116 +#define INST_DICT_NEXT 117 +#define INST_DICT_DONE 118 +#define INST_DICT_UPDATE_START 119 +#define INST_DICT_UPDATE_END 120 + +/* + * Instruction to support jumps defined by tables (instead of the classic + * [switch] technique of chained comparisons). + */ + +#define INST_JUMP_TABLE 121 + +/* + * Instructions to support compilation of global, variable, upvar and + * [namespace upvar]. + */ + +#define INST_UPVAR 122 +#define INST_NSUPVAR 123 +#define INST_VARIABLE 124 + +/* Instruction to support compiling syntax error to bytecode */ + +#define INST_SYNTAX 125 + +/* Instruction to reverse N items on top of stack */ + +#define INST_REVERSE 126 + +/* regexp instruction */ + +#define INST_REGEXP 127 + +/* For [info exists] compilation */ +#define INST_EXIST_SCALAR 128 +#define INST_EXIST_ARRAY 129 +#define INST_EXIST_ARRAY_STK 130 +#define INST_EXIST_STK 131 + +/* For [subst] compilation */ +#define INST_NOP 132 +#define INST_RETURN_CODE_BRANCH 133 + +/* For [unset] compilation */ +#define INST_UNSET_SCALAR 134 +#define INST_UNSET_ARRAY 135 +#define INST_UNSET_ARRAY_STK 136 +#define INST_UNSET_STK 137 + +/* For [dict with], [dict exists], [dict create] and [dict merge] */ +#define INST_DICT_EXPAND 138 +#define INST_DICT_RECOMBINE_STK 139 +#define INST_DICT_RECOMBINE_IMM 140 +#define INST_DICT_EXISTS 141 +#define INST_DICT_VERIFY 142 + +/* For [string map] and [regsub] compilation */ +#define INST_STR_MAP 143 +#define INST_STR_FIND 144 +#define INST_STR_FIND_LAST 145 +#define INST_STR_RANGE_IMM 146 +#define INST_STR_RANGE 147 + +/* For operations to do with coroutines and other NRE-manipulators */ +#define INST_YIELD 148 +#define INST_COROUTINE_NAME 149 +#define INST_TAILCALL 150 + +/* For compilation of basic information operations */ +#define INST_NS_CURRENT 151 +#define INST_INFO_LEVEL_NUM 152 +#define INST_INFO_LEVEL_ARGS 153 +#define INST_RESOLVE_COMMAND 154 +#define INST_TCLOO_SELF 155 +#define INST_TCLOO_CLASS 156 +#define INST_TCLOO_NS 157 +#define INST_TCLOO_IS_OBJECT 158 + +/* For compilation of [array] subcommands */ +#define INST_ARRAY_EXISTS_STK 159 +#define INST_ARRAY_EXISTS_IMM 160 +#define INST_ARRAY_MAKE_STK 161 +#define INST_ARRAY_MAKE_IMM 162 + +#define INST_INVOKE_REPLACE 163 + +/* The last opcode */ +#define LAST_INST_OPCODE 163 + +/* + * Table describing the Tcl bytecode instructions: their name (for displaying + * code), total number of code bytes required (including operand bytes), and a + * description of the type of each operand. These operand types include signed + * and unsigned integers of length one and four bytes. The unsigned integers + * are used for indexes or for, e.g., the count of objects to push in a "push" + * instruction. + */ + +#define MAX_INSTRUCTION_OPERANDS 2 + +typedef enum InstOperandType { + OPERAND_NONE, + OPERAND_INT1, /* One byte signed integer. */ + OPERAND_INT4, /* Four byte signed integer. */ + OPERAND_UINT1, /* One byte unsigned integer. */ + OPERAND_UINT4, /* Four byte unsigned integer. */ + OPERAND_IDX4, /* Four byte signed index (actually an + * integer, but displayed differently.) */ + OPERAND_LVT1, /* One byte unsigned index into the local + * variable table. */ + OPERAND_LVT4, /* Four byte unsigned index into the local + * variable table. */ + OPERAND_AUX4 /* Four byte unsigned index into the aux data + * table. */ +} InstOperandType; + +typedef struct InstructionDesc { + const char *name; /* Name of instruction. */ + int numBytes; /* Total number of bytes for instruction. */ + int stackEffect; /* The worst-case balance stack effect of the + * instruction, used for stack requirements + * computations. The value INT_MIN signals + * that the instruction's worst case effect is + * (1-opnd1). */ + int numOperands; /* Number of operands. */ + InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; + /* The type of each operand. */ +} InstructionDesc; + +MODULE_SCOPE InstructionDesc const tclInstructionTable[]; + +/* + * Compilation of some Tcl constructs such as if commands and the logical or + * (||) and logical and (&&) operators in expressions requires the generation + * of forward jumps. Since the PC target of these jumps isn't known when the + * jumps are emitted, we record the offset of each jump in an array of + * JumpFixup structures. There is one array for each sequence of jumps to one + * target PC. When we learn the target PC, we update the jumps with the + * correct distance. Also, if the distance is too great (> 127 bytes), we + * replace the single-byte jump with a four byte jump instruction, move the + * instructions after the jump down, and update the code offsets for any + * commands between the jump and the target. + */ + +typedef enum { + TCL_UNCONDITIONAL_JUMP, + TCL_TRUE_JUMP, + TCL_FALSE_JUMP +} TclJumpType; + +typedef struct JumpFixup { + TclJumpType jumpType; /* Indicates the kind of jump. */ + int codeOffset; /* Offset of the first byte of the one-byte + * forward jump's code. */ + int cmdIndex; /* Index of the first command after the one + * for which the jump was emitted. Used to + * update the code offsets for subsequent + * commands if the two-byte jump at jumpPc + * must be replaced with a five-byte one. */ + int exceptIndex; /* Index of the first range entry in the + * ExceptionRange array after the current one. + * This field is used to adjust the code + * offsets in subsequent ExceptionRange + * records when a jump is grown from 2 bytes + * to 5 bytes. */ +} JumpFixup; + +#define JUMPFIXUP_INIT_ENTRIES 10 + +typedef struct JumpFixupArray { + JumpFixup *fixup; /* Points to start of jump fixup array. */ + int next; /* Index of next free array entry. */ + int end; /* Index of last usable entry in array. */ + int mallocedArray; /* 1 if array was expanded and fixups points + * into the heap, else 0. */ + JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; + /* Initial storage for jump fixup array. */ +} JumpFixupArray; + +/* + * The structure describing one variable list of a foreach command. Note that + * only foreach commands inside procedure bodies are compiled inline so a + * ForeachVarList structure always describes local variables. Furthermore, + * only scalar variables are supported for inline-compiled foreach loops. + */ + +typedef struct ForeachVarList { + int numVars; /* The number of variables in the list. */ + int varIndexes[1]; /* An array of the indexes ("slot numbers") + * for each variable in the procedure's array + * of local variables. Only scalar variables + * are supported. The actual size of this + * field will be large enough to numVars + * indexes. THIS MUST BE THE LAST FIELD IN THE + * STRUCTURE! */ +} ForeachVarList; + +/* + * Structure used to hold information about a foreach command that is needed + * during program execution. These structures are stored in CompileEnv and + * ByteCode structures as auxiliary data. + */ + +typedef struct ForeachInfo { + int numLists; /* The number of both the variable and value + * lists of the foreach command. */ + int firstValueTemp; /* Index of the first temp var in a proc frame + * used to point to a value list. */ + int loopCtTemp; /* Index of temp var in a proc frame holding + * the loop's iteration count. Used to + * determine next value list element to assign + * each loop var. */ + ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList + * structures describing each var list. The + * actual size of this field will be large + * enough to numVars indexes. THIS MUST BE THE + * LAST FIELD IN THE STRUCTURE! */ +} ForeachInfo; + +MODULE_SCOPE const AuxDataType tclForeachInfoType; + +/* + * Structure used to hold information about a switch command that is needed + * during program execution. These structures are stored in CompileEnv and + * ByteCode structures as auxiliary data. + */ + +typedef struct JumptableInfo { + Tcl_HashTable hashTable; /* Hash that maps strings to signed ints (PC + * offsets). */ +} JumptableInfo; + +MODULE_SCOPE const AuxDataType tclJumptableInfoType; + +/* + * Structure used to hold information about a [dict update] command that is + * needed during program execution. These structures are stored in CompileEnv + * and ByteCode structures as auxiliary data. + */ + +typedef struct { + int length; /* Size of array */ + int varIndices[1]; /* Array of variable indices to manage when + * processing the start and end of a [dict + * update]. There is really more than one + * entry, and the structure is allocated to + * take account of this. MUST BE LAST FIELD IN + * STRUCTURE. */ +} DictUpdateInfo; + +MODULE_SCOPE const AuxDataType tclDictUpdateInfoType; + + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl bytecode compilation and execution modules but + * not used outside: + *---------------------------------------------------------------- + */ + +MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); +MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count, + CompileEnv *envPtr); +MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, + int numBytes, CompileEnv *envPtr, int optimize); +MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, + Tcl_Token *tokenPtr, int numWords, + CompileEnv *envPtr); +MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, + const char *script, int numBytes, + CompileEnv *envPtr); +MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, + CompileEnv *envPtr); +MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count, + CompileEnv *envPtr); +MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, + Tcl_Token *tokenPtr, CompileEnv *envPtr); +MODULE_SCOPE int TclCreateAuxData(ClientData clientData, + const AuxDataType *typePtr, CompileEnv *envPtr); +MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, + CompileEnv *envPtr); +MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, + TclJumpType jumpType, JumpFixup *jumpFixupPtr); +MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, + int catchOnly, ByteCode *codePtr); +MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); +MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void); +MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, + int create, CompileEnv *envPtr); +MODULE_SCOPE LiteralEntry * TclLookupLiteralEntry(Tcl_Interp *interp, + Tcl_Obj *objPtr); +MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, + JumpFixup *jumpFixupPtr, int jumpDist, + int distThreshold); +MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); +MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); +MODULE_SCOPE void TclInitAuxDataTypeTable(void); +MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, + CompileEnv *envPtr); +MODULE_SCOPE void TclInitCompilation(void); +MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); +#ifdef TCL_COMPILE_DEBUG +MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); +#endif +MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, + const unsigned char *pc); +MODULE_SCOPE void TclPrintObject(FILE *outFile, + Tcl_Obj *objPtr, int maxChars); +MODULE_SCOPE void TclPrintSource(FILE *outFile, + const char *string, int maxChars); +MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr); +MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, + char *bytes, int length, int flags); +#ifdef TCL_COMPILE_DEBUG +MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); +MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); +#endif +MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, + Tcl_Obj *valuePtr); + +/* + *---------------------------------------------------------------- + * Macros and flag values used by Tcl bytecode compilation and execution + * modules inside the Tcl core but not used outside. + *---------------------------------------------------------------- + */ + +#define LITERAL_ON_HEAP 0x01 +#define LITERAL_CMD_NAME 0x02 + +/* + * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to + * cast away constness, and it is cleanest to do that here, all in one place. + * + * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) + +/* + * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it + * is safe to cast away constness, and it is cleanest to do that here, all in + * one place. + * + * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) + +/* + * Macro used to manually adjust the stack requirements; used in cases where + * the stack effect cannot be computed from the opcode and its operands, but + * is still known at compile time. + * + * void TclAdjustStackDepth(int delta, CompileEnv *envPtr); + */ + +#define TclAdjustStackDepth(delta, envPtr) \ + do { \ + if ((delta) < 0) { \ + if ((envPtr)->maxStackDepth < (envPtr)->currStackDepth) { \ + (envPtr)->maxStackDepth = (envPtr)->currStackDepth; \ + } \ + } \ + (envPtr)->currStackDepth += (delta); \ + } while (0) + +/* + * Macro used to update the stack requirements. It is called by the macros + * TclEmitOpCode, TclEmitInst1 and TclEmitInst4. + * Remark that the very last instruction of a bytecode always reduces the + * stack level: INST_DONE or INST_POP, so that the maxStackdepth is always + * updated. + * + * void TclUpdateStackReqs(unsigned char op, int i, CompileEnv *envPtr); + */ + +#define TclUpdateStackReqs(op, i, envPtr) \ + do { \ + int delta = tclInstructionTable[(op)].stackEffect; \ + if (delta) { \ + if (delta == INT_MIN) { \ + delta = 1 - (i); \ + } \ + TclAdjustStackDepth(delta, envPtr); \ + } \ + } while (0) + +/* + * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C + * "prototype" for this macro is: + * + * void TclEmitOpcode(unsigned char op, CompileEnv *envPtr); + */ + +#define TclEmitOpcode(op, envPtr) \ + do { \ + if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateStackReqs(op, 0, envPtr); \ + } while (0) + +/* + * Macros to emit an integer operand. The ANSI C "prototype" for these macros + * are: + * + * void TclEmitInt1(int i, CompileEnv *envPtr); + * void TclEmitInt4(int i, CompileEnv *envPtr); + */ + +#define TclEmitInt1(i, envPtr) \ + do { \ + if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ + } while (0) + +#define TclEmitInt4(i, envPtr) \ + do { \ + if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 24); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 16); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 8); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) ); \ + } while (0) + +/* + * Macros to emit an instruction with signed or unsigned integer operands. + * Four byte integers are stored in "big-endian" order with the high order + * byte stored at the lowest address. The ANSI C "prototypes" for these macros + * are: + * + * void TclEmitInstInt1(unsigned char op, int i, CompileEnv *envPtr); + * void TclEmitInstInt4(unsigned char op, int i, CompileEnv *envPtr); + */ + +#define TclEmitInstInt1(op, i, envPtr) \ + do { \ + if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ + (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateStackReqs(op, i, envPtr); \ + } while (0) + +#define TclEmitInstInt4(op, i, envPtr) \ + do { \ + if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 24); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 16); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) >> 8); \ + *(envPtr)->codeNext++ = \ + (unsigned char) ((unsigned int) (i) ); \ + (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateStackReqs(op, i, envPtr); \ + } while (0) + +/* + * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the + * object's one or four byte array index into the CompileEnv's code array. + * These support, respectively, a maximum of 256 (2**8) and 2**32 objects in a + * CompileEnv. The ANSI C "prototype" for this macro is: + * + * void TclEmitPush(int objIndex, CompileEnv *envPtr); + */ + +#define TclEmitPush(objIndex, envPtr) \ + do { \ + register int objIndexCopy = (objIndex); \ + if (objIndexCopy <= 255) { \ + TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \ + } else { \ + TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ + } \ + } while (0) + +/* + * Macros to update a (signed or unsigned) integer starting at a pointer. The + * two variants depend on the number of bytes. The ANSI C "prototypes" for + * these macros are: + * + * void TclStoreInt1AtPtr(int i, unsigned char *p); + * void TclStoreInt4AtPtr(int i, unsigned char *p); + */ + +#define TclStoreInt1AtPtr(i, p) \ + *(p) = (unsigned char) ((unsigned int) (i)) + +#define TclStoreInt4AtPtr(i, p) \ + do { \ + *(p) = (unsigned char) ((unsigned int) (i) >> 24); \ + *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \ + *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \ + *(p+3) = (unsigned char) ((unsigned int) (i) ); \ + } while (0) + +/* + * Macros to update instructions at a particular pc with a new op code and a + * (signed or unsigned) int operand. The ANSI C "prototypes" for these macros + * are: + * + * void TclUpdateInstInt1AtPc(unsigned char op, int i, unsigned char *pc); + * void TclUpdateInstInt4AtPc(unsigned char op, int i, unsigned char *pc); + */ + +#define TclUpdateInstInt1AtPc(op, i, pc) \ + do { \ + *(pc) = (unsigned char) (op); \ + TclStoreInt1AtPtr((i), ((pc)+1)); \ + } while (0) + +#define TclUpdateInstInt4AtPc(op, i, pc) \ + do { \ + *(pc) = (unsigned char) (op); \ + TclStoreInt4AtPtr((i), ((pc)+1)); \ + } while (0) + +/* + * Macro to fix up a forward jump to point to the current code-generation + * position in the bytecode being created (the most common case). The ANSI C + * "prototypes" for this macro is: + * + * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr, + * int threshold); + */ + +#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ + TclFixupForwardJump((envPtr), (fixupPtr), \ + (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ + (threshold)) + +/* + * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int + * (GET_UINT{1,2}) from a pointer. There are two variants for each return type + * that depend on the number of bytes fetched. The ANSI C "prototypes" for + * these macros are: + * + * int TclGetInt1AtPtr(unsigned char *p); + * int TclGetInt4AtPtr(unsigned char *p); + * unsigned int TclGetUInt1AtPtr(unsigned char *p); + * unsigned int TclGetUInt4AtPtr(unsigned char *p); + */ + +/* + * The TclGetInt1AtPtr macro is tricky because we want to do sign extension on + * the 1-byte value. Unfortunately the "char" type isn't signed on all + * platforms so sign-extension doesn't always happen automatically. Sometimes + * we can explicitly declare the pointer to be signed, but other times we have + * to explicitly sign-extend the value in software. + */ + +#ifndef __CHAR_UNSIGNED__ +# define TclGetInt1AtPtr(p) ((int) *((char *) p)) +#elif defined(HAVE_SIGNED_CHAR) +# define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) +#else +# define TclGetInt1AtPtr(p) \ + (((int) *((char *) p)) | ((*(p) & 0200) ? (-256) : 0)) +#endif + +#define TclGetInt4AtPtr(p) \ + (((int) TclGetInt1AtPtr(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3))) + +#define TclGetUInt1AtPtr(p) \ + ((unsigned int) *(p)) +#define TclGetUInt4AtPtr(p) \ + ((unsigned int) (*(p) << 24) | \ + (*((p)+1) << 16) | \ + (*((p)+2) << 8) | \ + (*((p)+3))) + +/* + * Macros used to compute the minimum and maximum of two integers. The ANSI C + * "prototypes" for these macros are: + * + * int TclMin(int i, int j); + * int TclMax(int i, int j); + */ + +#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) +#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) + +/* + * Convenience macro for use when compiling bodies of commands. The ANSI C + * "prototype" for this macro is: + * + * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp); + */ + +#define CompileBody(envPtr, tokenPtr, interp) \ + TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)) + +/* + * Convenience macro for use when compiling tokens to be pushed. The ANSI C + * "prototype" for this macro is: + * + * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp); + */ + +#define CompileTokens(envPtr, tokenPtr, interp) \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); +/* + * Convenience macro for use when pushing literals. The ANSI C "prototype" for + * this macro is: + * + * static void PushLiteral(CompileEnv *envPtr, + * const char *string, int length); + */ + +#define PushLiteral(envPtr, string, length) \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) + +/* + * Macro to advance to the next token; it is more mnemonic than the address + * arithmetic that it replaces. The ANSI C "prototype" for this macro is: + * + * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr); + */ + +#define TokenAfter(tokenPtr) \ + ((tokenPtr) + ((tokenPtr)->numComponents + 1)) + +/* + * Macro to get the offset to the next instruction to be issued. The ANSI C + * "prototype" for this macro is: + * + * static int CurrentOffset(CompileEnv *envPtr); + */ + +#define CurrentOffset(envPtr) \ + ((envPtr)->codeNext - (envPtr)->codeStart) + +/* + * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the + * maximal depth of nested CATCH ranges in order to alloc runtime + * memory. These macros should compute precisely that? OTOH, the nesting depth + * of LOOP ranges is an interesting datum for debugging purposes, and that is + * what we compute now. + * + * static int DeclareExceptionRange(CompileEnv *envPtr, int type); + * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); + * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); + * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); + */ + +#define DeclareExceptionRange(envPtr, type) \ + (TclCreateExceptRange((type), (envPtr))) +#define ExceptionRangeStarts(envPtr, index) \ + (((envPtr)->exceptDepth++), \ + ((envPtr)->maxExceptDepth = \ + TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ + ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) +#define ExceptionRangeEnds(envPtr, index) \ + (((envPtr)->exceptDepth--), \ + ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ + CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) +#define ExceptionRangeTarget(envPtr, index, targetType) \ + ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) + +/* + * Check if there is an LVT for compiled locals + */ + +#define EnvHasLVT(envPtr) \ + (envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr) + +/* + * Macros for making it easier to deal with tokens and DStrings. + */ + +#define TclDStringAppendToken(dsPtr, tokenPtr) \ + Tcl_DStringAppend((dsPtr), (tokenPtr)->start, (tokenPtr)->size) +#define TclRegisterDStringLiteral(envPtr, dsPtr) \ + TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \ + Tcl_DStringLength(dsPtr), /*flags*/ 0) + +#endif /* _TCLENGINEINT */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 26b9aff..e161ba2 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -11,7 +11,6 @@ */ #include "tclInt.h" -#include "tclCompile.h" /* * Declarations for functions local to this file: @@ -35,15 +34,6 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); -static int CompileToCompiledCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, - CompileEnv *envPtr); -static void CompileToInvokedCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Tcl_Obj *replacements, - Command *cmdPtr, CompileEnv *envPtr); -static int CompileBasicNArgCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - CompileEnv *envPtr); /* * The lists of subcommands and options for the [namespace ensemble] command. @@ -2714,805 +2704,6 @@ StringOfEnsembleCmdRep( } /* - *---------------------------------------------------------------------- - * - * TclCompileEnsemble -- - * - * Procedure called to compile an ensemble command. Note that most - * ensembles are not compiled, since modifying a compiled ensemble causes - * a invalidation of all existing bytecode (expensive!) which is not - * normally warranted. - * - * 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 subcommands of the - * ensemble at runtime if a compile-time mapping is possible. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileEnsemble( - 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. */ -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; - Tcl_Obj *replaced = Tcl_NewObj(), *replacement; - Tcl_Command ensemble = (Tcl_Command) cmdPtr; - Command *oldCmdPtr = cmdPtr, *newCmdPtr; - int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; - int ourResult = TCL_ERROR; - unsigned numBytes; - const char *word; - - Tcl_IncrRefCount(replaced); - - /* - * This is where we return to if we are parsing multiple nested compiled - * ensembles. [info object] is such a beast. - */ - - checkNextWord: - if (parsePtr->numWords < depth + 1) { - goto failed; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Too hard. - */ - - goto failed; - } - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - - /* - * There's a sporting chance we'll be able to compile this. But now we - * must check properly. To do that, check that we're compiling an ensemble - * that has a compilable command as its appropriate subcommand. - */ - - if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK - || mapObj == NULL) { - /* - * Either not an ensemble or a mapping isn't installed. Crud. Too hard - * to proceed. - */ - - goto failed; - } - - /* - * Also refuse to compile anything that uses a formal parameter list for - * now, on the grounds that it is too complex. - */ - - if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK - || listObj != NULL) { - /* - * Figuring out how to compile this has become too much. Bail out. - */ - - goto failed; - } - - /* - * Next, get the flags. We need them on several code paths so that we can - * know whether we're to do prefix matching. - */ - - (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags); - - /* - * Check to see if there's also a subcommand list; must check to see if - * the subcommand we are calling is in that list if it exists, since that - * list filters the entries in the map. - */ - - (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj); - if (listObj != NULL) { - int sclen; - const char *str; - Tcl_Obj *matchObj = NULL; - - if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { - goto failed; - } - for (i=0 ; insPtr->flags & NS_SUPPRESS_COMPILATION - || newCmdPtr->flags & CMD_HAS_EXEC_TRACES - || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { - /* - * Maps to an undefined command or a command without a compiler. - * Cannot compile. - */ - - goto cleanup; - } - cmdPtr = newCmdPtr; - depth++; - - /* - * See whether we have a nested ensemble. If we do, we can go round the - * mulberry bush again, consuming the next word. - */ - - if (cmdPtr->compileProc == TclCompileEnsemble) { - tokenPtr = TokenAfter(tokenPtr); - ensemble = (Tcl_Command) cmdPtr; - goto checkNextWord; - } - - /* - * Now we've done the mapping process, can now actually try to compile. - * If there is a subcommand compiler and that successfully produces code, - * we'll use that. Otherwise, we fall back to generating opcodes to do the - * invoke at runtime. - */ - - invokeAnyway = 1; - if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, - envPtr) == TCL_OK) { - ourResult = TCL_OK; - goto cleanup; - } - - /* - * Failed to do a full compile for some reason. Try to do a direct invoke - * instead of going through the ensemble lookup process again. - */ - - failed: - if (depth < 250) { - if (depth > 1) { - if (!invokeAnyway) { - cmdPtr = oldCmdPtr; - depth--; - } - (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL); - } - CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); - ourResult = TCL_OK; - } - - /* - * Release the memory we allocated. If we've got here, we've either done - * something useful or we're in a case that we can't compile at all and - * we're just giving up. - */ - - cleanup: - Tcl_DecrRefCount(replaced); - return ourResult; -} - -/* - * How to compile a subcommand using its own command compiler. To do that, we - * have to perform some trickery to rewrite the arguments, as compilers *must* - * have parse tokens that refer to addresses in the original script. - */ - -static int -CompileToCompiledCommand( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - int depth, - Command *cmdPtr, - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Parse synthetic; - Tcl_Token *tokenPtr; - int result, i; - int savedNumCmds = envPtr->numCommands; - int savedStackDepth = envPtr->currStackDepth; - unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; - - if (cmdPtr->compileProc == NULL) { - return TCL_ERROR; - } - - TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - depth + 1; - TclGrowParseTokenArray(&synthetic, 2); - synthetic.numTokens = 2; - - /* - * Now we have the space to work in, install something rewritten. The - * first word will "officially" be the bytes of the structured ensemble - * name. That's technically wrong, but nobody will care; we just need - * *something* here... - */ - - synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; - synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[0].numComponents = 1; - synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; - synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[1].numComponents = 0; - for (i=0,tokenPtr=parsePtr->tokenPtr ; istart - synthetic.tokenPtr[0].start) - + tokenPtr->size; - - synthetic.tokenPtr[0].size = sclen; - synthetic.tokenPtr[1].size = sclen; - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Copy over the real argument tokens. - */ - - for (i=1; inumComponents + 1; - TclGrowParseTokenArray(&synthetic, toCopy); - memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, - sizeof(Tcl_Token) * toCopy); - synthetic.numTokens += toCopy; - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Hand off compilation to the subcommand compiler. At last! - */ - - result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); - - /* - * If our target fails to compile, revert the number of commands and the - * pointer to the place to issue the next instruction. [Bug 3600328] - */ - - if (result != TCL_OK) { - envPtr->numCommands = savedNumCmds; - envPtr->currStackDepth = savedStackDepth; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; - } - - /* - * Clean up if necessary. - */ - - Tcl_FreeParse(&synthetic); - return result; -} - -/* - * How to compile a subcommand to a _replacing_ invoke of its implementation - * command. - */ - -static void -CompileToInvokedCommand( - Tcl_Interp *interp, - Tcl_Parse *parsePtr, - Tcl_Obj *replacements, - Command *cmdPtr, - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokPtr; - Tcl_Obj *objPtr, **words; - char *bytes; - int length, i, numWords, cmdLit; - - /* - * Push the words of the command. Take care; the command words may be - * scripts that have backslashes in them, and [info frame 0] can see the - * difference. Hence the call to TclContinuationsEnterDerived... - */ - - Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); - for (i=0,tokPtr=parsePtr->tokenPtr ; inumWords ; i++) { - if (i > 0 && i < numWords+1) { - bytes = Tcl_GetStringFromObj(words[i-1], &length); - PushLiteral(envPtr, bytes, length); - } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterNewLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size); - - TclEmitPush(literal, envPtr); - } else { - CompileTokens(envPtr, tokPtr, interp); - } - tokPtr = TokenAfter(tokPtr); - } - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr); - TclEmitPush(cmdLit, envPtr); - TclDecrRefCount(objPtr); - - /* - * Do the replacing dispatch. - */ - - TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); - TclEmitInt1(numWords+1, envPtr); - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */ -} - -/* - * Helpers that do issuing of instructions for commands that "don't have - * compilers" (well, they do; these). They all work by just generating base - * code to invoke the command; they're intended for ensemble subcommands so - * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out - * that they're not needed. - * - * Note that these are NOT suitable for commands where there's an argument - * that is a script, as an [info level] or [info frame] in the inner context - * can see the difference. - */ - -static int -CompileBasicNArgCommand( - 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. */ -{ - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - int length, i, literal; - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr); - TclEmitPush(literal, envPtr); - TclDecrRefCount(objPtr); - - /* - * Push the words of the command. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; inumWords ; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); - } else { - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Do the standard dispatch. - */ - - if (i <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); - } - return TCL_OK; -} - -int -TclCompileBasic0ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic2ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic3ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic0Or1ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1Or2ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic2Or3ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic0To2ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 1 || parsePtr->numWords > 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasic1To3ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin0ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 1) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin1ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 2) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -int -TclCompileBasicMin2ArgCmd( - 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. */ -{ - /* - * Verify that the number of arguments is correct; that's the only case - * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, - * which is the only code that sees the shenanigans of ensemble dispatch. - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0a8f379..b08c410 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -15,8 +15,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" -#include "tclCompile.h" +#include "tclEngineInt.h" #include "tclOOInt.h" #include "tommath.h" #include diff --git a/generic/tclInt.decls b/generic/tclInt.decls index a57afed..f9d749c 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -565,10 +565,10 @@ declare 138 { declare 141 { CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } -declare 142 { - int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, - CompileHookProc *hookProc, ClientData clientData) -} +#declare 142 { +# int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, +# CompileHookProc *hookProc, ClientData clientData) +#} declare 143 { int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr) diff --git a/generic/tclInt.h b/generic/tclInt.h index b89b816..70956f2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -19,6 +19,8 @@ #ifndef _TCLINT #define _TCLINT +#include "tclInt.h" + /* * Some numerics configuration options. */ @@ -1207,75 +1209,6 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, #define TCL_TSD_INIT(keyPtr) \ (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) -/* - *---------------------------------------------------------------- - * Data structures related to bytecode compilation and execution. These are - * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. - *---------------------------------------------------------------- - */ - -/* - * Forward declaration to prevent errors when the forward references to - * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc - * declared below. - */ - -struct CompileEnv; - -/* - * The type of procedures called by the Tcl bytecode compiler to compile - * commands. Pointers to these procedures are kept in the Command structure - * describing each command. The integer value returned by a CompileProc must - * be one of the following: - * - * TCL_OK Compilation completed normally. - * TCL_ERROR Compilation could not be completed. This can be just a - * judgment by the CompileProc that the command is too - * complex to compile effectively, or it can indicate - * that in the current state of the interp, the command - * would raise an error. The bytecode compiler will not - * do any error reporting at compiler time. Error - * reporting is deferred until the actual runtime, - * because by then changes in the interp state may allow - * the command to be successfully evaluated. - * TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the - * sake of old code only. - */ - -#define TCL_OUT_LINE_COMPILE TCL_ERROR - -typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, - struct Command *cmdPtr, struct CompileEnv *compEnvPtr); - -/* - * The type of procedure called from the compilation hook point in - * SetByteCodeFromAny. - */ - -typedef int (CompileHookProc)(Tcl_Interp *interp, - struct CompileEnv *compEnvPtr, ClientData clientData); - -/* - * The data structure for a (linked list of) execution stacks. - */ - -typedef struct ExecStack { - struct ExecStack *prevPtr; - struct ExecStack *nextPtr; - Tcl_Obj **markerPtr; - Tcl_Obj **endPtr; - Tcl_Obj **tosPtr; - Tcl_Obj *stackWords[1]; -} ExecStack; - -/* - * The data structure defining the execution environment for ByteCode's. - * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation - * stack that holds command operands and results. The stack grows towards - * increasing addresses. The member stackPtr points to the stackItems of the - * currently active execution stack. - */ - typedef struct CorContext { struct CallFrame *framePtr; struct CallFrame *varFramePtr; @@ -1301,21 +1234,28 @@ typedef struct CoroutineData { * means "any" */ } CoroutineData; +#define COR_IS_SUSPENDED(corPtr) \ + ((corPtr)->stackLevel == NULL) + +/* + * The data structure defining the execution environment for ByteCode's. + * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation + * stack that holds command operands and results. The stack grows towards + * increasing addresses. The member stackPtr points to the stackItems of the + * currently active execution stack. + */ + typedef struct ExecEnv { - ExecStack *execStackPtr; /* Points to the first item in the evaluation - * stack on the heap. */ - Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ struct Tcl_Interp *interp; struct NRE_callback *callbackPtr; /* Top callback in NRE's stack. */ - struct NRE_stack *NRStack; struct CoroutineData *corPtr; int rewind; + Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */ + struct ExecStack *execStackPtr; /* Points to the first item in the evaluation + * stack on the heap. */ } ExecEnv; -#define COR_IS_SUSPENDED(corPtr) \ - ((corPtr)->stackLevel == NULL) - /* * The definitions for the LiteralTable and LiteralEntry structures. Each * interpreter contains a LiteralTable. It is used to reduce the storage @@ -1366,48 +1306,13 @@ typedef struct LiteralTable { } LiteralTable; /* - * The following structure defines for each Tcl interpreter various - * statistics-related information about the bytecode compiler and - * interpreter's operation in that interpreter. - */ - -#ifdef TCL_COMPILE_STATS -typedef struct ByteCodeStats { - long numExecutions; /* Number of ByteCodes executed. */ - long numCompilations; /* Number of ByteCodes created. */ - long numByteCodesFreed; /* Number of ByteCodes destroyed. */ - long instructionCount[256]; /* Number of times each instruction was - * executed. */ - - double totalSrcBytes; /* Total source bytes ever compiled. */ - double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ - double currentSrcBytes; /* Src bytes for all current ByteCodes. */ - double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ - - long srcCount[32]; /* Source size distribution: # of srcs of - * size [2**(n-1)..2**n), n in [0..32). */ - long byteCodeCount[32]; /* ByteCode size distribution. */ - long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ - - double currentInstBytes; /* Instruction bytes-current ByteCodes. */ - double currentLitBytes; /* Current literal bytes. */ - double currentExceptBytes; /* Current exception table bytes. */ - double currentAuxBytes; /* Current auxiliary information bytes. */ - double currentCmdMapBytes; /* Current src<->code map bytes. */ - - long numLiteralsCreated; /* Total literal objects ever compiled. */ - double totalLitStringBytes; /* Total string bytes in all literals. */ - double currentLitStringBytes; - /* String bytes in current literals. */ - long literalCount[32]; /* Distribution of literal string sizes. */ -} ByteCodeStats; -#endif /* TCL_COMPILE_STATS */ - -/* * Structure used in implementation of those core ensembles which are * partially compiled. Used as an array of these, with a terminating field * whose 'name' is NULL. */ +struct CompileEnv; +typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, + struct Command *cmdPtr, struct CompileEnv *compEnvPtr); typedef struct { const char *name; /* The name of the subcommand. */ @@ -1916,7 +1821,6 @@ typedef struct Interp { * (asyncCancelMsg not NULL), takes precedence * over the default error messages returned by * a script cancellation operation. */ - #ifdef TCL_COMPILE_STATS /* * Statistical information about the bytecode compiler and interpreter's @@ -2900,7 +2804,6 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void); MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif -MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); @@ -2973,9 +2876,6 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, int pathc, Tcl_Obj *const pathv[]); -MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); /* Assemble command function */ MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, @@ -4527,6 +4427,51 @@ typedef struct NRE_callback { #define Tcl_Free(ptr) TclpFree(ptr) #endif +/* + * ADDENDA + */ + +/* + * The following structure defines for each Tcl interpreter various + * statistics-related information about the bytecode compiler and + * interpreter's operation in that interpreter. + */ + +#ifdef TCL_COMPILE_STATS +typedef struct ByteCodeStats { + long numExecutions; /* Number of ByteCodes executed. */ + long numCompilations; /* Number of ByteCodes created. */ + long numByteCodesFreed; /* Number of ByteCodes destroyed. */ + long instructionCount[256]; /* Number of times each instruction was + * executed. */ + + double totalSrcBytes; /* Total source bytes ever compiled. */ + double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ + double currentSrcBytes; /* Src bytes for all current ByteCodes. */ + double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ + + long srcCount[32]; /* Source size distribution: # of srcs of + * size [2**(n-1)..2**n), n in [0..32). */ + long byteCodeCount[32]; /* ByteCode size distribution. */ + long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ + + double currentInstBytes; /* Instruction bytes-current ByteCodes. */ + double currentLitBytes; /* Current literal bytes. */ + double currentExceptBytes; /* Current exception table bytes. */ + double currentAuxBytes; /* Current auxiliary information bytes. */ + double currentCmdMapBytes; /* Current src<->code map bytes. */ + + long numLiteralsCreated; /* Total literal objects ever compiled. */ + double totalLitStringBytes; /* Total string bytes in all literals. */ + double currentLitStringBytes; + /* String bytes in current literals. */ + long literalCount[32]; /* Distribution of literal string sizes. */ +} ByteCodeStats; +#endif /* TCL_COMPILE_STATS */ + +MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; +MODULE_SCOPE void TclForceBodyNS(Tcl_Obj *bodyPtr, Namespace *nsPtr); + #endif /* _TCLINT */ /* diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 77dd9c6..98841d8 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -359,10 +359,7 @@ EXTERN CONST84_RETURN char * TclGetEnv(const char *name, /* 141 */ EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); -/* 142 */ -EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr, CompileHookProc *hookProc, - ClientData clientData); +/* Slot 142 is reserved */ /* 143 */ EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); @@ -749,7 +746,7 @@ typedef struct TclIntStubs { void (*reserved139)(void); void (*reserved140)(void); CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ - int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ + void (*reserved142)(void); int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ @@ -1101,8 +1098,7 @@ extern const TclIntStubs *tclIntStubsPtr; /* Slot 140 is reserved */ #define TclpGetCwd \ (tclIntStubsPtr->tclpGetCwd) /* 141 */ -#define TclSetByteCodeFromAny \ - (tclIntStubsPtr->tclSetByteCodeFromAny) /* 142 */ +/* Slot 142 is reserved */ #define TclAddLiteralObj \ (tclIntStubsPtr->tclAddLiteralObj) /* 143 */ #define TclHideLiteral \ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 441ea91..16ce2ab 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -14,8 +14,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" -#include "tclCompile.h" +#include "tclEngineInt.h" /* * When there are this many entries per bucket, on average, rebuild a diff --git a/generic/tclNRE.h b/generic/tclNRE.h index d740105..38aa301 100644 --- a/generic/tclNRE.h +++ b/generic/tclNRE.h @@ -3,16 +3,6 @@ * ********************************************** */ -#define NRE_STACK_DEBUG 0 -#define NRE_STACK_SIZE 100 - - -/* - * This is the main data struct for representing NR commands. It is designed - * to fit in sizeof(Tcl_Obj) in order to exploit the fastest memory allocator - * available. - */ - /* * Inline versions of Tcl_NRAddCallback and friends */ @@ -35,8 +25,6 @@ cbPtr->data[3] = (ClientData)(data3); \ } while (0) -#if NRE_STACK_DEBUG - typedef struct NRE_callback { Tcl_NRPostProc *procPtr; ClientData data[4]; @@ -61,40 +49,3 @@ typedef struct NRE_callback { #define NEXT_CB(ptr) (ptr)->nextPtr -#else /* not debugging the NRE stack */ - -typedef struct NRE_callback { - Tcl_NRPostProc *procPtr; - ClientData data[4]; -} NRE_callback; - -typedef struct NRE_stack { - struct NRE_callback items[NRE_STACK_SIZE]; - struct NRE_stack *next; -} NRE_stack; - -#define POP_CB(interp, cbPtr) \ - (cbPtr) = TOP_CB(interp)-- - -#define ALLOC_CB(interp, cbPtr) \ - do { \ - ExecEnv *eePtr = ((Interp *) interp)->execEnvPtr; \ - NRE_stack *this = eePtr->NRStack; \ - \ - if (eePtr->callbackPtr && \ - (eePtr->callbackPtr < &this->items[NRE_STACK_SIZE-1])) { \ - (cbPtr) = ++eePtr->callbackPtr; \ - } else { \ - (cbPtr) = TclNewCallback(interp); \ - } \ - } while (0) - -#define FREE_CB(interp, cbPtr) - -#define NEXT_CB(ptr) TclNextCallback(ptr) - -MODULE_SCOPE NRE_callback *TclNewCallback(Tcl_Interp *interp); -MODULE_SCOPE NRE_callback *TclPopCallback(Tcl_Interp *interp); -MODULE_SCOPE NRE_callback *TclNextCallback(NRE_callback *ptr); - -#endif diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 7604026..7c509e0 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -24,7 +24,6 @@ */ #include "tclInt.h" -#include "tclCompile.h" /* for TclLogCommandInfo visibility */ /* * Thread-local storage used to avoid having a global lock on data that is not diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 628090f..03d19b8 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -14,7 +14,6 @@ #endif #include "tclInt.h" #include "tclOOInt.h" -#include "tclCompile.h" /* * Structure used to contain all the information needed about a call frame @@ -713,12 +712,8 @@ PushMethodCallFrame( * alternative is *so* slow... */ - if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = - pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr; + TclForceBodyNS(pmPtr->procPtr->bodyPtr, nsPtr); - codePtr->nsPtr = nsPtr; - } result = TclProcCompileProc(interp, pmPtr->procPtr, pmPtr->procPtr->bodyPtr, nsPtr, "body of method", namePtr); if (result != TCL_OK) { diff --git a/generic/tclProc.c b/generic/tclProc.c index cecc1a8..2cc926b 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -14,7 +14,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclEngine.h" #include "tclOOInt.h" /* @@ -2571,235 +2571,6 @@ MakeLambdaError( } /* - *---------------------------------------------------------------------- - * - * Tcl_DisassembleObjCmd -- - * - * Implementation of the "::tcl::unsupported::disassemble" command. This - * command is not documented, but will disassemble procedures, lambda - * terms and general scripts. Note that will compile terms if necessary - * in order to disassemble them. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_DisassembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const types[] = { - "lambda", "method", "objmethod", "proc", "script", NULL - }; - enum Types { - DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, - DISAS_SCRIPT - }; - int idx, result; - Tcl_Obj *codeObjPtr = NULL; - Proc *procPtr = NULL; - Tcl_HashEntry *hPtr; - Object *oPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "type ..."); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ - return TCL_ERROR; - } - - switch ((enum Types) idx) { - case DISAS_LAMBDA: { - Command cmd; - Tcl_Obj *nsObjPtr; - Tcl_Namespace *nsPtr; - - /* - * Compile (if uncompiled) and disassemble a lambda term. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); - return TCL_ERROR; - } - if (objv[2]->typePtr == &lambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = SetLambdaFromAny(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - - memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - cmd.nsPtr = (Namespace *) nsPtr; - procPtr->cmdPtr = &cmd; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - } - case DISAS_PROC: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procName"); - return TCL_ERROR; - } - - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - /* - * Compile (if uncompiled) and disassemble a procedure. - */ - - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - case DISAS_SCRIPT: - /* - * Compile and disassemble a script. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script"); - return TCL_ERROR; - } - if (objv[2]->typePtr != &tclByteCodeType) { - if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ - return TCL_ERROR; - } - } - codeObjPtr = objv[2]; - break; - - case DISAS_CLASS_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of a class method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); - goto methodBody; - case DISAS_OBJECT_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of an instance method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->methodsPtr == NULL) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); - - /* - * Compile (if necessary) and disassemble a method body. - */ - - methodBody: - if (hPtr == NULL) { - unknownMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[3]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "body not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); - return TCL_ERROR; - } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of method", - TclGetString(objv[3])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - default: - CLANG_ASSERT(0); - } - - /* - * Do the actual disassembly. - */ - - if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not disassemble prebuilt bytecode", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2ec064f..376f8f9 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -332,7 +332,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 139 */ 0, /* 140 */ TclpGetCwd, /* 141 */ - TclSetByteCodeFromAny, /* 142 */ + 0, /* 142 */ TclAddLiteralObj, /* 143 */ TclHideLiteral, /* 144 */ TclGetAuxDataType, /* 145 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index da6245a..0e95368 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -20,7 +20,7 @@ # define USE_TCL_STUBS #endif #include -#include "tclInt.h" +#include "tclEngineInt.h" #include "tclOO.h" #include #include "tclNRE.h" diff --git a/tests/compile.test b/tests/compile.test index 4d91940..384f20d 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -624,90 +624,6 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup interp delete $i } -result substituted -# This tests the supported parts of the unsupported [disassemble] command. It -# does not check the format of disassembled bytecode though; that's liable to -# change without warning. - -test compile-18.1 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble -} -match glob -result {wrong # args: should be "*"} -test compile-18.2 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble ? -} -match glob -result {bad type "?": must be *} -test compile-18.3 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble lambda -} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} -test compile-18.4 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble lambda \{ -} -result "can't interpret \"\{\" as a lambda expression" -test compile-18.5 {disassembler - basics} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble lambda {{} {}} -} -match glob -result * -test compile-18.6 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble proc -} -match glob -result {wrong # args: should be "* proc procName"} -test compile-18.7 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble proc nosuchproc -} -result {"nosuchproc" isn't a procedure} -test compile-18.8 {disassembler - basics} -setup { - proc chewonthis {} {} -} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble proc chewonthis -} -cleanup { - rename chewonthis {} -} -match glob -result * -test compile-18.9 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble script -} -match glob -result {wrong # args: should be "* script script"} -test compile-18.10 {disassembler - basics} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble script {} -} -match glob -result * -test compile-18.11 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble method -} -match glob -result {wrong # args: should be "* method className methodName"} -test compile-18.12 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble method nosuchclass foo -} -result {nosuchclass does not refer to an object} -test compile-18.13 {disassembler - basics} -returnCodes error -setup { - oo::object create justanobject -} -body { - tcl::unsupported::disassemble method justanobject foo -} -cleanup { - justanobject destroy -} -result {"justanobject" is not a class} -test compile-18.14 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble method oo::object nosuchmethod -} -result {unknown method "nosuchmethod"} -test compile-18.15 {disassembler - basics} -setup { - oo::class create foo {method bar {} {}} -} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble method foo bar -} -cleanup { - foo destroy -} -match glob -result * -test compile-18.16 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble objmethod -} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} -test compile-18.17 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble objmethod nosuchobject foo -} -result {nosuchobject does not refer to an object} -test compile-18.18 {disassembler - basics} -returnCodes error -body { - tcl::unsupported::disassemble objmethod oo::object nosuchmethod -} -result {unknown method "nosuchmethod"} -test compile-18.19 {disassembler - basics} -setup { - oo::object create foo - oo::objdefine foo {method bar {} {}} -} -body { - # Allow any string: the result format is not defined anywhere! - tcl::unsupported::disassemble objmethod foo bar -} -cleanup { - foo destroy -} -match glob -result * -# TODO sometime - check that bytecode from tbcload is *not* disassembled. # cleanup catch {rename p ""} diff --git a/unix/Makefile.in b/unix/Makefile.in index cc7f42f..b38cd12 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -294,7 +294,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o tclClock.o \ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclCompCmds.o tclCompCmdsSZ.o \ tclCompExpr.o tclCompile.o tclConfig.o tclDate.o tclDictObj.o \ - tclEncoding.o tclEnsemble.o \ + tclEncoding.o tclEnsemble.o tclCompEnsemble.o\ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ @@ -403,6 +403,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclDictObj.c \ $(GENERIC_DIR)/tclEncoding.c \ $(GENERIC_DIR)/tclEnsemble.c \ + $(GENERIC_DIR)/tclCompEnsemble.c \ $(GENERIC_DIR)/tclEnv.c \ $(GENERIC_DIR)/tclEvent.c \ $(GENERIC_DIR)/tclExecute.c \ @@ -996,12 +997,13 @@ xtTestInit.o: $(UNIX_DIR)/tclAppInit.c ${TCL_EXE} REGHDRS=$(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ $(GENERIC_DIR)/regcustom.h TCLREHDRS=$(GENERIC_DIR)/tclRegexp.h -COMPILEHDR=$(GENERIC_DIR)/tclCompile.h +ENGINEHDR=$(GENERIC_DIR)/tclEngine.h +ENGINEINTHDR=$(ENGINEHDR) $(GENERIC_DIR)/tclEngineInt.h +NREHDR=$(GENERIC_DIR)/tclNRE.h FSHDR=$(GENERIC_DIR)/tclFileSystem.h IOHDR=$(GENERIC_DIR)/tclIO.h MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h PARSEHDR=$(GENERIC_DIR)/tclParse.h -NREHDR=$(GENERIC_DIR)/tclNRE.h regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \ $(GENERIC_DIR)/regc_color.c $(GENERIC_DIR)/regc_locale.c \ @@ -1023,13 +1025,13 @@ tclAppInit.o: $(UNIX_DIR)/tclAppInit.c tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c -tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) +tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(ENGINEINTHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c tclAsync.o: $(GENERIC_DIR)/tclAsync.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c -tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) +tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(ENGINEHDR) $(MATHHDRS) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c tclBinary.o: $(GENERIC_DIR)/tclBinary.c @@ -1053,16 +1055,16 @@ tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) tclDate.o: $(GENERIC_DIR)/tclDate.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c -tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) +tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(ENGINEINTHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c -tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) +tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(ENGINEINTHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsSZ.c -tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(COMPILEHDR) +tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(ENGINEINTHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompExpr.c -tclCompile.o: $(GENERIC_DIR)/tclCompile.c $(COMPILEHDR) +tclCompile.o: $(GENERIC_DIR)/tclCompile.c $(ENGINEINTHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompile.c tclConfig.o: $(GENERIC_DIR)/tclConfig.c @@ -1074,16 +1076,19 @@ tclDictObj.o: $(GENERIC_DIR)/tclDictObj.c $(MATHHDRS) tclEncoding.o: $(GENERIC_DIR)/tclEncoding.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEncoding.c -tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(COMPILEHDR) +tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnsemble.c +tclCompEnsemble.o: $(GENERIC_DIR)/tclCompEnsemble.c $(ENGINEINTHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompEnsemble.c + tclEnv.o: $(GENERIC_DIR)/tclEnv.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c tclEvent.o: $(GENERIC_DIR)/tclEvent.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEvent.c -tclExecute.o: $(GENERIC_DIR)/tclExecute.c $(COMPILEHDR) $(MATHHDRS) +tclExecute.o: $(GENERIC_DIR)/tclExecute.c $(ENGINEINTHDR) $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclExecute.c tclFCmd.o: $(GENERIC_DIR)/tclFCmd.c @@ -1134,10 +1139,10 @@ tclLink.o: $(GENERIC_DIR)/tclLink.c tclListObj.o: $(GENERIC_DIR)/tclListObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c -tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR) +tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(ENGINEINTHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c -tclObj.o: $(GENERIC_DIR)/tclObj.c $(COMPILEHDR) $(MATHHDRS) +tclObj.o: $(GENERIC_DIR)/tclObj.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclObj.c tclLoad.o: $(GENERIC_DIR)/tclLoad.c @@ -1170,7 +1175,7 @@ tclLoadShl.o: $(UNIX_DIR)/tclLoadShl.c tclMain.o: $(GENERIC_DIR)/tclMain.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMain.c -tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR) +tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c tclNotify.o: $(GENERIC_DIR)/tclNotify.c @@ -1242,7 +1247,7 @@ tclPosixStr.o: $(GENERIC_DIR)/tclPosixStr.c tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c -tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) +tclProc.o: $(GENERIC_DIR)/tclProc.c $(ENGINEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS) @@ -1281,7 +1286,7 @@ tclVar.o: $(GENERIC_DIR)/tclVar.c tclZlib.o: $(GENERIC_DIR)/tclZlib.c $(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c -tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(NREHDR) +tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(NREHDR) $(ENGINEINTHDR) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) -- cgit v0.12