From 0e6dbfcf9977281189ce5a639d1ea673a6a29eda Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 25 Jun 2013 14:19:39 +0000 Subject: Branch for rewriting TclCompileScript() and related routines, with the intent to generally simplify and make more readable, as well as find and eliminate duplication with ensemble machinery and improve mergeability to other branches. Work in Progress. Doesn't work at all right now. --- generic/tclCompile.c | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 8cb53f5..eafecbc 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1737,6 +1737,37 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ +#if 1 +static void +CompileCommandTokens( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + CompileEnv *envPtr) +{ + Tcl_Obj *cmdObj; + Tcl_Token *cmdTokenPtr = parsePtr->tokenPtr; + + + if (parsePtr->numWords == 0) { + return 0; + } + + if (!TclWordKnownAtCompileTime(cmdTokenPtr, cmdObj)) { + /* + * Command is not known until runtime substitution is complete. + * Emit instructions to perform that substitution. + */ + CompileTokens(interp, cmdTokenPtr, envPtr); + + } + + + + TclEmitOpcode(INST_POP, envPtr); + +} +#endif + void TclCompileScript( Tcl_Interp *interp, /* Used for error and status reporting. Also @@ -1748,6 +1779,98 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { +#if 1 + unsigned char *entryCodeNext = envPtr->codeNext; + const char *p; + int cmdLine, *clNext; + + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } + + /* + * Each iteration through the following loop compiles the next command + * from the script. + */ + + p = script; + cmdLine = envPtr->line; + clNext = envPtr->clNext; + while (numBytes > 0) { + Tcl_Parse parse; + const char *next; + + /* TODO: can we relocate this to happen less frequently? */ + Tcl_ResetResult(interp); + if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { + /* + * Compile bytecodes to report the parse error at runtime. + */ + + Tcl_LogCommandInfo(interp, script, parse.commandStart, + parse.term - parse.commandStart); + TclCompileSyntaxError(interp, envPtr); + break; + } + + /* + * TIP #280: Count newlines before the command start. + * (See test info-30.33). + */ + + TclAdvanceLines(&cmdLine, p, parse.commandStart); + TclAdvanceContinuations(&cmdLine, &clNext, + parse.commandStart - envPtr->source); + +#ifdef TCL_COMPILE_DEBUG + /* + * If tracing, print a line for each top level command compiled. + */ + + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(parse.term - parse.commandStart, 55)); + fprintf(stdout, "\n"); + } +#endif + + CompileCommandTokens(interp, &parse, envPtr); + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + numBytes -= next - p; + p = next; + + /* + * TIP #280: Track lines in the just compiled command. + */ + + TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); + Tcl_FreeParse(&parse); + } + + /* + * TIP #280: Bring the line counts in the CompEnv up to date. + * See tests info-30.33,34,35 . + */ + + envPtr->line = cmdLine; + envPtr->clNext = clNext; + + /* + * If the source script yielded no instructions (e.g., if it was empty), + * push an empty string as the command's result. + */ + + if (envPtr->codeNext == entryCodeNext) { + PushStringLiteral(envPtr, ""); + } +#else int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in * the command location table. Initialized to @@ -2192,6 +2315,7 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); } +#endif } /* -- cgit v0.12 From 9b8f81698635aaedfb4f36d41d4d8779e754ce11 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 25 Jun 2013 20:22:31 +0000 Subject: Nearly functional now, but leaky and not yet as tidy as I'm hoping for. --- generic/tclCompile.c | 301 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 289 insertions(+), 12 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 01320cf..2c6af46 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1744,27 +1744,295 @@ CompileCommandTokens( Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Obj *cmdObj; - Tcl_Token *cmdTokenPtr = parsePtr->tokenPtr; - + Interp *iPtr = (Interp *) interp; + Tcl_Obj *cmdObj = Tcl_NewObj(); + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + Command *cmdPtr = NULL; + int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int *wlines, wlineat; - if (parsePtr->numWords == 0) { - return 0; + if (numWords == 0) { + return; + } + + for (wordIdx = 0; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + expand = 1; + break; + } } - if (!TclWordKnownAtCompileTime(cmdTokenPtr, cmdObj)) { + Tcl_IncrRefCount(cmdObj); + tokenPtr = parsePtr->tokenPtr; + cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); + + if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { + /* + * Found a command. Test all the ways we can be told + * not to attempt to compile it. + */ + if ((cmdPtr->compileProc == NULL) + || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES) + || (expand && !(cmdPtr->flags & CMD_COMPILES_EXPANDED))) { + cmdPtr = NULL; + } + } + } + + /* Pre-Compile */ +int lastTopLevelCmdIndex, currCmdIndex, startCodeOffset; + +int cmdLine = envPtr->line; +int *clNext = envPtr->clNext; + + lastTopLevelCmdIndex = currCmdIndex = envPtr->numCommands; + envPtr->numCommands++; + startCodeOffset = envPtr->codeNext - envPtr->codeStart; + EnterCmdStartData(envPtr, currCmdIndex, + parsePtr->commandStart - envPtr->source, startCodeOffset); + + if (expand && !cmdPtr) { + StartExpanding(envPtr); + } + + /* + * TIP #280. Scan the words and compute the extended location + * information. The map first contain full per-word line + * information for use by the compiler. This is later replaced by + * a reduced form which signals non-literal words, stored in + * 'wlines'. + */ + + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + + if (cmdPtr) { + int savedNumCmds = envPtr->numCommands; + int update = 0; + int startStackDepth = envPtr->currStackDepth; + + /* + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first bytecode in the compile env, + * as the check is done before calling + * TclNRExecuteByteCode(). Do emit an INST_START_CMD + * in special cases where the first bytecode is in a + * loop, to insure that the corresponding command is + * counted properly. Compilers for commands able to + * produce such a beast (currently 'while 1' only) set + * envPtr->atCmdStart to 0 in order to signal this + * case. [Bug 1752146] + * + * Note that the environment is initialised with + * atCmdStart=1 to avoid emitting ISC for the first + * command. + */ + + if (envPtr->atCmdStart == 1) { + if (startCodeOffset) { + /* + * Increase the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) + } + } else if (envPtr->atCmdStart == 0) { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + TclEmitInt4(1, envPtr); + update = 1; + } + + if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { + +#ifdef TCL_COMPILE_DEBUG + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - startStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", + parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + if (update) { + /* + * Fix the bytecode length. + */ + + unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; + unsigned fixLen = envPtr->codeNext - fixPtr + 1; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + goto finishCommand; + } + + if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { + /* + * Decrease the number of commands being started + * at the current point. Note that this depends on + * the exact layout of the INST_START_CMD's + * operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); + } + /* - * Command is not known until runtime substitution is complete. - * Emit instructions to perform that substitution. + * Restore numCommands, codeNext, and currStackDepth to their + * correct values, removing any commands compiled before the + * failure to produce bytecode got reported. + * [Bugs 705406, 735055, 3614102] */ - CompileTokens(interp, cmdTokenPtr, envPtr); + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + startCodeOffset; + envPtr->currStackDepth = startStackDepth; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + + /* TODO: Can this happen? If so, is this right? */ + if (expand) { + StartExpanding(envPtr); + } } - + /* + * No complile attempted, or it failed. + * Need to emit instructions to invoke, with expansion if needed. + */ + + wordIdx = 0; + tokenPtr = parsePtr->tokenPtr; + if (cmdKnown) { + int cmdLitIdx, numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + + cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { + TclSetCmdNameObj(interp, + TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * Emit an invoke instruction for the command. We skip this if a + * compile procedure was found for the command. + */ + + if (expand) { + /* + * The stack depth during argument expansion can only be + * managed at runtime, as the number of elements in the + * expanded lists is not known at compile time. We adjust here + * the stack depth estimate so that it is correct after the + * command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. + */ + + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - wordIdx, envPtr); + } else { + /* + * Save PC -> command map for the TclArgumentBC* functions. + */ + + int isnew; + Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, + INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew); + + Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } + } + +finishCommand: TclEmitOpcode(INST_POP, envPtr); + EnterCmdExtentData(envPtr, currCmdIndex, + parsePtr->term - parsePtr->commandStart, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + if (cmdKnown) { + Tcl_DecrRefCount(cmdObj); + } + + /* + * TIP #280: Free full form of per-word line data and insert the + * reduced form now + */ + + envPtr->line = cmdLine; + envPtr->clNext = clNext; + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); + eclPtr->loc[wlineat].line = wlines; + eclPtr->loc[wlineat].next = NULL; } #endif @@ -1828,14 +2096,19 @@ TclCompileScript( */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + int commandLength = parse.term - parse.commandStart; fprintf(stdout, " Compiling: "); TclPrintSource(stdout, parse.commandStart, - TclMin(parse.term - parse.commandStart, 55)); + TclMin(commandLength, 55)); fprintf(stdout, "\n"); } #endif + envPtr->line = cmdLine; + envPtr->clNext = clNext; CompileCommandTokens(interp, &parse, envPtr); + cmdLine = envPtr->line; + clNext = envPtr->clNext; /* * Advance to the next command in the script. @@ -1849,7 +2122,7 @@ TclCompileScript( * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + TclAdvanceLines(&cmdLine, parse.commandStart, p); TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); Tcl_FreeParse(&parse); } @@ -1869,6 +2142,10 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); + } else { + /* Remove the surplus INST_POP */ + envPtr->codeNext--; + TclAdjustStackDepth(1, envPtr); } #else int lastTopLevelCmdIndex = -1; -- cgit v0.12 From a0860b63fb252ca05d70706533db45c410b95c0e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Jun 2013 03:46:54 +0000 Subject: A few bug fixes from failing tests; still leaky. --- generic/tclCompile.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 955078c..626c5ae 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2076,7 +2076,10 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parse.commandStart, - parse.term - parse.commandStart); + /* Drop the command terminator (";","]") if appropriate */ + (parse.term == + parse.commandStart + parse.commandSize - 1)? + parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); break; } @@ -2142,7 +2145,7 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); - } else { + } else if (envPtr->codeNext[-1] == INST_POP) { /* Remove the surplus INST_POP */ envPtr->codeNext--; TclAdjustStackDepth(1, envPtr); -- cgit v0.12 From 33e20f17a6f8a5fddafb1a39563a04aed53705e1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Jun 2013 16:06:44 +0000 Subject: Fix bytecode ranges in the cmdMapPtr. still leaky. --- generic/tclCompile.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 626c5ae..62943b2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1742,7 +1742,8 @@ static void CompileCommandTokens( Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr) + CompileEnv *envPtr, + int *lastPopPtr) { Interp *iPtr = (Interp *) interp; Tcl_Obj *cmdObj = Tcl_NewObj(); @@ -2017,6 +2018,8 @@ finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + *lastPopPtr = currCmdIndex; + if (cmdKnown) { Tcl_DecrRefCount(cmdObj); @@ -2051,6 +2054,7 @@ TclCompileScript( unsigned char *entryCodeNext = envPtr->codeNext; const char *p; int cmdLine, *clNext; + int lastPop = -1; if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2081,6 +2085,7 @@ TclCompileScript( parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); + lastPop = -1; break; } @@ -2109,7 +2114,7 @@ TclCompileScript( envPtr->line = cmdLine; envPtr->clNext = clNext; - CompileCommandTokens(interp, &parse, envPtr); + CompileCommandTokens(interp, &parse, envPtr, &lastPop); cmdLine = envPtr->line; clNext = envPtr->clNext; @@ -2145,8 +2150,8 @@ TclCompileScript( if (envPtr->codeNext == entryCodeNext) { PushStringLiteral(envPtr, ""); - } else if (envPtr->codeNext[-1] == INST_POP) { - /* Remove the surplus INST_POP */ + } else if (lastPop >= 0) { + envPtr->cmdMapPtr[lastPop].numCodeBytes--; envPtr->codeNext--; TclAdjustStackDepth(1, envPtr); } -- cgit v0.12 From e72d24628cda082e00cafb1ec1e95ea027dc66c8 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Jun 2013 13:11:53 +0000 Subject: plug memory leaks --- generic/tclCompile.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 62943b2..416078c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1746,7 +1746,7 @@ CompileCommandTokens( int *lastPopPtr) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *cmdObj = Tcl_NewObj(); + Tcl_Obj *cmdObj; Tcl_Token *tokenPtr = parsePtr->tokenPtr; Command *cmdPtr = NULL; int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; @@ -1765,6 +1765,7 @@ CompileCommandTokens( } } + cmdObj = Tcl_NewObj(); Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -2085,6 +2086,7 @@ TclCompileScript( parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); + Tcl_FreeParse(&parse); lastPop = -1; break; } -- cgit v0.12 From 7924f4a694c43ca8fe4260041d090795b0791a96 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Jun 2013 20:10:41 +0000 Subject: Stop the compileProc routines leaving behind error messages in interp. (Nicer way to solve [Bug 20a81392ec].) Make simplifications in TclCompileScript() make possible by the new structure. Still a work in progress. --- generic/tclAssembly.c | 32 +++++++++++++- generic/tclCompCmds.c | 5 ++- generic/tclCompCmdsGR.c | 1 + generic/tclCompile.c | 109 ++++++++++++++++++++++-------------------------- 4 files changed, 83 insertions(+), 64 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 62641e6..1a061f0 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,6 +930,12 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ +#if 0 + int numCommands = envPtr->numCommands; + int offset = envPtr->codeNext - envPtr->codeStart; + int depth = envPtr->currStackDepth; +#endif + /* * Make sure that the command has a single arg that is a simple word. */ @@ -943,10 +949,32 @@ TclCompileAssembleCmd( } /* - * Compile the code and return any error from the compilation. + * Compile the code and convert any error from the compilation into + * bytecode reporting the error; */ - return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); + if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, + tokenPtr[1].size, TCL_EVAL_DIRECT)) { + + /* + * TODO: Finish working out how to capture syntax errors captured + * during compile and make them bytecode reporting the error. + */ +#if 0 + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.*s\" body, line %d)", + parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + Tcl_GetErrorLine(interp))); + envPtr->numCommands = numCommands; + envPtr->codeNext = envPtr->codeStart + offset; + envPtr->currStackDepth = depth; + TclCompileSyntaxError(interp, envPtr); +#else + Tcl_ResetResult(interp); + return TCL_ERROR; +#endif + } + return TCL_OK; } /* diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fddf152..18295eb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2544,7 +2544,7 @@ CompileEachloopCmd( Tcl_DStringInit(&varList); TclDStringAppendToken(&varList, &tokenPtr[1]); - code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), + code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList), &varcList[loopIndex], &varvList[loopIndex]); Tcl_DStringFree(&varList); if (code != TCL_OK) { @@ -2988,7 +2988,8 @@ TclCompileFormatCmd( ckfree(objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { - return TCL_ERROR; + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; } /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..4de8cf2 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2534,6 +2534,7 @@ TclCompileSyntaxError( TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); + Tcl_ResetResult(interp); } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 416078c..5a8524c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1738,24 +1738,25 @@ FindCompiledCommandFromToken( */ #if 1 -static void +static int CompileCommandTokens( Tcl_Interp *interp, Tcl_Parse *parsePtr, - CompileEnv *envPtr, - int *lastPopPtr) + CompileEnv *envPtr) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *cmdObj; Tcl_Token *tokenPtr = parsePtr->tokenPtr; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines, wlineat; + int cmdLine = envPtr->line; + int *clNext = envPtr->clNext; + int cmdIdx = envPtr->numCommands; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - if (numWords == 0) { - return; - } + assert (numWords > 0); for (wordIdx = 0; wordIdx < numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { @@ -1765,7 +1766,6 @@ CompileCommandTokens( } } - cmdObj = Tcl_NewObj(); Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -1787,15 +1787,9 @@ CompileCommandTokens( } /* Pre-Compile */ -int lastTopLevelCmdIndex, currCmdIndex, startCodeOffset; - -int cmdLine = envPtr->line; -int *clNext = envPtr->clNext; - lastTopLevelCmdIndex = currCmdIndex = envPtr->numCommands; envPtr->numCommands++; - startCodeOffset = envPtr->codeNext - envPtr->codeStart; - EnterCmdStartData(envPtr, currCmdIndex, + EnterCmdStartData(envPtr, cmdIdx, parsePtr->commandStart - envPtr->source, startCodeOffset); if (expand && !cmdPtr) { @@ -2016,11 +2010,9 @@ int *clNext = envPtr->clNext; finishCommand: TclEmitOpcode(INST_POP, envPtr); - EnterCmdExtentData(envPtr, currCmdIndex, + EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - *lastPopPtr = currCmdIndex; - if (cmdKnown) { Tcl_DecrRefCount(cmdObj); @@ -2037,6 +2029,8 @@ finishCommand: ckfree(eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; + + return cmdIdx; } #endif @@ -2052,10 +2046,8 @@ TclCompileScript( CompileEnv *envPtr) /* Holds resulting instructions. */ { #if 1 - unsigned char *entryCodeNext = envPtr->codeNext; - const char *p; - int cmdLine, *clNext; - int lastPop = -1; + int lastCmdIdx = -1; + const char *p = script; if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2066,40 +2058,34 @@ TclCompileScript( * from the script. */ - p = script; - cmdLine = envPtr->line; - clNext = envPtr->clNext; + /* TODO: Figure out when/why we need this */ +#if 0 +if (Tcl_GetStringResult(interp)[0] != '\0') { + fprintf(stdout, "INIT: '%s'\n", Tcl_GetStringResult(interp)); + fflush(stdout); +} +#endif + Tcl_ResetResult(interp); while (numBytes > 0) { Tcl_Parse parse; const char *next; - /* TODO: can we relocate this to happen less frequently? */ - Tcl_ResetResult(interp); if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { /* * Compile bytecodes to report the parse error at runtime. */ Tcl_LogCommandInfo(interp, script, parse.commandStart, +/* TODO: Make this more sensible, f. ex. [eval {foo \$x(}] */ /* Drop the command terminator (";","]") if appropriate */ (parse.term == parse.commandStart + parse.commandSize - 1)? parse.commandSize - 1 : parse.commandSize); TclCompileSyntaxError(interp, envPtr); Tcl_FreeParse(&parse); - lastPop = -1; - break; + return; } - /* - * TIP #280: Count newlines before the command start. - * (See test info-30.33). - */ - - TclAdvanceLines(&cmdLine, p, parse.commandStart); - TclAdvanceContinuations(&cmdLine, &clNext, - parse.commandStart - envPtr->source); - #ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. @@ -2114,48 +2100,51 @@ TclCompileScript( } #endif - envPtr->line = cmdLine; - envPtr->clNext = clNext; - CompileCommandTokens(interp, &parse, envPtr, &lastPop); - cmdLine = envPtr->line; - clNext = envPtr->clNext; + /* + * TIP #280: Count newlines before the command start. + * (See test info-30.33). + */ + + TclAdvanceLines(&envPtr->line, p, parse.commandStart); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + parse.commandStart - envPtr->source); /* - * Advance to the next command in the script. + * Advance parser to the next command in the script. */ next = parse.commandStart + parse.commandSize; numBytes -= next - p; p = next; + if (parse.numWords == 0) { + /* TODO: Document justification */ + continue; + } + + lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr); + /* * TIP #280: Track lines in the just compiled command. */ - TclAdvanceLines(&cmdLine, parse.commandStart, p); - TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); + TclAdvanceLines(&envPtr->line, parse.commandStart, p); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + p - envPtr->source); Tcl_FreeParse(&parse); } /* - * TIP #280: Bring the line counts in the CompEnv up to date. - * See tests info-30.33,34,35 . - */ - - envPtr->line = cmdLine; - envPtr->clNext = clNext; - - /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. */ - if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); - } else if (lastPop >= 0) { - envPtr->cmdMapPtr[lastPop].numCodeBytes--; + if (lastCmdIdx >= 0) { + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; - TclAdjustStackDepth(1, envPtr); + envPtr->currStackDepth++; + } else { + PushStringLiteral(envPtr, ""); } #else int lastTopLevelCmdIndex = -1; -- cgit v0.12 From d896ae28d39cbaeb363e3b84c58c26e31bd0c56d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Jun 2013 02:58:15 +0000 Subject: More elimination of error message litter to fix [Bug 20a81392ec]. --- generic/tclCompCmdsSZ.c | 3 +++ generic/tclCompile.c | 8 -------- generic/tclExecute.c | 18 +++++++----------- 3 files changed, 10 insertions(+), 19 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 855dd8f..026b214 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -748,6 +748,9 @@ TclSubstCompile( Tcl_InterpState state = NULL; TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); + if (state != NULL) { + Tcl_ResetResult(interp); + } /* * Tricky point! If the first token does not result in a *guaranteed* push diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5a8524c..1f72aa7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2058,14 +2058,6 @@ TclCompileScript( * from the script. */ - /* TODO: Figure out when/why we need this */ -#if 0 -if (Tcl_GetStringResult(interp)[0] != '\0') { - fprintf(stdout, "INIT: '%s'\n", Tcl_GetStringResult(interp)); - fflush(stdout); -} -#endif - Tcl_ResetResult(interp); while (numBytes > 0) { Tcl_Parse parse; const char *next; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3a0d32..37bf072 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1426,17 +1426,12 @@ Tcl_NRExprObj( Tcl_Obj *resultPtr) { ByteCode *codePtr; + Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); - /* TODO: consider saving whole state? */ - Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); - - Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); codePtr = CompileExprObj(interp, objPtr); - /* TODO: Confirm reset not required? */ - /*Tcl_ResetResult(interp);*/ - Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr, + Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); } @@ -1447,14 +1442,15 @@ ExprObjCallback( Tcl_Interp *interp, int result) { - Tcl_Obj *saveObjPtr = data[0]; + Tcl_InterpState state = data[0]; Tcl_Obj *resultPtr = data[1]; if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, saveObjPtr); + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); } - TclDecrRefCount(saveObjPtr); return result; } -- cgit v0.12 From 5d46ba8b3ec614cfb931011d5b6c35d9eb046d75 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 1 Jul 2013 20:58:15 +0000 Subject: More Work In Progress. --- generic/tclCompile.c | 55 ++++++++++++++++++++++++++++++++-------------------- tests/misc.test | 7 +------ 2 files changed, 35 insertions(+), 27 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1f72aa7..6f5ef50 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -16,6 +16,8 @@ #include "tclCompile.h" #include +#define REWRITE + /* * Table of all AuxData types. */ @@ -562,8 +564,10 @@ static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); +#ifndef REWRITE static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, Tcl_Token *tokenPtr); +#endif static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -1671,6 +1675,7 @@ TclWordKnownAtCompileTime( return 1; } +#ifndef REWRITE /* * --------------------------------------------------------------------- * @@ -1718,6 +1723,7 @@ FindCompiledCommandFromToken( Tcl_DStringFree(&ds); return cmdPtr; } +#endif /* *---------------------------------------------------------------------- @@ -1737,7 +1743,7 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ -#if 1 +#ifdef REWRITE static int CompileCommandTokens( Tcl_Interp *interp, @@ -2045,18 +2051,18 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#if 1 - int lastCmdIdx = -1; - const char *p = script; +#ifdef REWRITE + int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last + * command this routine compiles into bytecode. + * Initial value of -1 indicates this routine + * has not yet generated any bytecode. */ + const char *p = script; /* Where we are in our compile. */ if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); } - /* - * Each iteration through the following loop compiles the next command - * from the script. - */ + /* Each iteration compiles one command from the script. */ while (numBytes > 0) { Tcl_Parse parse; @@ -2068,11 +2074,7 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parse.commandStart, -/* TODO: Make this more sensible, f. ex. [eval {foo \$x(}] */ - /* Drop the command terminator (";","]") if appropriate */ - (parse.term == - parse.commandStart + parse.commandSize - 1)? - parse.commandSize - 1 : parse.commandSize); + parse.term + 1 - parse.commandStart); TclCompileSyntaxError(interp, envPtr); Tcl_FreeParse(&parse); return; @@ -2126,17 +2128,28 @@ TclCompileScript( Tcl_FreeParse(&parse); } - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - */ - - if (lastCmdIdx >= 0) { + if (lastCmdIdx == -1) { + /* + * Compiling the script yielded no bytecode. The script must be + * all whitespace, comments, and empty commands. Such scripts + * are defined to successfully produce the empty string result, + * so we emit the simple bytecode that makes that happen. + */ + PushStringLiteral(envPtr, ""); + } else { + /* + * We compiled at least one command to bytecode. The routine + * CompileCommandTokens() follows the bytecode of each compiled + * command with an INST_POP, so that stack balance is maintained + * when several commands are in sequence. (The result of each + * command is thrown away before moving on to the next command). + * For the last command compiled, we need to undo that INST_POP + * so that the result of the last command becomes the result of + * the script. These code here removes that trailing INST_POP. + */ envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; envPtr->currStackDepth++; - } else { - PushStringLiteral(envPtr, ""); } #else int lastTopLevelCmdIndex = -1; diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] -- cgit v0.12 From 5599b1864958a90b4754b554eadb41722bdc9246 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 2 Jul 2013 10:36:32 +0000 Subject: comment improvements --- generic/tclCompile.c | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6f5ef50..05daabf 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1764,6 +1764,7 @@ CompileCommandTokens( assert (numWords > 0); + /* Determine whether any words of the command require expansion */ for (wordIdx = 0; wordIdx < numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { @@ -1772,6 +1773,7 @@ CompileCommandTokens( } } + /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); @@ -1791,6 +1793,7 @@ CompileCommandTokens( } } } + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ /* Pre-Compile */ @@ -2112,7 +2115,22 @@ TclCompileScript( p = next; if (parse.numWords == 0) { - /* TODO: Document justification */ + /* + * The "command" parsed has no words. In this case + * we can skip the rest of the loop body. With no words, + * clearly CompileCommandTokens() has nothing to do. Since + * the parser aggressively sucks up leading comment and white + * space, including newlines, parse.commandStart must be + * pointing at either the end of script, or a command-terminating + * semi-colon. In either case, the TclAdvance*() calls have + * nothing to do. Finally, when no words are parsed, no + * tokens have been allocated at parse.tokenPtr so there's + * also nothing for Tcl_FreeParse() to do. + * + * The advantage of this shortcut is that CompileCommandTokens() + * can be written with an assumption that parse.numWords > 0, + * with the implication the CCT() always generates bytecode. + */ continue; } @@ -2145,7 +2163,7 @@ TclCompileScript( * command is thrown away before moving on to the next command). * For the last command compiled, we need to undo that INST_POP * so that the result of the last command becomes the result of - * the script. These code here removes that trailing INST_POP. + * the script. The code here removes that trailing INST_POP. */ envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; -- cgit v0.12 From 4e5f3c749a2ed1b7c44cb7d1040ed19b03898b18 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 14:31:14 +0000 Subject: The routines StartExpanding() and EnterCmdWordData() are orthogonal, so it's ok to reverse the order in which they are called. --- generic/tclCompile.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5aab69c..0dc30e2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1802,10 +1802,6 @@ CompileCommandTokens( EnterCmdStartData(envPtr, cmdIdx, parsePtr->commandStart - envPtr->source, startCodeOffset); - if (expand && !cmdPtr) { - StartExpanding(envPtr); - } - /* * TIP #280. Scan the words and compute the extended location * information. The map first contain full per-word line @@ -1823,6 +1819,9 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; + if (expand && !cmdPtr) { + StartExpanding(envPtr); + } if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; -- cgit v0.12 From edb7dfc419cc7a8a06ed06669400e1e192a47c09 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:00:02 +0000 Subject: Consolidate the StartExpanding() calls. --- generic/tclCompile.c | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 0dc30e2..cbb93d9 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1819,9 +1819,6 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; - if (expand && !cmdPtr) { - StartExpanding(envPtr); - } if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; @@ -1919,11 +1916,10 @@ CompileCommandTokens( envPtr->line = eclPtr->loc[wlineat].line[0]; envPtr->clNext = eclPtr->loc[wlineat].next[0]; + } - /* TODO: Can this happen? If so, is this right? */ - if (expand) { - StartExpanding(envPtr); - } + if (expand) { + StartExpanding(envPtr); } /* -- cgit v0.12 From d8459f08677700f376c5e39328895bd98bb5d7d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:24:56 +0000 Subject: Defer expansion request detection as much as possible. --- generic/tclCompile.c | 43 ++++++++++++++++++++++++++++++------------- 1 file changed, 30 insertions(+), 13 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cbb93d9..052dc8e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1744,6 +1744,22 @@ FindCompiledCommandFromToken( */ #ifdef REWRITE + +static int +ExpandRequested( + Tcl_Token *tokenPtr, + int numWords) +{ + /* Determine whether any words of the command require expansion */ + while (numWords--) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + return 1; + } + tokenPtr += tokenPtr->numComponents + 1; + } + return 0; +} + static int CompileCommandTokens( Tcl_Interp *interp, @@ -1755,7 +1771,7 @@ CompileCommandTokens( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; - int wordIdx, cmdKnown, expand = 0, numWords = parsePtr->numWords; + int wordIdx, cmdKnown, expand = -1, numWords = parsePtr->numWords; int *wlines, wlineat; int cmdLine = envPtr->line; int *clNext = envPtr->clNext; @@ -1763,15 +1779,6 @@ CompileCommandTokens( int startCodeOffset = envPtr->codeNext - envPtr->codeStart; assert (numWords > 0); - - /* Determine whether any words of the command require expansion */ - for (wordIdx = 0; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); @@ -1783,13 +1790,19 @@ CompileCommandTokens( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if (cmdPtr) { /* - * Found a command. Test all the ways we can be told + * Found a command. Test the ways we can be told * not to attempt to compile it. */ if ((cmdPtr->compileProc == NULL) || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES) - || (expand && !(cmdPtr->flags & CMD_COMPILES_EXPANDED))) { + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + cmdPtr = NULL; + } + } + if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + if (expand) { + /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; } } @@ -1918,6 +1931,10 @@ CompileCommandTokens( envPtr->clNext = eclPtr->loc[wlineat].next[0]; } + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + } + if (expand) { StartExpanding(envPtr); } -- cgit v0.12 From c5f6c28026fcea560f1ca456c9ac4f8b7239e902 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 15:39:55 +0000 Subject: Move TIP 280 and command extent housekeeping to the periphery. --- generic/tclCompile.c | 54 ++++++++++++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 052dc8e..388b8a0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1780,6 +1780,29 @@ CompileCommandTokens( assert (numWords > 0); + /* Pre-Compile */ + + envPtr->numCommands++; + EnterCmdStartData(envPtr, cmdIdx, + parsePtr->commandStart - envPtr->source, startCodeOffset); + + /* + * TIP #280. Scan the words and compute the extended location + * information. The map first contain full per-word line + * information for use by the compiler. This is later replaced by + * a reduced form which signals non-literal words, stored in + * 'wlines'. + */ + + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + /* Do we know the command word? */ Tcl_IncrRefCount(cmdObj); tokenPtr = parsePtr->tokenPtr; @@ -1809,29 +1832,6 @@ CompileCommandTokens( } /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ - /* Pre-Compile */ - - envPtr->numCommands++; - EnterCmdStartData(envPtr, cmdIdx, - parsePtr->commandStart - envPtr->source, startCodeOffset); - - /* - * TIP #280. Scan the words and compute the extended location - * information. The map first contain full per-word line - * information for use by the compiler. This is later replaced by - * a reduced form which signals non-literal words, stored in - * 'wlines'. - */ - - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->commandSize, parsePtr->numWords, cmdLine, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; - - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; - if (cmdPtr) { int savedNumCmds = envPtr->numCommands; int update = 0; @@ -2031,15 +2031,15 @@ CompileCommandTokens( } finishCommand: + if (cmdKnown) { + Tcl_DecrRefCount(cmdObj); + } + TclEmitOpcode(INST_POP, envPtr); EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - if (cmdKnown) { - Tcl_DecrRefCount(cmdObj); - } - /* * TIP #280: Free full form of per-word line data and insert the * reduced form now -- cgit v0.12 From d668a84e6108d23992a0dcfa20714ce1c4be3037 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 18:08:01 +0000 Subject: Plug memory leak; Break three compilation mechanisms into routines. --- generic/tclCompile.c | 462 +++++++++++++++++++++++++++++---------------------- 1 file changed, 266 insertions(+), 196 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 388b8a0..1958d47 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1760,6 +1760,255 @@ ExpandRequested( return 0; } +static void +CompileInvocation( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + int wlineat, + CompileEnv *envPtr) +{ + int isnew, wordIdx = 0; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + + if (cmdObj) { + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), + cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * Save PC -> command map for the TclArgumentBC* functions. + */ + + Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, + INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), + INT2PTR(wlineat)); + + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } +} + +static void +CompileExpanded( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + int wlineat, + CompileEnv *envPtr) +{ + int wordIdx = 0; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + + StartExpanding(envPtr); + if (cmdObj) { + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, + TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); + + wordIdx = 1; + tokenPtr += tokenPtr->numComponents + 1; + } + + for (; wordIdx < numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + int objIdx; + + envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, + eclPtr->loc[wlineat].next[wordIdx]); + } + TclEmitPush(objIdx, envPtr); + } + + /* + * The stack depth during argument expansion can only be + * managed at runtime, as the number of elements in the + * expanded lists is not known at compile time. We adjust here + * the stack depth estimate so that it is correct after the + * command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. + */ + + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - wordIdx, envPtr); +} + +static int +CompileCmdCompileProc( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, + int startCodeOffset, + CompileEnv *envPtr) +{ + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int savedNumCmds = envPtr->numCommands; + int startStackDepth = envPtr->currStackDepth; + int wlineat = eclPtr->nuloc - 1; + int update = 0; + + /* + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first bytecode in the compile env, + * as the check is done before calling + * TclNRExecuteByteCode(). Do emit an INST_START_CMD + * in special cases where the first bytecode is in a + * loop, to insure that the corresponding command is + * counted properly. Compilers for commands able to + * produce such a beast (currently 'while 1' only) set + * envPtr->atCmdStart to 0 in order to signal this + * case. [Bug 1752146] + * + * Note that the environment is initialised with + * atCmdStart=1 to avoid emitting ISC for the first + * command. + */ + + if (envPtr->atCmdStart == 1) { + if (startCodeOffset) { + /* + * Increase the number of commands being + * started at the current point. Note that + * this depends on the exact layout of the + * INST_START_CMD's operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) + } + } else if (envPtr->atCmdStart == 0) { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + TclEmitInt4(1, envPtr); + update = 1; + } + + if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { + +#ifdef TCL_COMPILE_DEBUG + /* + * Confirm that the command compiler generated a + * single value on the stack as its result. This + * is only done in debugging mode, as it *should* + * be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - startStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + if (update) { + /* + * Fix the bytecode length. + */ + + unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; + unsigned fixLen = envPtr->codeNext - fixPtr + 1; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + return TCL_OK; + } + + if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { + /* + * Decrease the number of commands being started + * at the current point. Note that this depends on + * the exact layout of the INST_START_CMD's + * operands, so be careful! + */ + + TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); + } + + /* + * Restore numCommands, codeNext, and currStackDepth to their + * correct values, removing any commands compiled before the + * failure to produce bytecode got reported. + * [Bugs 705406, 735055, 3614102] + */ + + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + startCodeOffset; + envPtr->currStackDepth = startStackDepth; + + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + return TCL_ERROR; +} + static int CompileCommandTokens( Tcl_Interp *interp, @@ -1771,14 +2020,15 @@ CompileCommandTokens( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj = Tcl_NewObj(); Command *cmdPtr = NULL; - int wordIdx, cmdKnown, expand = -1, numWords = parsePtr->numWords; + int code = TCL_ERROR; + int cmdKnown, expand = -1; int *wlines, wlineat; int cmdLine = envPtr->line; int *clNext = envPtr->clNext; int cmdIdx = envPtr->numCommands; int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - assert (numWords > 0); + assert (parsePtr->numWords > 0); /* Pre-Compile */ @@ -1830,210 +2080,30 @@ CompileCommandTokens( } } } - /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ if (cmdPtr) { - int savedNumCmds = envPtr->numCommands; - int update = 0; - int startStackDepth = envPtr->currStackDepth; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart == 1) { - if (startCodeOffset) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { - -#ifdef TCL_COMPILE_DEBUG - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - - int diff = envPtr->currStackDepth - startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; - unsigned fixLen = envPtr->codeNext - fixPtr + 1; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - - /* - * Restore numCommands, codeNext, and currStackDepth to their - * correct values, removing any commands compiled before the - * failure to produce bytecode got reported. - * [Bugs 705406, 735055, 3614102] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + startCodeOffset; - envPtr->currStackDepth = startStackDepth; - - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; - } - - if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); - } - - if (expand) { - StartExpanding(envPtr); - } - - /* - * No complile attempted, or it failed. - * Need to emit instructions to invoke, with expansion if needed. - */ - - wordIdx = 0; - tokenPtr = parsePtr->tokenPtr; - if (cmdKnown) { - int cmdLitIdx, numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - - cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - - wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, + startCodeOffset, envPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - int objIdx; - - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - CompileTokens(envPtr, tokenPtr, interp); - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } - - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (envPtr->clNext) { - TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); + if (code == TCL_ERROR) { + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); } - TclEmitPush(objIdx, envPtr); - } - - /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. - */ - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ - - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); - } else { - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - int isnew; - Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew); - - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + if (expand) { + CompileExpanded(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, + envPtr); } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + CompileInvocation(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, + envPtr); } } -finishCommand: - if (cmdKnown) { - Tcl_DecrRefCount(cmdObj); - } + Tcl_DecrRefCount(cmdObj); TclEmitOpcode(INST_POP, envPtr); EnterCmdExtentData(envPtr, cmdIdx, -- cgit v0.12 From 8127bc5dd162ce6a44aa4bdcb28f378ae8663514 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 19:29:01 +0000 Subject: Factor out compiling the Command literal. --- generic/tclCompile.c | 41 +++++++++++++++++++---------------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1958d47..a1ad5c8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1761,6 +1761,23 @@ ExpandRequested( } static void +CompileCmdLiteral( + Tcl_Interp *interp, + Tcl_Obj *cmdObj, + CompileEnv *envPtr) +{ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); +} + +static void CompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, @@ -1773,17 +1790,7 @@ CompileInvocation( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; if (cmdObj) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - - if (cmdPtr) { - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), - cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - + CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; tokenPtr += tokenPtr->numComponents + 1; } @@ -1839,17 +1846,7 @@ CompileExpanded( StartExpanding(envPtr); if (cmdObj) { - int numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); - - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); - } - TclEmitPush(cmdLitIdx, envPtr); - + CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; tokenPtr += tokenPtr->numComponents + 1; } -- cgit v0.12 From 13eca0490a3b888d3858a8a27f12a779d4a8235f Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 22:36:55 +0000 Subject: Use TIP 280 macros. --- generic/tclCompile.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a1ad5c8..656f700 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1906,11 +1906,10 @@ CompileCmdCompileProc( int startCodeOffset, CompileEnv *envPtr) { - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int savedNumCmds = envPtr->numCommands; int startStackDepth = envPtr->currStackDepth; - int wlineat = eclPtr->nuloc - 1; int update = 0; + DefineLineInformation; /* * Mark the start of the command; the proper bytecode @@ -2001,8 +2000,7 @@ CompileCmdCompileProc( envPtr->codeNext = envPtr->codeStart + startCodeOffset; envPtr->currStackDepth = startStackDepth; - envPtr->line = eclPtr->loc[wlineat].line[0]; - envPtr->clNext = eclPtr->loc[wlineat].next[0]; + SetLineInformation(0); return TCL_ERROR; } -- cgit v0.12 From 05741eb1bdedbef1fd4b526cd8ddd3f887d59490 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Jul 2013 23:02:44 +0000 Subject: Use the TokenAfter() macro. --- generic/tclCompile.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 656f700..afe34b0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1755,7 +1755,7 @@ ExpandRequested( if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { return 1; } - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } return 0; } @@ -1792,11 +1792,10 @@ CompileInvocation( if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; @@ -1848,11 +1847,10 @@ CompileExpanded( if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); wordIdx = 1; - tokenPtr += tokenPtr->numComponents + 1; + tokenPtr = TokenAfter(tokenPtr); } - for (; wordIdx < numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -- cgit v0.12 From c2d2ec2ecab6696829da18c4e7174a90e42f9138 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 9 Jul 2013 20:37:37 +0000 Subject: Tentative Work In Progress unwinding TIP 280 line information. --- generic/tclCompile.c | 39 +++++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 10 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index afe34b0..777c03e 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1787,7 +1787,8 @@ CompileInvocation( CompileEnv *envPtr) { int isnew, wordIdx = 0; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; +// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + DefineLineInformation; if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1798,8 +1799,9 @@ CompileInvocation( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; +// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; +// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + SetLineInformation(wordIdx); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1811,7 +1813,8 @@ CompileInvocation( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); +// eclPtr->loc[wlineat].next[wordIdx]); + mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); } @@ -1820,9 +1823,11 @@ CompileInvocation( * Save PC -> command map for the TclArgumentBC* functions. */ - Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, +// Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, + Tcl_SetHashValue(Tcl_CreateHashEntry(&mapPtr->litInfo, INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), - INT2PTR(wlineat)); +// INT2PTR(wlineat)); + INT2PTR(eclIndex)); if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); @@ -1841,7 +1846,9 @@ CompileExpanded( CompileEnv *envPtr) { int wordIdx = 0; - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + DefineLineInformation; +// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + StartExpanding(envPtr); if (cmdObj) { @@ -1853,8 +1860,9 @@ CompileExpanded( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + SetLineInformation(wordIdx); +// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; +// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1870,7 +1878,8 @@ CompileExpanded( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); +// eclPtr->loc[wlineat].next[wordIdx]); + mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); } @@ -1998,6 +2007,16 @@ CompileCmdCompileProc( envPtr->codeNext = envPtr->codeStart + startCodeOffset; envPtr->currStackDepth = startStackDepth; + /* + * Throw out any line information generated by the failed + * compile attempt. + */ + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } + SetLineInformation(0); return TCL_ERROR; } -- cgit v0.12 From ea62135f72eea3a5096735196d59c2b6785e942e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 03:17:57 +0000 Subject: Revise the litInfo table so that it gets built later (in TclInitByteCodeObj) from a simpler store of data that can unwind. --- generic/tclCompile.c | 79 +++++++++++++--------------------------------------- generic/tclCompile.h | 1 + 2 files changed, 20 insertions(+), 60 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 777c03e..c31d256 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1786,8 +1786,7 @@ CompileInvocation( int wlineat, CompileEnv *envPtr) { - int isnew, wordIdx = 0; -// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + int wordIdx = 0; DefineLineInformation; if (cmdObj) { @@ -1799,8 +1798,6 @@ CompileInvocation( for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { int objIdx; -// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; SetLineInformation(wordIdx); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -1813,7 +1810,6 @@ CompileInvocation( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, -// eclPtr->loc[wlineat].next[wordIdx]); mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); @@ -1823,11 +1819,7 @@ CompileInvocation( * Save PC -> command map for the TclArgumentBC* functions. */ -// Tcl_SetHashValue(Tcl_CreateHashEntry(&eclPtr->litInfo, - Tcl_SetHashValue(Tcl_CreateHashEntry(&mapPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), &isnew), -// INT2PTR(wlineat)); - INT2PTR(eclIndex)); + mapPtr->loc[eclIndex].invokePc = envPtr->codeNext - envPtr->codeStart; if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); @@ -1847,7 +1839,6 @@ CompileExpanded( { int wordIdx = 0; DefineLineInformation; -// ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; StartExpanding(envPtr); @@ -1861,8 +1852,6 @@ CompileExpanded( int objIdx; SetLineInformation(wordIdx); -// envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; -// envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); @@ -1878,7 +1867,6 @@ CompileExpanded( if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, -// eclPtr->loc[wlineat].next[wordIdx]); mapPtr->loc[eclIndex].next[wordIdx]); } TclEmitPush(objIdx, envPtr); @@ -2015,6 +2003,7 @@ CompileCmdCompileProc( mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; + mapPtr->loc[mapPtr->nuloc].invokePc = -1; } SetLineInformation(0); @@ -3340,6 +3329,17 @@ TclInitByteCodeObj( * byte code object (internal rep), for use with the bc compiler. */ + for (i = 0; i < envPtr->extCmdMapPtr->nuloc; i++) { + int isnew, pc = envPtr->extCmdMapPtr->loc[i].invokePc; + + if (pc < 0) { + continue; + } + + Tcl_SetHashValue(Tcl_CreateHashEntry(&envPtr->extCmdMapPtr->litInfo, + INT2PTR(pc), &isnew), INT2PTR(i)); + } + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; @@ -3710,6 +3710,7 @@ EnterCmdWordData( ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; + ePtr->invokePc = -1; ePtr->line = ckalloc(numWords * sizeof(int)); ePtr->next = ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; @@ -4493,54 +4494,12 @@ TclFixupForwardJump( { ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; - - /* A helper structure */ - - typedef struct { - int pc; - int cmd; - } MAP; - - /* - * And the helper array. At most the whole hashtable is placed into - * this. - */ - - MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); - - Tcl_HashSearch hSearch; - Tcl_HashEntry* hPtr; - int n, k, isnew; - - /* - * Phase I: Locate the affected entries, and save them in adjusted - * form to the array. This removes them from the hash. - */ - - for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); - map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); - - if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { - Tcl_DeleteHashEntry(hPtr); - map [n].pc += 3; - n++; + for (k = eclPtr->nuloc - 1; k >= 0; k--) { + if (eclPtr->loc[k].invokePc < (jumpFixupPtr->codeOffset + 2)) { + continue; } + eclPtr->loc[k].invokePc += 3; } - - /* - * Phase II: Re-insert the modified entries into the hash. - */ - - for (k=0;klitInfo, INT2PTR(map[k].pc), &isnew); - Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); - } - - ckfree (map); } return 1; /* the jump was grown */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..cbe104c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -175,6 +175,7 @@ typedef struct CmdLocation { typedef struct ECL { int srcOffset; /* Command location to find the entry. */ + int invokePc; int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ -- cgit v0.12 From 98b5a1b51d301f8712ef1dd7e9a321804d93ba02 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 03:28:37 +0000 Subject: Remove the (now unused) wlineat arguments. --- generic/tclCompile.c | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c31d256..5f4acff 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1783,7 +1783,6 @@ CompileInvocation( Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, - int wlineat, CompileEnv *envPtr) { int wordIdx = 0; @@ -1834,7 +1833,6 @@ CompileExpanded( Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, - int wlineat, CompileEnv *envPtr) { int wordIdx = 0; @@ -2095,12 +2093,10 @@ CompileCommandTokens( if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, - envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { CompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, parsePtr->numWords, wlineat, - envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } -- cgit v0.12 From 79cd9409e13c0854f7eb3f04d970e44b30c3ec7d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:17:12 +0000 Subject: Disabling the SetLineInformation() macro entirely causes only 3 tests in the test suite to fail. Restoring just 2 SetLineInformation() calls fixes those failures. The need for all the other SLI() calls is not demonstrated by any test. Without more complete test coverage, it is difficult to confidently tweak the TIP 280 implementation without fear that changes are introducing breakage. --- generic/tclCompCmdsGR.c | 2 ++ generic/tclCompCmdsSZ.c | 2 ++ generic/tclCompile.h | 9 ++++++--- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..3cd0da6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -265,6 +265,8 @@ TclCompileIfCmd( if (compileScripts) { SetLineInformation(wordIdx); +envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; +envPtr->clNext = mapPtr->loc[eclIndex].next[wordIdx]; CompileBody(envPtr, tokenPtr, interp); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 855dd8f..8723a4f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -726,6 +726,8 @@ TclCompileSubstCmd( } SetLineInformation(numArgs); +envPtr->line = mapPtr->loc[eclIndex].line[numArgs]; +envPtr->clNext = mapPtr->loc[eclIndex].next[numArgs]; TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..6fe14f2 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,9 +1537,12 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] +//#define SetLineInformation(word) \ +// envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ +// envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + +#define SetLineInformation(word) + #define PushVarNameWord(i,v,e,f,l,sc,word) \ TclPushVarName(i,v,e,f,l,sc, \ -- cgit v0.12 From 55deb86ee331985bbfedb4d5211968c4dbe1decd Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:27:09 +0000 Subject: First additional test. Remove dup macros in tclEnsemble.c. --- generic/tclCompCmds.c | 2 +- generic/tclCompCmdsGR.c | 4 +--- generic/tclCompCmdsSZ.c | 4 +--- generic/tclCompile.h | 6 +++--- generic/tclEnsemble.c | 10 ---------- tests/info.test | 15 +++++++++++++++ 6 files changed, 21 insertions(+), 20 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fddf152..7ed9006 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,7 +610,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - SetLineInformation(1); + LineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3cd0da6..cc3f694 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -264,9 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - SetLineInformation(wordIdx); -envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; -envPtr->clNext = mapPtr->loc[eclIndex].next[wordIdx]; + LineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 8723a4f..34c24f9 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -725,9 +725,7 @@ TclCompileSubstCmd( return TCL_ERROR; } - SetLineInformation(numArgs); -envPtr->line = mapPtr->loc[eclIndex].line[numArgs]; -envPtr->clNext = mapPtr->loc[eclIndex].next[numArgs]; + LineInformation(numArgs); TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6fe14f2..5043f65 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,9 +1537,9 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -//#define SetLineInformation(word) \ -// envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ -// envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] +#define LineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] #define SetLineInformation(word) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 813e056..e0aa0c4 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -88,16 +88,6 @@ const Tcl_ObjType tclEnsembleCmdType = { NULL /* setFromAnyProc */ }; -/* - * Copied from tclCompCmds.c - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] static inline Tcl_Obj * NewNsObj( diff --git a/tests/info.test b/tests/info.test index ebc853a..a1d3b1a 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1962,6 +1962,21 @@ test info-9.13 {info level option, value in global context} -body { } -returnCodes error -result {bad level "2"} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + catch {*}{ + {info frame 0} + res + } + return $res +} +test info-33.4 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From acd32d6e7090b829a7d5e1aec2e6b09f987aaccc Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 16:43:01 +0000 Subject: Next attempt. Appears to have uncovered a bug. --- generic/tclCompCmds.c | 2 +- tests/info.test | 14 ++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7ed9006..13318a3 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1467,7 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - SetLineInformation(3); + LineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); diff --git a/tests/info.test b/tests/info.test index a1d3b1a..ba31159 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1977,6 +1977,20 @@ test info-33.4 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + dict for {a b} {c d} {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.5 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From fceaf9997d7c45ba92c6c61930207823446f1e50 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 17:58:45 +0000 Subject: Fix for [86fb5ea28e]. Test will eventually merge in from tip280-test-coverage. --- generic/tclEnsemble.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 813e056..a718d0e 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3059,6 +3059,7 @@ CompileToCompiledCommand( int savedNumCmds = envPtr->numCommands; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + DefineLineInformation; if (cmdPtr->compileProc == NULL) { return TCL_ERROR; @@ -3107,12 +3108,27 @@ CompileToCompiledCommand( } /* + * Shift the line information arrays to account for different word + * index values. + */ + + mapPtr->loc[eclIndex].line += (depth - 1); + mapPtr->loc[eclIndex].next += (depth - 1); + + /* * Hand off compilation to the subcommand compiler. At last! */ result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); /* + * Undo the shift. + */ + + mapPtr->loc[eclIndex].line -= (depth - 1); + mapPtr->loc[eclIndex].next -= (depth - 1); + + /* * If our target fails to compile, revert the number of commands and the * pointer to the place to issue the next instruction. [Bug 3600328] */ -- cgit v0.12 From 6f87f7f3302077aa68a48258e328bbf2ee5abd51 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 19:34:55 +0000 Subject: Add tests for, and fix bugs in, the SetLineInformation() calls in tclCompCmds.c. --- generic/tclCompCmds.c | 20 ++++----- tests/info.test | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 127 insertions(+), 11 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 13318a3..28a3e64 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1651,7 +1651,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords - 1); + LineInformation(parsePtr->numWords - 1); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -1992,7 +1992,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords-1); + LineInformation(parsePtr->numWords-1); CompileBody(envPtr, tokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -2268,7 +2268,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - SetLineInformation(1); + LineInformation(1); CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); @@ -2292,7 +2292,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - SetLineInformation(4); + LineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,7 +2306,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - SetLineInformation(3); + LineInformation(3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2325,7 +2325,7 @@ TclCompileForCmd( testCodeOffset += 3; } - SetLineInformation(2); + LineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; @@ -2464,7 +2464,7 @@ CompileEachloopCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; unsigned char *jumpPc; JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; + int jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; DefineLineInformation; /* TIP #280 */ @@ -2504,8 +2504,6 @@ CompileEachloopCmd( return TCL_ERROR; } - bodyIndex = i-1; - /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -2646,7 +2644,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - SetLineInformation(i); + LineInformation(i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); @@ -2684,7 +2682,7 @@ CompileEachloopCmd( * Inline compile the loop body. */ - SetLineInformation(bodyIndex); + LineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/tests/info.test b/tests/info.test index ba31159..98bb724 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1991,6 +1991,124 @@ test info-33.5 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {a b} + dict update d x y {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.6 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {} + dict with d {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.7 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {set res [info frame 0]} + {1} {} {break} + } + return $res +} +test info-33.8 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} {} + {set res [info frame 0]; break} + } + return $res +} +test info-33.9 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} + {return [info frame 0]} + {} + } +} +test info-33.10 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} + {[return [info frame 0]]} + {} {} + } +} +test info-33.11 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x + } [return [info frame 0]] {} +} +test info-33.12 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x y + {set res [info frame 0]} + } + return $res +} +test info-33.13 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From ef77c88392ff7b5d78b792b9d684a4ba30d175cc Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 19:43:56 +0000 Subject: Add tests for SetLineInformation() calls in tclCompCmdsGR.c. --- generic/tclCompCmdsGR.c | 8 ++++---- tests/info.test | 53 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+), 4 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index cc3f694..32514ab 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -222,7 +222,7 @@ TclCompileIfCmd( compileScripts = 0; } } else { - SetLineInformation(wordIdx); + LineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { @@ -345,7 +345,7 @@ TclCompileIfCmd( * Compile the else command body. */ - SetLineInformation(wordIdx); + LineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -474,7 +474,7 @@ TclCompileIncrCmd( PushLiteral(envPtr, word, numBytes); } } else { - SetLineInformation(2); + LineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ @@ -701,7 +701,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - SetLineInformation(1); + LineInformation(1); CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } diff --git a/tests/info.test b/tests/info.test index 98bb724..98f6ea7 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2109,6 +2109,59 @@ test info-33.13 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if {*}{ + {[return [info frame 0]]} + {} + } +} +test info-33.14 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if 0 {*}{ + {} else + {return [info frame 0]} + } +} +test info-33.15 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + incr {*}{ + x + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + info level {*}{ + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From fe3f5136f96353b1b0d77700e4c4ef6256eb1e55 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Jul 2013 20:33:45 +0000 Subject: Add tests for SetLineInformation() calls in tclCompCmdsSZ.c as well as some obvious refactoring improvements. --- generic/tclCompCmdsSZ.c | 66 ++++++----------- tests/info.test | 186 +++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 206 insertions(+), 46 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 34c24f9..d5208e6 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -40,17 +40,14 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int mode, int noCase, - int valueIndex, Tcl_Token *valueTokenPtr, - int numWords, Tcl_Token **bodyToken, - int *bodyLines, int **bodyNext); -static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int valueIndex, - Tcl_Token *valueTokenPtr, int numWords, + CompileEnv *envPtr, int mode, int noCase, + int valueIndex, int numWords, Tcl_Token **bodyToken, int *bodyLines, - int **bodyContLines); + int **bodyNext); +static void IssueSwitchJumpTable(Tcl_Interp *interp, + CompileEnv *envPtr, int valueIndex, + int numWords, Tcl_Token **bodyToken, + int *bodyLines, int **bodyContLines); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, @@ -89,7 +86,7 @@ const AuxDataType tclJumptableInfoType = { #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define BODY(token,index) \ - SetLineInformation((index));CompileBody(envPtr,(token),interp) + LineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -436,7 +433,7 @@ TclCompileStringMatchCmd( } PushLiteral(envPtr, str, length); } else { - SetLineInformation(i+1+nocase); + LineInformation(i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); @@ -486,7 +483,7 @@ TclCompileStringLenCmd( len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { - SetLineInformation(1); + LineInformation(1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } @@ -1286,13 +1283,16 @@ TclCompileSwitchCmd( * but it handles the most common case well enough. */ + /* Both methods push the value to match against onto the stack. */ + LineInformation(valueIndex); + CompileTokens(envPtr, valueTokenPtr, interp); + if (mode == Switch_Exact) { - IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex, - valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines); + IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken, + bodyLines, bodyContLines); } else { - IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase, - valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines, - bodyContLines); + IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex, + numWords, bodyToken, bodyLines, bodyContLines); } result = TCL_OK; @@ -1330,13 +1330,9 @@ static void IssueSwitchChainedTests( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ @@ -1361,13 +1357,6 @@ IssueSwitchChainedTests( int i; /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* * Generate a test for each arm. */ @@ -1592,11 +1581,7 @@ static void IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ @@ -1612,13 +1597,6 @@ IssueSwitchJumpTable( Tcl_HashEntry *hPtr; /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* * Compile the switch by using a jump table, which is basically a * hashtable that maps from literal values to match against to the offset * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump @@ -2048,8 +2026,7 @@ TclCompileTryCmd( */ DefineLineInformation; /* TIP #280 */ - SetLineInformation(1); - CompileBody(envPtr, bodyToken, interp); + BODY(bodyToken, 1); return TCL_OK; } @@ -3028,13 +3005,12 @@ TclCompileWhileCmd( * Compile the loop body. */ - SetLineInformation(2); bodyCodeOffset = ExceptionRangeStarts(envPtr, range); if (!loopMayEnd) { envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; } - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 2); ExceptionRangeEnds(envPtr, range); OP( POP); @@ -3050,7 +3026,7 @@ TclCompileWhileCmd( bodyCodeOffset += 3; testCodeOffset += 3; } - SetLineInformation(1); + LineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; diff --git a/tests/info.test b/tests/info.test index 98f6ea7..a68fb43 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2155,13 +2155,197 @@ proc foo::bar {} { info level {*}{ } [return [info frame 0]] } -test info-33.16 {{*}, literal, simple, bytecompiled} -body { +test info-33.17 {{*}, literal, simple, bytecompiled} -body { reduce [foo::bar] } -cleanup { namespace delete foo } -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + } [return [info frame 0]] {} +} +test info-33.18 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + {} + } [return [info frame 0]] +} +test info-33.19 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string length {*}{ + } [return [info frame 0]] +} +test info-33.20 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while {*}{ + {[return [info frame 0]]} + } {} +} +test info-33.21 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + switch -- {*}{ + } [return [info frame 0]] {*}{ + } x y +} +test info-33.22 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.23 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } finally {} + return $res +} +test info-33.24 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} + return $res +} +test info-33.25 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} finally {} + return $res +} +test info-33.26 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while 1 {*}{ + {return [info frame 0]} + } +} +test info-33.27 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.28 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.29 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } +} +test info-33.30 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } finally {} +} +test info-33.31 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From f3a1a26516d79b15224325941f72deb7dfda25f6 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 03:48:40 +0000 Subject: Add tests for the SetLineInformation() calls in tclEnsemble.c, and fix the bugs around those calls exposed by the tests. --- generic/tclEnsemble.c | 9 +++------ tests/info.test | 25 +++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 6 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index d654bbf..794a059 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3168,6 +3168,7 @@ CompileToInvokedCommand( bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* TODO: Check about registering Cmd Literals here */ int literal = TclRegisterNewLiteral(envPtr, tokPtr[1].start, tokPtr[1].size); @@ -3179,9 +3180,7 @@ CompileToInvokedCommand( } TclEmitPush(literal, envPtr); } else { - if (envPtr->clNext) { - SetLineInformation(i); - } + LineInformation(i); CompileTokens(envPtr, tokPtr, interp); } tokPtr = TokenAfter(tokPtr); @@ -3255,12 +3254,10 @@ CompileBasicNArgCommand( tokenPtr = TokenAfter(parsePtr->tokenPtr); for (i=1 ; inumWords ; i++) { - if (envPtr->clNext) { - SetLineInformation(i); - } if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } else { + LineInformation(i); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); diff --git a/tests/info.test b/tests/info.test index a68fb43..afdaaee 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2346,6 +2346,31 @@ test info-33.31 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + binary format {*}{ + } [return [info frame 0]] +} +test info-33.32 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set format format + binary $format {*}{ + } [return [info frame 0]] +} +test info-33.33 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From ac62d0c4970dfe3fa03f4fa77c05d23943a20671 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 04:00:57 +0000 Subject: Revert the revised macros used in developing the new tests. --- generic/tclCompCmds.c | 20 ++++++++++---------- generic/tclCompCmdsGR.c | 10 +++++----- generic/tclCompCmdsSZ.c | 12 ++++++------ generic/tclCompile.h | 5 +---- generic/tclEnsemble.c | 4 ++-- 5 files changed, 24 insertions(+), 27 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 28a3e64..a56727d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,7 +610,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - LineInformation(1); + SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -1467,7 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - LineInformation(3); + SetLineInformation(3); CompileBody(envPtr, bodyTokenPtr, interp); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); @@ -1651,7 +1651,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - LineInformation(parsePtr->numWords - 1); + SetLineInformation(parsePtr->numWords - 1); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -1992,7 +1992,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - LineInformation(parsePtr->numWords-1); + SetLineInformation(parsePtr->numWords-1); CompileBody(envPtr, tokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -2268,7 +2268,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - LineInformation(1); + SetLineInformation(1); CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); @@ -2292,7 +2292,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - LineInformation(4); + SetLineInformation(4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,7 +2306,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - LineInformation(3); + SetLineInformation(3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2325,7 +2325,7 @@ TclCompileForCmd( testCodeOffset += 3; } - LineInformation(2); + SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; @@ -2644,7 +2644,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); @@ -2682,7 +2682,7 @@ CompileEachloopCmd( * Inline compile the loop body. */ - LineInformation(numWords - 1); + SetLineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 32514ab..f7c15e6 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -222,7 +222,7 @@ TclCompileIfCmd( compileScripts = 0; } } else { - LineInformation(wordIdx); + SetLineInformation(wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { @@ -264,7 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - LineInformation(wordIdx); + SetLineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -345,7 +345,7 @@ TclCompileIfCmd( * Compile the else command body. */ - LineInformation(wordIdx); + SetLineInformation(wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -474,7 +474,7 @@ TclCompileIncrCmd( PushLiteral(envPtr, word, numBytes); } } else { - LineInformation(2); + SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ @@ -701,7 +701,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - LineInformation(1); + SetLineInformation(1); CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d5208e6..0497e8a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -86,7 +86,7 @@ const AuxDataType tclJumptableInfoType = { #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define BODY(token,index) \ - LineInformation((index));CompileBody(envPtr,(token),interp) + SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -433,7 +433,7 @@ TclCompileStringMatchCmd( } PushLiteral(envPtr, str, length); } else { - LineInformation(i+1+nocase); + SetLineInformation(i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); @@ -483,7 +483,7 @@ TclCompileStringLenCmd( len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { - LineInformation(1); + SetLineInformation(1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } @@ -722,7 +722,7 @@ TclCompileSubstCmd( return TCL_ERROR; } - LineInformation(numArgs); + SetLineInformation(numArgs); TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); @@ -1284,7 +1284,7 @@ TclCompileSwitchCmd( */ /* Both methods push the value to match against onto the stack. */ - LineInformation(valueIndex); + SetLineInformation(valueIndex); CompileTokens(envPtr, valueTokenPtr, interp); if (mode == Switch_Exact) { @@ -3026,7 +3026,7 @@ TclCompileWhileCmd( bodyCodeOffset += 3; testCodeOffset += 3; } - LineInformation(1); + SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5043f65..9af4911 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1537,13 +1537,10 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 -#define LineInformation(word) \ +#define SetLineInformation(word) \ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] -#define SetLineInformation(word) - - #define PushVarNameWord(i,v,e,f,l,sc,word) \ TclPushVarName(i,v,e,f,l,sc, \ mapPtr->loc[eclIndex].line[(word)], \ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 794a059..0bb7cb6 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3180,7 +3180,7 @@ CompileToInvokedCommand( } TclEmitPush(literal, envPtr); } else { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokPtr, interp); } tokPtr = TokenAfter(tokPtr); @@ -3257,7 +3257,7 @@ CompileBasicNArgCommand( if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } else { - LineInformation(i); + SetLineInformation(i); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); -- cgit v0.12 From 6da16cce5001da699a5d43e075eaf706b8d68d63 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 17:06:35 +0000 Subject: Have TclMakeEnsemble() set ENSEMBLE_COMPILE at creation, not as a separate epoch-bumping step. --- generic/tclEnsemble.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 0bb7cb6..680ab45d 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -1527,6 +1527,14 @@ TclMakeEnsemble( cmdName = nameParts[nameCount - 1]; } } + + /* + * Switch on compilation always for core ensembles now that we can do + * nice bytecode things with them. Do it now. Waiting until later will + * just cause pointless epoch bumps. + */ + + ensembleFlags |= ENSEMBLE_COMPILE; ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags); /* @@ -1578,14 +1586,6 @@ TclMakeEnsemble( } } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); - - /* - * Switch on compilation always for core ensembles now that we can do - * nice bytecode things with them. - */ - - Tcl_SetEnsembleFlags(interp, ensemble, - ensembleFlags | ENSEMBLE_COMPILE); } Tcl_DStringFree(&buf); -- cgit v0.12 From 906e3c456afb4ee425936e01ffb768ae30271da4 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Jul 2013 23:19:14 +0000 Subject: Revise the CompileWord() and PushVarNameWord() macros to make explicit the SetLineInformation() that's in each of them. --- generic/tclCompCmds.c | 9 +-------- generic/tclCompile.h | 16 ++++++---------- 2 files changed, 7 insertions(+), 18 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a56727d..0a1a739 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3164,10 +3164,7 @@ TclPushVarName( CompileEnv *envPtr, /* Holds resulting instructions. */ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ int *localIndexPtr, /* Must not be NULL. */ - int *isScalarPtr, /* Must not be NULL. */ - int line, /* Line the token starts on. */ - int *clNext) /* Reference to offset of next hidden cont. - * line. */ + int *isScalarPtr) /* Must not be NULL. */ { register const char *p; const char *name, *elName; @@ -3347,8 +3344,6 @@ TclPushVarName( if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { if (elNameChars) { - envPtr->line = line; - envPtr->clNext = clNext; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { @@ -3360,8 +3355,6 @@ TclPushVarName( * The var name isn't simple: compile and push it. */ - envPtr->line = line; - envPtr->clNext = clNext; CompileTokens(envPtr, varTokenPtr, interp); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9af4911..a4ebd96 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1074,7 +1074,7 @@ MODULE_SCOPE void TclPrintSource(FILE *outFile, MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, - int *isScalarPtr, int line, int *clNext); + int *isScalarPtr); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -1515,13 +1515,10 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define CompileWord(envPtr, tokenPtr, interp, word) \ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ + PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \ } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ + SetLineInformation((word)); \ + CompileTokens((envPtr), (tokenPtr), (interp)); \ } /* @@ -1542,9 +1539,8 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] #define PushVarNameWord(i,v,e,f,l,sc,word) \ - TclPushVarName(i,v,e,f,l,sc, \ - mapPtr->loc[eclIndex].line[(word)], \ - mapPtr->loc[eclIndex].next[(word)]) + SetLineInformation(word); \ + TclPushVarName(i,v,e,f,l,sc) /* * Often want to issue one of two versions of an instruction based on whether -- cgit v0.12 From 979b26b406c0679a35edba070797e94d3ecb656a Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Jul 2013 16:25:51 +0000 Subject: Tests demonstrating the need for the last two SetLineInformation() calls. --- tests/info.test | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/tests/info.test b/tests/info.test index afdaaee..3057dd2 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2371,6 +2371,31 @@ test info-33.33 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append x {*}{ + } [return [info frame 0]] +} +test info-33.34 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append {*}{ + } x([return [info frame 0]]) {*}{ + } a +} +test info-33.35 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup -- cgit v0.12 From 5e4c2308ce99d3d1349d0defd0585b05cd11e3fe Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 12 Jul 2013 18:44:15 +0000 Subject: Global replace: CompileBody() -> BODY(). --- generic/tclCompCmds.c | 25 +++++++++---------------- generic/tclCompCmdsGR.c | 6 ++---- generic/tclCompCmdsSZ.c | 4 +--- generic/tclCompile.h | 14 +++++++------- 4 files changed, 19 insertions(+), 30 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0a1a739..561d816 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -610,12 +610,12 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - SetLineInformation(1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, cmdTokenPtr, interp); + BODY(cmdTokenPtr, 1); } else { + SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -1467,8 +1467,7 @@ CompileDictEachCmd( * Compile the loop body itself. It should be stack-neutral. */ - SetLineInformation(3); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 3); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -1651,8 +1650,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords - 1); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -1992,8 +1990,7 @@ TclCompileDictWithCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - SetLineInformation(parsePtr->numWords-1); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -2268,8 +2265,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - SetLineInformation(1); - CompileBody(envPtr, startTokenPtr, interp); + BODY(startTokenPtr, 1); TclEmitOpcode(INST_POP, envPtr); /* @@ -2292,8 +2288,7 @@ TclCompileForCmd( bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - SetLineInformation(4); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 4); ExceptionRangeEnds(envPtr, bodyRange); TclEmitOpcode(INST_POP, envPtr); @@ -2306,8 +2301,7 @@ TclCompileForCmd( nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - SetLineInformation(3); - CompileBody(envPtr, nextTokenPtr, interp); + BODY(nextTokenPtr, 3); ExceptionRangeEnds(envPtr, nextRange); TclEmitOpcode(INST_POP, envPtr); @@ -2682,9 +2676,8 @@ CompileEachloopCmd( * Inline compile the loop body. */ - SetLineInformation(numWords - 1); ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, numWords - 1); ExceptionRangeEnds(envPtr, range); if (collect == TCL_EACH_COLLECT) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f7c15e6..0572cd3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -264,8 +264,7 @@ TclCompileIfCmd( */ if (compileScripts) { - SetLineInformation(wordIdx); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, wordIdx); } if (realCond) { @@ -345,8 +344,7 @@ TclCompileIfCmd( * Compile the else command body. */ - SetLineInformation(wordIdx); - CompileBody(envPtr, tokenPtr, interp); + BODY(tokenPtr, wordIdx); } /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0497e8a..19e636d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -85,8 +85,6 @@ const AuxDataType tclJumptableInfoType = { TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define BODY(token,index) \ - SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ PushStringLiteral(envPtr, str) #define JUMP4(name,var) \ @@ -1499,7 +1497,7 @@ IssueSwitchChainedTests( } /* - * Now do the actual compilation. Note that we do not use CompileBody + * Now do the actual compilation. Note that we do not use BODY() * because we may have synthesized the tokens in a non-standard * pattern. */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a4ebd96..cf8475d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1407,16 +1407,16 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #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: + * Convenience macros for use when compiling bodies of commands. The ANSI C + * "prototype" for these macros are: * - * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); + * static void BODY(Tcl_Token *tokenPtr, int word); */ -#define CompileBody(envPtr, tokenPtr, interp) \ - TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)) +#define BODY(tokenPtr, word) \ + SetLineInformation((word)); \ + TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \ + envPtr) /* * Convenience macro for use when compiling tokens to be pushed. The ANSI C -- cgit v0.12 From a398b126a43e46efa6d6044b0bcf57a4b9385c4e Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 17:07:51 +0000 Subject: Prefer CompileWord() over CompileTokens() when possible. --- generic/tclCompCmds.c | 3 +-- generic/tclCompCmdsGR.c | 3 +-- generic/tclCompCmdsSZ.c | 3 +-- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 561d816..37ce335 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2638,8 +2638,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - SetLineInformation(i); - CompileTokens(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, i); tempVar = (firstValueTemp + loopIndex); Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); TclEmitOpcode( INST_POP, envPtr); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 0572cd3..2c71dc5 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -699,8 +699,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - SetLineInformation(1); - CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); + CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); } return TCL_OK; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 19e636d..3a91c83 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1282,8 +1282,7 @@ TclCompileSwitchCmd( */ /* Both methods push the value to match against onto the stack. */ - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); + CompileWord(envPtr, valueTokenPtr, interp, valueIndex); if (mode == Switch_Exact) { IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken, -- cgit v0.12 From 59d8c6ba4b9cc7f77258e0cdae09b6d786f19fc4 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 20:16:11 +0000 Subject: Build CompileBasicNArgCommand on top of TclCompileInvocation. --- generic/tclBasic.c | 22 ++++++++++++++++++---- generic/tclCompile.c | 6 +++--- generic/tclCompile.h | 3 +++ generic/tclEnsemble.c | 10 ++++++++++ 4 files changed, 34 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..963b53a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5633,6 +5633,24 @@ TclArgumentBCEnter( CFWordBC *lastPtr = NULL; /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ + + if (ePtr->nline != objc) { + return; + } + + /* + * Having disposed of the ensemble cases, we can state... * A few truths ... * (1) ePtr->nline == objc * (2) (ePtr->line[word] < 0) => !literal, for all words @@ -5642,10 +5660,6 @@ TclArgumentBCEnter( * have to save them at compile time. */ - if (ePtr->nline != objc) { - Tcl_Panic ("TIP 280 data structure inconsistency"); - } - for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { int isnew; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5f4acff..a2c7131 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1777,8 +1777,8 @@ CompileCmdLiteral( TclEmitPush(cmdLitIdx, envPtr); } -static void -CompileInvocation( +void +TclCompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, @@ -2095,7 +2095,7 @@ CompileCommandTokens( CompileExpanded(interp, parsePtr->tokenPtr, cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { - CompileInvocation(interp, parsePtr->tokenPtr, + TclCompileInvocation(interp, parsePtr->tokenPtr, cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 0bcd84e..b94bd93 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1003,6 +1003,9 @@ MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); +MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, + CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, int numBytes, CompileEnv *envPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 680ab45d..9b6ca92 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3229,6 +3229,15 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { +#if 1 + Tcl_Obj *objPtr = Tcl_NewObj(); + + Tcl_IncrRefCount(objPtr); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, + parsePtr->numWords, envPtr); + Tcl_DecrRefCount(objPtr); +#else Tcl_Token *tokenPtr; Tcl_Obj *objPtr; char *bytes; @@ -3272,6 +3281,7 @@ CompileBasicNArgCommand( } else { TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); } +#endif return TCL_OK; } -- cgit v0.12 From 2d98ee0f477ef33bb0a8473efbd44ef203463c32 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 14:07:41 +0000 Subject: Eliminate the litInfo table and all the code tending to its care and feeding. The pc -> command index mapping function it provided can be achieved using other data already in the ByteCode struct. --- generic/tclBasic.c | 134 +++++++++++++++++++++++++-------------------------- generic/tclCompile.c | 43 ----------------- generic/tclCompile.h | 8 --- generic/tclExecute.c | 44 ++++++++++++----- generic/tclInt.h | 2 +- 5 files changed, 97 insertions(+), 134 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 963b53a..bd4f157 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1609,8 +1609,6 @@ DeleteInterpProc( ckfree(eclPtr->loc); } - Tcl_DeleteHashTable(&eclPtr->litInfo); - ckfree(eclPtr); Tcl_DeleteHashEntry(hPtr); } @@ -5614,90 +5612,88 @@ TclArgumentBCEnter( int objc, void *codePtr, CmdFrame *cfPtr, + int cmd, int pc) { + ExtCmdLoc *eclPtr; + int word; + ECL *ePtr; + CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - ExtCmdLoc *eclPtr; if (!hePtr) { return; } eclPtr = Tcl_GetHashValue(hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); - if (hePtr) { - int word; - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL *ePtr = &eclPtr->loc[cmd]; - CFWordBC *lastPtr = NULL; + ePtr = &eclPtr->loc[cmd]; - /* - * ePtr->nline is the number of words originally parsed. - * - * objc is the number of elements getting invoked. - * - * If they are not the same, we arrived here by compiling an - * ensemble dispatch. Ensemble subcommands that lead to script - * evaluation are not supposed to get compiled, because a command - * such as [info level] in the script can expose some of the dispatch - * shenanigans. This means that we don't have to tend to the - * housekeeping, and can escape now. - */ + /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ - if (ePtr->nline != objc) { - return; - } + if (ePtr->nline != objc) { + return; + } - /* - * Having disposed of the ensemble cases, we can state... - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ + /* + * Having disposed of the ensemble cases, we can state... + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isnew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isnew); - CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - lastPtr = cfwPtr; - - if (isnew) { - /* - * The word is not on the stack yet, remember the current - * location and initialize references. - */ - - cfwPtr->prevPtr = NULL; - } else { - /* - * The object is already on the stack, however it may have - * a different location now (literal sharing may map - * multiple location to a single Tcl_Obj*. Save the old - * information in the new structure. - */ - - cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); - } + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, + objv[word], &isnew); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - Tcl_SetHashValue(hPtr, cfwPtr); + cfwPtr->framePtr = cfPtr; + cfwPtr->obj = objv[word]; + cfwPtr->pc = pc; + cfwPtr->word = word; + cfwPtr->nextPtr = lastPtr; + lastPtr = cfwPtr; + + if (isnew) { + /* + * The word is not on the stack yet, remember the current + * location and initialize references. + */ + + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may have + * a different location now (literal sharing may map + * multiple location to a single Tcl_Obj*. Save the old + * information in the new structure. + */ + + cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); } - } /* for */ - cfPtr->litarg = lastPtr; - } /* if */ + Tcl_SetHashValue(hPtr, cfwPtr); + } + } /* for */ + + cfPtr->litarg = lastPtr; } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a2c7131..7e0be76 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1296,8 +1296,6 @@ ReleaseCmdWordData( ckfree((char *) eclPtr->loc); } - Tcl_DeleteHashTable (&eclPtr->litInfo); - ckfree((char *) eclPtr); } @@ -1382,7 +1380,6 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; - Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) { /* @@ -1814,12 +1811,6 @@ TclCompileInvocation( TclEmitPush(objIdx, envPtr); } - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - mapPtr->loc[eclIndex].invokePc = envPtr->codeNext - envPtr->codeStart; - if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { @@ -2001,7 +1992,6 @@ CompileCmdCompileProc( mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; - mapPtr->loc[mapPtr->nuloc].invokePc = -1; } SetLineInformation(0); @@ -3325,17 +3315,6 @@ TclInitByteCodeObj( * byte code object (internal rep), for use with the bc compiler. */ - for (i = 0; i < envPtr->extCmdMapPtr->nuloc; i++) { - int isnew, pc = envPtr->extCmdMapPtr->loc[i].invokePc; - - if (pc < 0) { - continue; - } - - Tcl_SetHashValue(Tcl_CreateHashEntry(&envPtr->extCmdMapPtr->litInfo, - INT2PTR(pc), &isnew), INT2PTR(i)); - } - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; @@ -3706,7 +3685,6 @@ EnterCmdWordData( ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->invokePc = -1; ePtr->line = ckalloc(numWords * sizeof(int)); ePtr->next = ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; @@ -4477,27 +4455,6 @@ TclFixupForwardJump( } } - /* - * TIP #280: Adjust the mapping from PC values to the per-command - * information about arguments and their line numbers. - * - * Note: We cannot simply remove an out-of-date entry and then reinsert - * with the proper PC, because then we might overwrite another entry which - * was at that location. Therefore we pull (copy + delete) all effected - * entries (beyond the fixed PC) into an array, update them there, and at - * last reinsert them all. - */ - - { - ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; - for (k = eclPtr->nuloc - 1; k >= 0; k--) { - if (eclPtr->loc[k].invokePc < (jumpFixupPtr->codeOffset + 2)) { - continue; - } - eclPtr->loc[k].invokePc += 3; - } - } - return 1; /* the jump was grown */ } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b94bd93..f70f8f7 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -175,7 +175,6 @@ typedef struct CmdLocation { typedef struct ECL { int srcOffset; /* Command location to find the entry. */ - int invokePc; int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ @@ -194,13 +193,6 @@ typedef struct ExtCmdLoc { ECL *loc; /* Command word locations (lines). */ int nloc; /* Number of allocated entries in 'loc'. */ int nuloc; /* Number of used entries in 'loc'. */ - Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the - * information accessible per command and - * argument, not per whole bytecode. Value is - * index of command in 'loc', giving us the - * literals to associate with line information - * as command argument, see - * TclArgumentBCEnter() */ } ExtCmdLoc; /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 37bf072..f8ed667 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -721,7 +721,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, - const unsigned char **pcBeg); + const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, @@ -2431,8 +2431,11 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } pc++; @@ -2885,8 +2888,11 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } DECACHE_STACK_INFO(); @@ -3031,8 +3037,11 @@ TEBCresume( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = opnd; @@ -6967,7 +6976,7 @@ TEBCresume( if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; - bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); @@ -7149,7 +7158,7 @@ TEBCresume( } codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); @@ -8642,7 +8651,7 @@ ValidatePcAndStackTop( if (checkStack && ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", stackTop, relativePc, stackUpperBound); @@ -8756,7 +8765,7 @@ TclGetSrcInfoForCmd( ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr, NULL); + codePtr, lenPtr, NULL, NULL); } void @@ -8768,7 +8777,7 @@ TclGetSrcInfoForPc( if (cfPtr->cmd.str.cmd == NULL) { cfPtr->cmd.str.cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len, NULL); + &cfPtr->cmd.str.len, NULL, NULL); } if (cfPtr->cmd.str.cmd != NULL) { @@ -8828,9 +8837,12 @@ GetSrcInfoForPc( int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ - const unsigned char **pcBeg)/* If non-NULL, the bytecode location + const unsigned char **pcBeg,/* If non-NULL, the bytecode location * where the current instruction starts. * If NULL; no pointer is stored. */ + int *cmdIdxPtr) /* If non-NULL, the location where the index + * of the command containing the pc should + * be stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -8840,6 +8852,7 @@ GetSrcInfoForPc( int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + int bestCmdIdx = -1; if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { if (pcBeg != NULL) *pcBeg = NULL; @@ -8907,6 +8920,7 @@ GetSrcInfoForPc( bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; + bestCmdIdx = i; } } } @@ -8936,6 +8950,10 @@ GetSrcInfoForPc( *lengthPtr = bestSrcLength; } + if (cmdIdxPtr != NULL) { + *cmdIdxPtr = bestCmdIdx; + } + return (codePtr->source + bestSrcOffset); } diff --git a/generic/tclInt.h b/generic/tclInt.h index b940225..da09366 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2828,7 +2828,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int pc); + void *codePtr, CmdFrame *cfPtr, int cmd, int pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, -- cgit v0.12 From e783ef57ec6e0ab2d08f1524e86cbc849e36f763 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 14:52:33 +0000 Subject: Simplify arguments to TclContinuationsEnterDerived(). --- generic/tclCompile.c | 6 ++---- generic/tclEnsemble.c | 14 ++++++++------ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7e0be76..bc7501a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1805,8 +1805,7 @@ TclCompileInvocation( tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[wordIdx]); + tokenPtr[1].start - envPtr->source, envPtr->clNext); } TclEmitPush(objIdx, envPtr); } @@ -1855,8 +1854,7 @@ CompileExpanded( tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), - tokenPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[wordIdx]); + tokenPtr[1].start - envPtr->source, envPtr->clNext); } TclEmitPush(objIdx, envPtr); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 9b6ca92..864283b 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3163,12 +3163,16 @@ CompileToInvokedCommand( */ Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); - for (i=0,tokPtr=parsePtr->tokenPtr ; inumWords ; i++) { + for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; + i++, tokPtr = TokenAfter(tokPtr)) { 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) { - /* TODO: Check about registering Cmd Literals here */ + continue; + } + + SetLineInformation(i); + if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { int literal = TclRegisterNewLiteral(envPtr, tokPtr[1].start, tokPtr[1].size); @@ -3176,14 +3180,12 @@ CompileToInvokedCommand( TclContinuationsEnterDerived( TclFetchLiteral(envPtr, literal), tokPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[i]); + envPtr->clNext); } TclEmitPush(literal, envPtr); } else { - SetLineInformation(i); CompileTokens(envPtr, tokPtr, interp); } - tokPtr = TokenAfter(tokPtr); } /* -- cgit v0.12 From 01f1692c1f639eeb817ce6c51928195620872173 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 17:21:12 +0000 Subject: Simplify the ensemble subcommand compile. There's no need to be crafting synthetic Tcl_Parse and copying tokens. Some pointer shifts will do. --- generic/tclCompile.c | 1 - generic/tclEnsemble.c | 70 +++++++++++---------------------------------------- 2 files changed, 15 insertions(+), 56 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bc7501a..d82d728 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1992,7 +1992,6 @@ CompileCmdCompileProc( mapPtr->loc[mapPtr->nuloc].line = NULL; } - SetLineInformation(0); return TCL_ERROR; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 864283b..e4f96c0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3029,12 +3029,6 @@ TclCompileEnsemble( 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, @@ -3043,10 +3037,8 @@ CompileToCompiledCommand( Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Parse synthetic; - Tcl_Token *tokenPtr; int result, i; - int savedNumCmds = envPtr->numCommands; + Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; DefineLineInformation; @@ -3055,47 +3047,17 @@ CompileToCompiledCommand( 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. + * Advance parsePtr->tokenPtr so that it points at the last subcommand. + * This will be wrong, but it will not matter, and it will put the + * tokens for the arguments in the right place without the needed to + * allocate a synthetic Tcl_Parse struct, or copy tokens around. */ - for (i=1; inumComponents + 1; - TclGrowParseTokenArray(&synthetic, toCopy); - memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, - sizeof(Tcl_Token) * toCopy); - synthetic.numTokens += toCopy; - tokenPtr = TokenAfter(tokenPtr); + for (i = 0; i < depth - 1; i++) { + parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr); } + parsePtr->numWords -= (depth - 1); /* * Shift the line information arrays to account for different word @@ -3109,7 +3071,7 @@ CompileToCompiledCommand( * Hand off compilation to the subcommand compiler. At last! */ - result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr); /* * Undo the shift. @@ -3118,22 +3080,20 @@ CompileToCompiledCommand( mapPtr->loc[eclIndex].line -= (depth - 1); mapPtr->loc[eclIndex].next -= (depth - 1); + parsePtr->numWords += (depth - 1); + parsePtr->tokenPtr = saveTokenPtr; + /* - * 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 our target failed to compile, revert any data from failed partial + * compiles. Note that envPtr->numCommands need not be checked because + * we avoid compiling subcommands that recursively call TclCompileScript(). */ if (result != TCL_OK) { - envPtr->numCommands = savedNumCmds; envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; } - /* - * Clean up if necessary. - */ - - Tcl_FreeParse(&synthetic); return result; } -- cgit v0.12 From 945323c68b1aaa265a1467ae1d1101a618e871a9 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 16 Jul 2013 20:48:37 +0000 Subject: Streamline the housekeeping on the operands of INST_START_CMD. For example, do only incr on success, not incr on attempt + decr on error. --- generic/tclCompile.c | 81 +++++++++++++++++++++------------------------------- 1 file changed, 32 insertions(+), 49 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d82d728..6ac5fb9 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1885,47 +1885,41 @@ CompileCmdCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, - int startCodeOffset, CompileEnv *envPtr) { int savedNumCmds = envPtr->numCommands; int startStackDepth = envPtr->currStackDepth; - int update = 0; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; + int incrOffset = -1; DefineLineInformation; /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] + * Emit of the INST_START_CMD instruction is controlled by + * the value of envPtr->atCmdStart: * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. + * atCmdStart == 2 : We are not using the INST_START_CMD instruction. + * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. + * : We do not need to emit another. Instead we + * : increment the number of cmds started at it (except + * : for the special case at the start of a script.) + * atCmdStart == 0 : The last instruction was something else. We need + * : to emit INST_START_CMD here. */ - if (envPtr->atCmdStart == 1) { - if (startCodeOffset) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { + switch (envPtr->atCmdStart) { + case 0: TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; + incrOffset = envPtr->codeNext - envPtr->codeStart; + TclEmitInt4(0, envPtr); + break; + case 1: + if (envPtr->codeNext > envPtr->codeStart) { + incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; + } + break; + case 2: + /* Nothing to do */ + ; } if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { @@ -1947,30 +1941,20 @@ CompileCmdCompileProc( parsePtr->tokenPtr->start, diff); } #endif - if (update) { + if (incrOffset >= 0) { /* - * Fix the bytecode length. + * We successfully compiled a command. Increment the number + * of commands that start at the currently active INST_START_CMD. */ + unsigned char *incrPtr = envPtr->codeStart + incrOffset; + unsigned char *startPtr = incrPtr - 5; - unsigned char *fixPtr = envPtr->codeStart + startCodeOffset + 1; - unsigned fixLen = envPtr->codeNext - fixPtr + 1; - - TclStoreInt4AtPtr(fixLen, fixPtr); + TclIncrUInt4AtPtr(incrPtr, 1); + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } return TCL_OK; } - if (envPtr->atCmdStart == 1 && startCodeOffset != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - /* * Restore numCommands, codeNext, and currStackDepth to their * correct values, removing any commands compiled before the @@ -2069,8 +2053,7 @@ CompileCommandTokens( /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ if (cmdPtr) { - code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, - startCodeOffset, envPtr); + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); } if (code == TCL_ERROR) { -- cgit v0.12 From 6d2beac7e80048bcc4d4d46c68ec4f55d90986b3 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 17 Jul 2013 13:57:23 +0000 Subject: Factor out the call to a compileProc into one place used by both ensemble subcommand compiles and toplevel command compiles in TclCompileScript. --- generic/tclCompile.c | 48 ++++++++++++++---------------------------------- generic/tclCompile.h | 3 +++ generic/tclEnsemble.c | 28 +++++++++++++++++++++------- 3 files changed, 38 insertions(+), 41 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6ac5fb9..763e8f1 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1887,10 +1887,7 @@ CompileCmdCompileProc( Command *cmdPtr, CompileEnv *envPtr) { - int savedNumCmds = envPtr->numCommands; - int startStackDepth = envPtr->currStackDepth; - int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - int incrOffset = -1; + int unwind = 0, incrOffset = -1; DefineLineInformation; /* @@ -1908,6 +1905,7 @@ CompileCmdCompileProc( switch (envPtr->atCmdStart) { case 0: + unwind = tclInstructionTable[INST_START_CMD].numBytes; TclEmitInstInt4(INST_START_CMD, 0, envPtr); incrOffset = envPtr->codeNext - envPtr->codeStart; TclEmitInt4(0, envPtr); @@ -1922,25 +1920,7 @@ CompileCmdCompileProc( ; } - if (TCL_OK == cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr)) { - -#ifdef TCL_COMPILE_DEBUG - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - - int diff = envPtr->currStackDepth - startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { if (incrOffset >= 0) { /* * We successfully compiled a command. Increment the number @@ -1950,21 +1930,15 @@ CompileCmdCompileProc( unsigned char *startPtr = incrPtr - 5; TclIncrUInt4AtPtr(incrPtr, 1); - TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); + if (unwind) { + /* We started the INST_START_CMD. Record the code length. */ + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); + } } return TCL_OK; } - /* - * Restore numCommands, codeNext, and currStackDepth to their - * correct values, removing any commands compiled before the - * failure to produce bytecode got reported. - * [Bugs 705406, 735055, 3614102] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + startCodeOffset; - envPtr->currStackDepth = startStackDepth; + envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ /* * Throw out any line information generated by the failed @@ -1976,6 +1950,12 @@ CompileCmdCompileProc( mapPtr->loc[mapPtr->nuloc].line = NULL; } + /* + * Reset the index of next command. + * Toss out any from failed nested partial compiles. + */ + envPtr->numCommands = mapPtr->nuloc; + return TCL_ERROR; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f70f8f7..56315db 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -984,6 +984,9 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, *---------------------------------------------------------------- */ +MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, + Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + CompileEnv *envPtr); MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index e4f96c0..bab63c9 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -35,9 +35,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); @@ -2994,8 +2991,8 @@ TclCompileEnsemble( */ invokeAnyway = 1; - if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, - envPtr) == TCL_OK) { + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr, + envPtr)) { ourResult = TCL_OK; goto cleanup; } @@ -3029,8 +3026,8 @@ TclCompileEnsemble( return ourResult; } -static int -CompileToCompiledCommand( +int +TclAttemptCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, @@ -3092,6 +3089,23 @@ CompileToCompiledCommand( if (result != TCL_OK) { envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; +#ifdef TCL_COMPILE_DEBUG + } else { + /* + * Confirm that the command compiler generated a single value on + * the stack as its result. This is only done in debugging mode, + * as it *should* be correct and normal users have no reasonable + * way to fix it anyway. + */ + + int diff = envPtr->currStackDepth - savedStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif } return result; -- cgit v0.12 From 517197f8571ca5ff1c51b2cadc771505922d9137 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 18 Jul 2013 15:05:18 +0000 Subject: [Bug 1c17fbba5d] Fix -errorinfo from syntax errors so that the error is not obscured. Instead highlight it by making it the last character quoted. --- generic/tclAssembly.c | 15 ++++++++------- generic/tclBasic.c | 5 ++++- generic/tclCompile.c | 5 +---- tests/assemble.test | 3 +-- tests/misc.test | 7 +------ 5 files changed, 15 insertions(+), 20 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 62641e6..416ee10 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -985,8 +985,6 @@ TclAssembleCode( const char* instPtr = codePtr; /* Where to start looking for a line of code */ - int instLen; /* Length in bytes of the current line of - * code */ const char* nextPtr; /* Pointer to the end of the line of code */ int bytesLeft = codeLen; /* Number of bytes of source code remaining to * be parsed */ @@ -1000,10 +998,6 @@ TclAssembleCode( */ status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); - instLen = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + instLen - 1) { - --instLen; - } /* * Report errors in the parse. @@ -1012,7 +1006,7 @@ TclAssembleCode( if (status != TCL_OK) { if (flags & TCL_EVAL_DIRECT) { Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, - instLen); + parsePtr->term + 1 - parsePtr->commandStart); } FreeAssemblyEnv(assemEnvPtr); return TCL_ERROR; @@ -1032,6 +1026,13 @@ TclAssembleCode( */ if (parsePtr->numWords > 0) { + int instLen = parsePtr->commandSize; + /* Length in bytes of the current command */ + + if (parsePtr->term == parsePtr->commandStart + instLen - 1) { + --instLen; + } + /* * If tracing, show each line assembled as it happens. */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..1d35034 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5084,7 +5084,9 @@ TclEvalEx( do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; - goto error; + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); + goto posterror; } /* @@ -5340,6 +5342,7 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } + posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 633966e..6a2a318 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1790,10 +1790,7 @@ TclCompileScript( */ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - /* Drop the command terminator (";","]") if appropriate */ - (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1)? - parsePtr->commandSize - 1 : parsePtr->commandSize); + parsePtr->term + 1 - parsePtr->commandStart); TclCompileSyntaxError(interp, envPtr); break; } diff --git a/tests/assemble.test b/tests/assemble.test index 7d4e5d1..b0487e6 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} { -match glob -result {1 {extra characters after close-brace} {extra characters after close-brace while executing -"{}extra - " +"{}e" ("assemble" body, line 2)*}} } test assemble-4.2 {null command} { diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] -- cgit v0.12 From f06af4fe86a953a20b9ef90f5605331707370765 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 18 Jul 2013 18:25:24 +0000 Subject: [assemble] compile syntax error into bytecode reporting syntax error message. --- generic/tclAssembly.c | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 0722eb9..9b9b6f8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,7 +930,7 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ -#if 0 +#if 1 int numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; int depth = envPtr->currStackDepth; @@ -956,11 +956,7 @@ TclCompileAssembleCmd( if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, TCL_EVAL_DIRECT)) { - /* - * TODO: Finish working out how to capture syntax errors captured - * during compile and make them bytecode reporting the error. - */ -#if 0 +#if 1 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, @@ -1136,7 +1132,7 @@ NewAssemblyEnv( assemEnvPtr->envPtr = envPtr; assemEnvPtr->parsePtr = parsePtr; - assemEnvPtr->cmdLine = envPtr->line; + assemEnvPtr->cmdLine = 1; assemEnvPtr->clNext = envPtr->clNext; /* -- cgit v0.12 From c81da08d4a5ddf07bf70bab9be966473b2520644 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Jul 2013 09:07:21 +0000 Subject: Add "testfork" test command. Not used in any test-case yet --- unix/configure | 204 ++++++++++++++++++++++++++--------------------------- unix/configure.in | 2 +- unix/tclUnixTest.c | 50 +++++++++++++ 3 files changed, 153 insertions(+), 103 deletions(-) diff --git a/unix/configure b/unix/configure index 6faa7d8..9fa5673 100755 --- a/unix/configure +++ b/unix/configure @@ -5303,6 +5303,108 @@ echo "${ECHO_T}no (default)" >&6 +for ac_func in pthread_atfork +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ @@ -17439,108 +17541,6 @@ _ACEOF fi done - -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - fi cat >>confdefs.h <<\_ACEOF diff --git a/unix/configure.in b/unix/configure.in index e22a7d3..5a7125e 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -93,6 +93,7 @@ fi #------------------------------------------------------------------------ SC_ENABLE_THREADS +AC_CHECK_FUNCS(pthread_atfork) #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 @@ -513,7 +514,6 @@ if test "`uname -s`" = "Darwin" ; then if test $tcl_corefoundation = yes; then AC_CHECK_HEADERS(libkern/OSAtomic.h) AC_CHECK_FUNCS(OSSpinLockLock) - AC_CHECK_FUNCS(pthread_atfork) fi AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index b6529c2..2fc1647 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -66,6 +66,8 @@ static int TestfilewaitCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); static int TestfindexecutableCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); +static int TestforkObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST *argv); static int TestgetopenfileCmd(ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv); static int TestgetdefencdirCmd(ClientData dummy, @@ -110,6 +112,8 @@ TclplatformtestInit( (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd, (ClientData) 0, NULL); + Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd, + (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, (ClientData) 0, NULL); Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, @@ -533,6 +537,52 @@ TestsetdefencdirCmd( Tcl_SetDefaultEncodingDir(argv[1]); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestforkObjCmd -- + * + * This function implements the "testfork" command. It is used to + * fork the Tcl process for specific test cases. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestforkObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST *objv) /* Argument strings. */ +{ + pid_t pid; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + pid = fork(); + if (pid == -1) { + Tcl_AppendResult(interp, + "Cannot fork", NULL); + return TCL_ERROR; + } +#ifndef HAVE_PTHREAD_ATFORK + /* Only needed when pthread_atfork is not present. */ + if (pid==0) { + Tcl_InitNotifier(); + } +#endif + Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); + return TCL_OK; +} /* *---------------------------------------------------------------------- -- cgit v0.12