From 42b09bbed6f6321e1ef37e138d47cb0a508d3f93 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 31 Dec 2012 02:39:40 +0000 Subject: Working towards more efficient treatment of non-bytecoded ensemble subcommands. --- generic/tclCompile.c | 5 ++++ generic/tclCompile.h | 4 ++- generic/tclEnsemble.c | 81 +++++++++++++++++++++++++++++++++++++++++++++++---- generic/tclExecute.c | 57 ++++++++++++++++++++++++++++++++++++ 4 files changed, 141 insertions(+), 6 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 309682d..c052531 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -529,6 +529,11 @@ InstructionDesc const tclInstructionTable[] = { /* Forces the variable indexed by opnd to be an array. Does not touch * the stack. */ + {"invokeReplace", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Invoke command named objv[0], replacing the first two words with + * the word at the top of the stack; + * = */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3302f9b..4d8ed65 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -711,8 +711,10 @@ typedef struct ByteCode { #define INST_ARRAY_MAKE_STK 161 #define INST_ARRAY_MAKE_IMM 162 +#define INST_INVOKE_REPLACE 163 + /* The last opcode */ -#define LAST_INST_OPCODE 162 +#define LAST_INST_OPCODE 163 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index b76c603..8f0d4fe 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -35,6 +35,14 @@ 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, Tcl_Token *tokenPtr, + int len, Tcl_Obj **elems, Command *cmdPtr, + CompileEnv *envPtr); +static int CompileToInvokedCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Tcl_Token *tokenPtr, + int len, Tcl_Obj **elems, Command *cmdPtr, + CompileEnv *envPtr); /* * The lists of subcommands and options for the [namespace ensemble] command. @@ -2734,7 +2742,6 @@ TclCompileEnsemble( Tcl_Token *tokenPtr; Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; Tcl_Command ensemble = (Tcl_Command) cmdPtr; - Tcl_Parse synthetic; int len, result, flags = 0, i; unsigned numBytes; const char *word; @@ -2920,7 +2927,7 @@ TclCompileEnsemble( if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) { return TCL_ERROR; } - if (len > 1 && Tcl_IsSafe(interp)) { + if (len > 1 || Tcl_IsSafe(interp)) { return TCL_ERROR; } targetCmdObj = elems[0]; @@ -2928,7 +2935,7 @@ TclCompileEnsemble( Tcl_IncrRefCount(targetCmdObj); cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); - if (cmdPtr == NULL || cmdPtr->compileProc == NULL + if (cmdPtr == NULL || cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION || cmdPtr->flags * CMD_HAS_EXEC_TRACES || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { @@ -2942,10 +2949,39 @@ TclCompileEnsemble( /* * Now we've done the mapping process, can now actually try to compile. - * We do this by handing off to the subcommand's actual compiler. But to - * do that, we have to perform some trickery to rewrite the arguments. + * 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. */ + if (cmdPtr->compileProc != NULL && + CompileToCompiledCommand(interp, parsePtr, tokenPtr, + len, elems, cmdPtr, envPtr) == TCL_OK) { + return TCL_OK; + } + return CompileToInvokedCommand(interp, parsePtr, tokenPtr, + len, elems, cmdPtr, envPtr); +} + +/* + * 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, + Tcl_Token *tokenPtr, + int len, + Tcl_Obj **elems, + Command *cmdPtr, + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Parse synthetic; + int result, i; + TclParseInit(interp, NULL, 0, &synthetic); synthetic.numWords = parsePtr->numWords - 2 + len; TclGrowParseTokenArray(&synthetic, 2*len); @@ -3001,6 +3037,41 @@ TclCompileEnsemble( Tcl_FreeParse(&synthetic); return result; } + +static int +CompileToInvokedCommand( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Tcl_Token *tokenPtr, + int len, + Tcl_Obj **elems, + Command *cmdPtr, + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Obj *objPtr = Tcl_NewObj(); + char *bytes; + int length, i, literal; + + if (len != 1) { + return TCL_ERROR; + } + + // TODO: Generate magic (with new instruction) for setting up the ensemble + // rewriting... + + for (i=0,tokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); + tokenPtr = TokenAfter(tokenPtr); + } + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + bytes = Tcl_GetStringFromObj(objPtr, &length); + literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); + TclDecrRefCount(objPtr); + TclEmitPush(literal, envPtr); + TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); + TclAdjustStackDepth(-1, envPtr); + return TCL_OK; +} /* * Local Variables: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2b5f713..3fab3cc 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2972,6 +2972,63 @@ TEBCresume( Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); #endif + case INST_INVOKE_REPLACE: + objc = TclGetUInt4AtPtr(pc+1); + objPtr = POP_OBJECT(); + objv = &OBJ_AT_DEPTH(objc-1); + cleanup = objc; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call (implementation %s) ", + objc, O2S(objPtr))); + } else { + fprintf(stdout, + "%d: (%u) invoking (using implementation %s) ", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + O2S(objPtr)); + } + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + { + Tcl_Obj *copyPtr = Tcl_NewListObj(objc - 1, NULL); + register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj **copyObjv = &listRepPtr->elements; + int i; + + listRepPtr->elemCount = objc - 1; + copyObjv[0] = objPtr; + memcpy(copyObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc - 2)); + for (i=1 ; idata.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 2; + iPtr->ensembleRewrite.numInsertedObjs = 1; + DECACHE_STACK_INFO(); + pc += 5; + TEBC_YIELD(); + TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); + iPtr->evalFlags |= TCL_EVAL_REDIRECT; + return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN); + /* * ----------------------------------------------------------------- * Start of INST_LOAD instructions. -- cgit v0.12 From 92d844b187a1a7cd56fc2955b50aa461cd9e0086 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Jan 2013 15:10:00 +0000 Subject: Passing more tests. --- generic/tclCompile.c | 2 +- generic/tclEnsemble.c | 119 +++++++++++++++++++++++++++++++++----------------- generic/tclExecute.c | 24 ++++++---- 3 files changed, 94 insertions(+), 51 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c052531..45a74d7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -529,7 +529,7 @@ InstructionDesc const tclInstructionTable[] = { /* Forces the variable indexed by opnd to be an array. Does not touch * the stack. */ - {"invokeReplace", 5, INT_MIN, 1, {OPERAND_UINT4}}, + {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}}, /* Invoke command named objv[0], replacing the first two words with * the word at the top of the stack; * = */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 8f0d4fe..8cd9717 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -39,9 +39,9 @@ static int CompileToCompiledCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Token *tokenPtr, int len, Tcl_Obj **elems, Command *cmdPtr, CompileEnv *envPtr); -static int CompileToInvokedCommand(Tcl_Interp *interp, +static void CompileToInvokedCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Token *tokenPtr, - int len, Tcl_Obj **elems, Command *cmdPtr, + Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr); /* @@ -2739,24 +2739,24 @@ TclCompileEnsemble( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; + 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; - int len, result, flags = 0, i; + int len, result, flags = 0, i, depth = 1; unsigned numBytes; const char *word; - if (parsePtr->numWords < 2) { - return TCL_ERROR; + Tcl_IncrRefCount(replaced); + if (parsePtr->numWords < depth + 1) { + goto failed; } - - tokenPtr = TokenAfter(parsePtr->tokenPtr); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * Too hard. */ - return TCL_ERROR; + goto failed; } word = tokenPtr[1].start; @@ -2775,7 +2775,7 @@ TclCompileEnsemble( * to proceed. */ - return TCL_ERROR; + goto failed; } /* @@ -2789,7 +2789,7 @@ TclCompileEnsemble( * Figuring out how to compile this has become too much. Bail out. */ - return TCL_ERROR; + goto failed; } /* @@ -2812,7 +2812,7 @@ TclCompileEnsemble( Tcl_Obj *matchObj = NULL; if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { - return TCL_ERROR; + goto failed; } for (i=0 ; i 1 || Tcl_IsSafe(interp)) { - return TCL_ERROR; + goto failed; } targetCmdObj = elems[0]; @@ -2944,7 +2950,12 @@ TclCompileEnsemble( * Cannot compile. */ - return TCL_ERROR; + goto failed; + } + depth++; + + if (cmdPtr->compileProc == TclCompileEnsemble) { + // TODO: Back round the loop to parse the next level down. } /* @@ -2957,10 +2968,23 @@ TclCompileEnsemble( if (cmdPtr->compileProc != NULL && CompileToCompiledCommand(interp, parsePtr, tokenPtr, len, elems, cmdPtr, envPtr) == TCL_OK) { - return TCL_OK; + goto succeeded; + } else if (len != 1) { + goto failed; } - return CompileToInvokedCommand(interp, parsePtr, tokenPtr, - len, elems, cmdPtr, envPtr); + CompileToInvokedCommand(interp, parsePtr, tokenPtr, replaced, + cmdPtr, envPtr); + succeeded: + if (replaced != NULL) { + Tcl_DecrRefCount(replaced); + } + return TCL_OK; + + failed: + if (replaced != NULL) { + Tcl_DecrRefCount(replaced); + } + return TCL_ERROR; } /* @@ -3038,39 +3062,52 @@ CompileToCompiledCommand( return result; } -static int +static void CompileToInvokedCommand( Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Token *tokenPtr, - int len, - Tcl_Obj **elems, + Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Token *tokPtr; + Tcl_Obj *objPtr, **words; char *bytes; - int length, i, literal; - - if (len != 1) { - return TCL_ERROR; - } + int length, i, numWords; // TODO: Generate magic (with new instruction) for setting up the ensemble // rewriting... - for (i=0,tokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); - tokenPtr = TokenAfter(tokenPtr); + Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); + for (i=0,tokPtr=parsePtr->tokenPtr ; inumWords ; i++) { + if (i > 0 && i-1 < numWords) { + bytes = Tcl_GetStringFromObj(words[i-1], &length); + PushLiteral(envPtr, bytes, length); + } else { + TclCompileTokens(interp, tokPtr+1, tokPtr->numComponents, envPtr); + } + 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); - literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); + PushLiteral(envPtr, bytes, length); TclDecrRefCount(objPtr); - TclEmitPush(literal, envPtr); + + /* + * Do the replacing dispatch. + */ + TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); - TclAdjustStackDepth(-1, envPtr); - return TCL_OK; + TclEmitInt1(numWords+1, envPtr); + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */ } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3fab3cc..b0da17d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2974,6 +2974,7 @@ TEBCresume( case INST_INVOKE_REPLACE: objc = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc+5); objPtr = POP_OBJECT(); objv = &OBJ_AT_DEPTH(objc-1); cleanup = objc; @@ -2983,8 +2984,7 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call (implementation %s) ", - objc, O2S(objPtr))); + TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, "%d: (%u) invoking (using implementation %s) ", @@ -2992,7 +2992,13 @@ TEBCresume( O2S(objPtr)); } for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); + if (i < opnd) { + fprintf(stdout, "<"); + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, ">"); + } else { + TclPrintObject(stdout, objv[i], 15); + } fprintf(stdout, " "); } fprintf(stdout, "\n"); @@ -3000,15 +3006,15 @@ TEBCresume( } #endif /*TCL_COMPILE_DEBUG*/ { - Tcl_Obj *copyPtr = Tcl_NewListObj(objc - 1, NULL); + Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj **copyObjv = &listRepPtr->elements; int i; - listRepPtr->elemCount = objc - 1; + listRepPtr->elemCount = objc - opnd + 1; copyObjv[0] = objPtr; - memcpy(copyObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc - 2)); - for (i=1 ; icodeStart); } iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 2; + iPtr->ensembleRewrite.numRemovedObjs = opnd; iPtr->ensembleRewrite.numInsertedObjs = 1; DECACHE_STACK_INFO(); - pc += 5; + pc += 6; TEBC_YIELD(); TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); iPtr->evalFlags |= TCL_EVAL_REDIRECT; -- cgit v0.12 From 810edde822b6b99b1dcc766be690db919e90e361 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 Jan 2013 18:33:27 +0000 Subject: All tests pass except one; not sure what's wrong there. --- generic/tclCompCmds.c | 8 +-- generic/tclEnsemble.c | 154 ++++++++++++++++++++++++++++++++------------------ tests/info.test | 26 ++++----- tests/nre.test | 26 +-------- 4 files changed, 118 insertions(+), 96 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 160fa3c..8fa191b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -5791,7 +5791,7 @@ TclCompileVariableCmd( */ valueTokenPtr = parsePtr->tokenPtr; - for (i=2; i<=numWords; i+=2) { + for (i=1; iextCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 +#define CompileWord(envPtr, tokenPtr, interp, word) \ + if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ + TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ + (tokenPtr)[1].size), (envPtr)); \ + } else { \ + if (mapPtr->loc[eclIndex].next) { \ + envPtr->line = mapPtr->loc[eclIndex].line[word]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ + } \ + TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ + (envPtr)); \ + } static inline Tcl_Obj * NewNsObj( @@ -2743,11 +2761,14 @@ TclCompileEnsemble( Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; Tcl_Obj *replaced = Tcl_NewObj(), *replacement; Tcl_Command ensemble = (Tcl_Command) cmdPtr; - int len, result, flags = 0, i, depth = 1; + 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); + checkNextWord: if (parsePtr->numWords < depth + 1) { goto failed; } @@ -2915,6 +2936,7 @@ TclCompileEnsemble( */ if (matched != 1) { + invokeAnyway = 1; goto failed; } } @@ -2933,29 +2955,33 @@ TclCompileEnsemble( if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) { goto failed; } - if (len > 1 || Tcl_IsSafe(interp)) { + if (len != 1) { goto failed; } targetCmdObj = elems[0]; + oldCmdPtr = cmdPtr; Tcl_IncrRefCount(targetCmdObj); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); + newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); - if (cmdPtr == NULL - || cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION - || cmdPtr->flags * CMD_HAS_EXEC_TRACES + if (newCmdPtr == NULL || Tcl_IsSafe(interp) + || newCmdPtr->nsPtr->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 failed; + goto cleanup; } + cmdPtr = newCmdPtr; depth++; if (cmdPtr->compileProc == TclCompileEnsemble) { - // TODO: Back round the loop to parse the next level down. + tokenPtr = TokenAfter(tokenPtr); + ensemble = (Tcl_Command) cmdPtr; + goto checkNextWord; } /* @@ -2965,26 +2991,44 @@ TclCompileEnsemble( * invoke at runtime. */ - if (cmdPtr->compileProc != NULL && - CompileToCompiledCommand(interp, parsePtr, tokenPtr, - len, elems, cmdPtr, envPtr) == TCL_OK) { - goto succeeded; - } else if (len != 1) { - goto failed; - } - CompileToInvokedCommand(interp, parsePtr, tokenPtr, replaced, - cmdPtr, envPtr); - succeeded: - if (replaced != NULL) { - Tcl_DecrRefCount(replaced); + invokeAnyway = 1; + if (cmdPtr->compileProc != NULL) { + if (CompileToCompiledCommand(interp, parsePtr, tokenPtr, depth, + cmdPtr, envPtr) == TCL_OK) { + ourResult = TCL_OK; + goto cleanup; + } } - return TCL_OK; + + /* + * 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 (len == 1 && 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: if (replaced != NULL) { Tcl_DecrRefCount(replaced); } - return TCL_ERROR; + return ourResult; } /* @@ -2998,46 +3042,44 @@ CompileToCompiledCommand( Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Token *tokenPtr, - int len, - Tcl_Obj **elems, + int depth, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Parse synthetic; + Tcl_Token *tokPtr; int result, i; TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - 2 + len; - TclGrowParseTokenArray(&synthetic, 2*len); - synthetic.numTokens = 2*len; + synthetic.numWords = parsePtr->numWords - depth + 1; + TclGrowParseTokenArray(&synthetic, 2); + synthetic.numTokens = 2; /* - * Now we have the space to work in, install something rewritten. Note - * that we are here praying for all our might that none of these words are - * a script; the error detection code will crash if that happens and there - * is nothing we can do to avoid it! + * Now we have the space to work in, install something rewritten. The + * first word will "officially" be the structured ensemble name. */ - for (i=0 ; itokenPtr[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; + tokPtr = parsePtr->tokenPtr; + for (i=0 ; istart-synthetic.tokenPtr[0].start)+tokPtr->size; + + synthetic.tokenPtr[0].size = sclen; + synthetic.tokenPtr[1].size = sclen; + tokPtr = TokenAfter(tokPtr); } /* * Copy over the real argument tokens. */ - for (i=len; itokenPtr ; inumWords ; i++) { - if (i > 0 && i-1 < numWords) { + if (i > 0 && i < numWords+1) { bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); } else { - TclCompileTokens(interp, tokPtr+1, tokPtr->numComponents, envPtr); + CompileWord(envPtr, tokPtr, interp, i); } tokPtr = TokenAfter(tokPtr); } @@ -3098,7 +3140,9 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); bytes = Tcl_GetStringFromObj(objPtr, &length); - PushLiteral(envPtr, bytes, length); + cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); + TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr); + TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); /* diff --git a/tests/info.test b/tests/info.test index 5078e11..ebc853a 100644 --- a/tests/info.test +++ b/tests/info.test @@ -692,31 +692,31 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body { ## # ### ### ### ######### ######### ######### ## info frame + ## Helper # For the more complex results we cut the file name down to remove path # dependencies, and we use only part of the first line of the reported # command. The latter is required because otherwise the whole test case may # appear in some results, but the result is part of the testcase. An infinite # string would be required to describe that. The cutting-down breaks this. + proc reduce {frame} { - set pos [lsearch -exact $frame cmd] - incr pos - set cmd [lindex $frame $pos] + set cmd [dict get $frame cmd] if {[regexp \n $cmd]} { - set first [string range [lindex [split $cmd \n] 0] 0 end-4] - set frame [lreplace $frame $pos $pos $first] + dict set frame cmd \ + [string range [lindex [split $cmd \n] 0] 0 end-4] } - set pos [lsearch -exact $frame file] - if {$pos >=0} { - incr pos - set tail [file tail [lindex $frame $pos]] - set frame [lreplace $frame $pos $pos $tail] + if {[dict exists $frame file]} { + dict set frame file \ + [file tail [dict get $frame file]] } - set frame + return $frame } + proc subinterp {} { interp create sub ; interp debug sub -frame 1; interp eval sub [list proc reduce [info args reduce] [info body reduce]] } + ## Helper # Generate a stacktrace from the current location to top. This code # not only depends on the exact location of things, but also on the @@ -1454,9 +1454,9 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body { test info-30.2 {bs+nl in literal words, namespace script} { namespace eval xxx { variable res \ - [reduce [info frame 0]];# line 1457 + [info frame 0];# line 1457 } - return $xxx::res + return [reduce $xxx::res] } {type source line 1457 file info.test cmd {info frame 0} level 0} test info-30.3 {bs+nl in literal words, namespace multi-word script} { diff --git a/tests/nre.test b/tests/nre.test index b8ef2e0..b5eb032 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -74,7 +74,6 @@ test nre-1.1 {self-recursive procs} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-1.2 {self-recursive lambdas} -setup { set a [list i [makebody {apply $::a $i}]] } -body { @@ -85,7 +84,6 @@ test nre-1.2 {self-recursive lambdas} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-1.3 {mutually recursive procs and lambdas} -setup { proc a i { apply $::b [incr i] @@ -164,8 +162,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 3 2 2} 0} - +} -result {{0 2 2 2} 0} test nre-5.2 {[namespace eval] is not recursive} -setup { namespace eval ::foo { setabs @@ -177,7 +174,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 3 2 2} 0} +} -result {{0 2 2 2} 0} test nre-6.1 {[uplevel] is not recursive} -setup { proc a i [makebody {uplevel 1 [list a $i]}] @@ -189,7 +186,6 @@ test nre-6.1 {[uplevel] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-6.2 {[uplevel] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "set x $i; a $i"}] @@ -211,7 +207,6 @@ test nre-7.1 {[catch] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 3 3 0} 0} - test nre-7.2 {[if] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "if 1 {a $i}"}] @@ -222,7 +217,6 @@ test nre-7.2 {[if] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.3 {[while] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}] @@ -233,7 +227,6 @@ test nre-7.3 {[while] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.4 {[for] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}] @@ -244,7 +237,6 @@ test nre-7.4 {[for] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.5 {[foreach] is not recursive} -setup { # # Enable once [foreach] is NR-enabled @@ -258,7 +250,6 @@ test nre-7.5 {[foreach] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 3 3 0} 0} - test nre-7.6 {[eval] is not recursive} -setup { proc a i [makebody {eval [list a $i]}] } -body { @@ -269,7 +260,6 @@ test nre-7.6 {[eval] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 1} 0} - test nre-7.7 {[eval] is not recursive} -setup { proc a i [makebody {eval "a $i"}] } -body { @@ -280,7 +270,6 @@ test nre-7.7 {[eval] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 1} 0} - test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { proc foo args {} foo @@ -295,18 +284,15 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { } -body { # if switching to plain eval is not nre aware, this will cause a "cannot # yield" error - list [bar] [bar] [bar] } -cleanup { rename bar {} rename foo {} } -result {1 2 3} - test nre-8.1 {nre and {*}} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the TEBCdataPtr. This crashes on failure. - proc inner {} { set long [lrepeat 1000000 1] list {*}$long @@ -321,21 +307,18 @@ test nre-8.2 {nre and {*}, [Bug 2415422]} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not # done properly. - proc nop {} {} proc crash {} { foreach val [list {*}[lrepeat 100000 x]] { nop } } - crash } -cleanup { rename nop {} rename crash {} } - # # Basic TclOO tests # @@ -351,7 +334,6 @@ test nre-oo.1 {really deep calls in oo - direct} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.2 {really deep calls in oo - call via [self]} -setup { oo::object create foo oo::objdefine foo method bar i [makebody {[self] bar $i}] @@ -363,7 +345,6 @@ test nre-oo.2 {really deep calls in oo - call via [self]} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.3 {really deep calls in oo - private calls} -setup { oo::object create foo oo::objdefine foo method bar i [makebody {my bar $i}] @@ -375,7 +356,6 @@ test nre-oo.3 {really deep calls in oo - private calls} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.4 {really deep calls in oo - overriding} -setup { oo::class create foo { method bar i [makebody {my bar $i}] @@ -392,7 +372,6 @@ test nre-oo.4 {really deep calls in oo - overriding} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.5 {really deep calls in oo - forwards} -setup { oo::object create foo set body [makebody {my boo $i}] @@ -409,7 +388,6 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup { testnrelevels } -result {{0 2 1 1} 0} - # # NASTY BUG found by tcllib's interp package # -- cgit v0.12 From e82d1f6be8957bb381a19b3663a3e0c34c1480b3 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 3 Jan 2013 00:37:29 +0000 Subject: Got the test suite passing cleanly. Excellent. --- generic/tclEnsemble.c | 95 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 60 insertions(+), 35 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 5bef6e8..d12ffe6 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -4,7 +4,7 @@ * Contains support for ensembles (see TIP#112), which provide simple * mechanism for creating composite commands on top of namespaces. * - * Copyright (c) 2005-2010 Donal K. Fellows. + * Copyright (c) 2005-2013 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -36,8 +36,8 @@ 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, Tcl_Token *tokenPtr, - int depth, Command *cmdPtr, CompileEnv *envPtr); + 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); @@ -92,18 +92,9 @@ const Tcl_ObjType tclEnsembleCmdType = { #define DefineLineInformation \ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -#define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ - } else { \ - if (mapPtr->loc[eclIndex].next) { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - } \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ - } +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] static inline Tcl_Obj * NewNsObj( @@ -2768,6 +2759,12 @@ TclCompileEnsemble( 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; @@ -2978,6 +2975,11 @@ TclCompileEnsemble( 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; @@ -2992,12 +2994,10 @@ TclCompileEnsemble( */ invokeAnyway = 1; - if (cmdPtr->compileProc != NULL) { - if (CompileToCompiledCommand(interp, parsePtr, tokenPtr, depth, - cmdPtr, envPtr) == TCL_OK) { - ourResult = TCL_OK; - goto cleanup; - } + if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, + envPtr) == TCL_OK) { + ourResult = TCL_OK; + goto cleanup; } /* @@ -3025,9 +3025,7 @@ TclCompileEnsemble( */ cleanup: - if (replaced != NULL) { - Tcl_DecrRefCount(replaced); - } + Tcl_DecrRefCount(replaced); return ourResult; } @@ -3041,15 +3039,18 @@ static int CompileToCompiledCommand( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Tcl_Token *tokenPtr, int depth, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Parse synthetic; - Tcl_Token *tokPtr; + Tcl_Token *tokenPtr; int result, i; + if (cmdPtr->compileProc == NULL) { + return TCL_ERROR; + } + TclParseInit(interp, NULL, 0, &synthetic); synthetic.numWords = parsePtr->numWords - depth + 1; TclGrowParseTokenArray(&synthetic, 2); @@ -3057,7 +3058,9 @@ CompileToCompiledCommand( /* * Now we have the space to work in, install something rewritten. The - * first word will "officially" be the structured ensemble name. + * 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; @@ -3066,13 +3069,13 @@ CompileToCompiledCommand( synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; synthetic.tokenPtr[1].numComponents = 0; - tokPtr = parsePtr->tokenPtr; - for (i=0 ; istart-synthetic.tokenPtr[0].start)+tokPtr->size; + for (i=0,tokenPtr=parsePtr->tokenPtr ; istart - synthetic.tokenPtr[0].start) + + tokenPtr->size; synthetic.tokenPtr[0].size = sclen; synthetic.tokenPtr[1].size = sclen; - tokPtr = TokenAfter(tokPtr); + tokenPtr = TokenAfter(tokenPtr); } /* @@ -3082,12 +3085,12 @@ CompileToCompiledCommand( for (i=1; inumComponents + 1; TclGrowParseTokenArray(&synthetic, toCopy); memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, sizeof(Tcl_Token) * toCopy); synthetic.numTokens += toCopy; + tokenPtr = TokenAfter(tokenPtr); } /* @@ -3104,6 +3107,11 @@ CompileToCompiledCommand( return result; } +/* + * How to compile a subcommand to a _replacing_ invoke of its implementation + * command. + */ + static void CompileToInvokedCommand( Tcl_Interp *interp, @@ -3118,16 +3126,33 @@ CompileToInvokedCommand( int length, i, numWords, cmdLit; DefineLineInformation; - // TODO: Generate magic (with new instruction) for setting up the ensemble - // rewriting... + /* + * 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); + + if (envPtr->clNext) { + TclContinuationsEnterDerived( + envPtr->literalArrayPtr[literal].objPtr, + tokPtr[1].start - envPtr->source, + mapPtr->loc[eclIndex].next[i]); + } + TclEmitPush(literal, envPtr); } else { - CompileWord(envPtr, tokPtr, interp, i); + if (envPtr->clNext) { + SetLineInformation(i); + } + CompileTokens(envPtr, tokPtr, interp); } tokPtr = TokenAfter(tokPtr); } -- cgit v0.12