diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | generic/tclAssembly.c | 3 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 199 | ||||
| -rw-r--r-- | generic/tclCompile.c | 288 | ||||
| -rw-r--r-- | generic/tclCompile.h | 36 | ||||
| -rw-r--r-- | generic/tclExecute.c | 62 |
6 files changed, 548 insertions, 53 deletions
@@ -1,3 +1,16 @@ +2013-05-10 Donal K. Fellows <dkf@users.sf.net> + + Optimizations and general bytecode generation improvements. + * generic/tclCompCmds.c (TclCompileAppendCmd, TclCompileLappendCmd): + (TclCompileReturnCmd): Make these generate bytecode in more cases. + (TclCompileListCmd): Make this able to push a literal when it can. + * generic/tclCompile.c (TclSetByteCodeFromAny, PeepholeOptimize): + Added checks to see if we can apply some simple cross-command-boundary + optimizations, and defined a small number of such optimizations. + (TclCompileScript): Added the special ability to compile the list + command with expansion ([list {*}blah]) into bytecode that does not + call an external command. + 2013-05-06 Jan Nijtmans <nijtmans@users.sf.net> * generic/tclStubInit.c: Add support for Cygwin64, which has a 64-bit diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 5786975..cd2ad13 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -20,7 +20,7 @@ *- break and continue - if exception ranges can be sorted out. *- foreach_start4, foreach_step4 *- returnImm, returnStk - *- expandStart, expandStkTop, invokeExpanded + *- expandStart, expandStkTop, invokeExpanded, listExpanded *- dictFirst, dictNext, dictDone *- dictUpdateStart, dictUpdateEnd *- jumpTable testing @@ -437,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = { {"lindexMulti", ASSEM_LINDEX_MULTI, INST_LIST_INDEX_MULTI, INT_MIN,1}, {"list", ASSEM_LIST, INST_LIST, INT_MIN,1}, + {"listConcat", ASSEM_1BYTE, INST_LIST_CONCAT, 2, 1}, {"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1}, {"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1}, {"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f6ca0e0..9ffdbc3 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -155,7 +155,7 @@ TclCompileAppendCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int simpleVarName, isScalar, localIndex, numWords; + int simpleVarName, isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; @@ -169,10 +169,11 @@ TclCompileAppendCmd( return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr); } else if (numWords > 3) { /* - * APPEND instructions currently only handle one value. + * APPEND instructions currently only handle one value, but we can + * handle some multi-value cases by stringing them together. */ - return TCL_ERROR; + goto appendMultiple; } /* @@ -222,6 +223,42 @@ TclCompileAppendCmd( } return TCL_OK; + + appendMultiple: + /* + * Can only handle the case where we are appending to a local scalar when + * there are multiple values to append. Fortunately, this is common. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar || localIndex < 0) { + return TCL_ERROR; + } + + /* + * Definitely appending to a local scalar; generate the words and append + * them. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + for (i = 2 ; i < numWords ; i++) { + CompileWord(envPtr, valueTokenPtr, interp, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr); + for (i = 2 ; i < numWords ;) { + Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr); + if (++i < numWords) { + TclEmitOpcode(INST_POP, envPtr); + } + } + + return TCL_OK; } /* @@ -4067,8 +4104,8 @@ TclCompileLappendCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *varTokenPtr; - int simpleVarName, isScalar, localIndex, numWords; + Tcl_Token *varTokenPtr, *valueTokenPtr; + int simpleVarName, isScalar, localIndex, numWords, i, fwd, offsetFwd; DefineLineInformation; /* TIP #280 */ /* @@ -4085,10 +4122,11 @@ TclCompileLappendCmd( } if (numWords != 3) { /* - * LAPPEND instructions currently only handle one value appends. + * LAPPEND instructions currently only handle one value, but we can + * handle some multi-value cases by stringing them together. */ - return TCL_ERROR; + goto lappendMultiple; } /* @@ -4141,6 +4179,45 @@ TclCompileLappendCmd( } return TCL_OK; + + lappendMultiple: + /* + * Can only handle the case where we are appending to a local scalar when + * there are multiple values to append. Fortunately, this is common. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &simpleVarName, &isScalar, 1); + if (!isScalar || localIndex < 0) { + return TCL_ERROR; + } + + /* + * Definitely appending to a local scalar; generate the words and append + * them. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + for (i = 2 ; i < numWords ; i++) { + CompileWord(envPtr, valueTokenPtr, interp, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + TclEmitInstInt4( INST_LIST, numWords-2, envPtr); + TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + + return TCL_OK; } /* @@ -4390,14 +4467,7 @@ TclCompileListCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr; int i, numWords; - - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } + Tcl_Obj *listObj, *objPtr; if (parsePtr->numWords == 1) { /* @@ -4405,20 +4475,57 @@ TclCompileListCmd( */ PushLiteral(envPtr, "", 0); - } else { - /* - * Push the all values onto the stack. - */ + return TCL_OK; + } + + /* + * Test if all arguments are compile-time known. If they are, we can + * implement with a simple push. + */ - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i = 1; i < numWords; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); - valueTokenPtr = TokenAfter(valueTokenPtr); + numWords = parsePtr->numWords; + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + listObj = Tcl_NewObj(); + for (i = 1; i < numWords && listObj != NULL; i++) { + objPtr = Tcl_NewObj(); + if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) { + (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); + } else { + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(listObj); + listObj = NULL; } - TclEmitInstInt4( INST_LIST, numWords - 1, envPtr); + valueTokenPtr = TokenAfter(valueTokenPtr); } + if (listObj != NULL) { + int len; + const char *bytes = Tcl_GetStringFromObj(listObj, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(listObj); + if (len > 0) { + /* + * Force list interpretation! + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + return TCL_OK; + } + + /* + * Push the all values onto the stack. + */ + + numWords = parsePtr->numWords; + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 1; i < numWords; i++) { + CompileWord(envPtr, valueTokenPtr, interp, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + TclEmitInstInt4( INST_LIST, numWords - 1, envPtr); return TCL_OK; } @@ -5578,15 +5685,20 @@ TclCompileReturnCmd( objv[objc] = Tcl_NewObj(); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - objc++; - status = TCL_ERROR; - goto cleanup; + /* + * Non-literal, so punt to run-time. + */ + + for (; objc>=0 ; objc--) { + TclDecrRefCount(objv[objc]); + } + TclStackFree(interp, objv); + goto issueRuntimeReturn; } wordTokenPtr = TokenAfter(wordTokenPtr); } status = TclMergeReturnOptions(interp, objc, objv, &returnOpts, &code, &level); - cleanup: while (--objc >= 0) { TclDecrRefCount(objv[objc]); } @@ -5667,6 +5779,35 @@ TclCompileReturnCmd( CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); return TCL_OK; + + issueRuntimeReturn: + /* + * Assemble the option dictionary (as a list as that's good enough). + */ + + wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (objc=1 ; objc<=numOptionWords ; objc++) { + CompileWord(envPtr, wordTokenPtr, interp, objc); + wordTokenPtr = TokenAfter(wordTokenPtr); + } + TclEmitInstInt4(INST_LIST, numOptionWords, envPtr); + + /* + * Push the result. + */ + + if (explicitResult) { + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + } else { + PushLiteral(envPtr, "", 0); + } + + /* + * Issue the RETURN itself. + */ + + TclEmitOpcode(INST_RETURN_STK, envPtr); + return TCL_OK; } static void diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 0e98385..1da6e03 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -14,6 +14,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Table of all AuxData types. @@ -50,7 +51,7 @@ static int traceInitialized = 0; * existence of a procedure call frame to distinguish these. */ -InstructionDesc const tclInstructionTable[] = { +const InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ @@ -279,12 +280,12 @@ InstructionDesc const tclInstructionTable[] = { /* Binary exponentiation operator: push (stknext ** stktop) */ /* - * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong - - * but it cannot be done right at compile time, the stack effect is only - * known at run time. The value for invokeExpanded is estimated better at - * compile time. + * NOTE: the stack effects of expandStkTop, invokeExpanded and + * listExpanded are wrong - but it cannot be done right at compile time, + * the stack effect is only known at run time. The value for both + * invokeExpanded and listExpanded are estimated better at compile time. * See the comments further down in this file, where INST_INVOKE_EXPANDED - * is emitted. + * and INST_LIST_EXPANDED are emitted. */ {"expandStart", 1, 0, 0, {OPERAND_NONE}}, /* Start of command with {*} (expanded) arguments */ @@ -534,6 +535,13 @@ InstructionDesc const tclInstructionTable[] = { * the word at the top of the stack; * <objc,objv> = <op4,top op4 after popping 1> */ + {"listConcat", 1, -1, 0, {OPERAND_NONE}}, + /* Concatenates the two lists at the top of the stack into a single + * list and pushes that resulting list onto the stack. + * Stack: ... list1 list2 => ... [lconcat list1 list2] */ + {"listExpanded", 1, 0, 0, {OPERAND_NONE}}, + /* Construct a list from the words marked by the last 'expandStart' */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -554,6 +562,9 @@ static void EnterCmdStartData(CompileEnv *envPtr, static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); +static int IsCompactibleCompileEnv(Tcl_Interp *interp, + CompileEnv *envPtr); +static void PeepholeOptimize(CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ @@ -654,6 +665,7 @@ TclSetByteCodeFromAny( * in frame. */ int length, result = TCL_OK; const char *stringPtr; + Proc *procPtr = iPtr->compiledProcPtr; ContLineLoc *clLocPtr; #ifdef TCL_COMPILE_DEBUG @@ -705,6 +717,38 @@ TclSetByteCodeFromAny( TclEmitOpcode(INST_DONE, &compEnv); /* + * Check for optimizations! + * + * Test if the generated code is free of most hazards; if so, recompile + * but with generation of INST_START_CMD disabled. This produces somewhat + * faster code in some cases, and more compact code in more. + */ + + if (Tcl_GetMaster(interp) == NULL && + !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME) + && IsCompactibleCompileEnv(interp, &compEnv)) { + TclFreeCompileEnv(&compEnv); + iPtr->compiledProcPtr = procPtr; + TclInitCompileEnv(interp, &compEnv, stringPtr, length, + iPtr->invokeCmdFramePtr, iPtr->invokeWord); + if (clLocPtr) { + compEnv.clLoc = clLocPtr; + compEnv.clNext = &compEnv.clLoc->loc[0]; + Tcl_Preserve(compEnv.clLoc); + } + compEnv.atCmdStart = 2; /* The disabling magic. */ + TclCompileScript(interp, stringPtr, length, &compEnv); + TclEmitOpcode(INST_DONE, &compEnv); + } + + /* + * Apply some peephole optimizations that can cross specific/generic + * instruction generator boundaries. + */ + + PeepholeOptimize(&compEnv); + + /* * Invoke the compilation hook procedure if one exists. */ @@ -973,6 +1017,202 @@ TclCleanupByteCode( } /* + * --------------------------------------------------------------------- + * + * IsCompactibleCompileEnv -- + * + * Checks to see if we may apply some basic compaction optimizations to a + * piece of bytecode. Idempotent. + * + * --------------------------------------------------------------------- + */ + +static int +IsCompactibleCompileEnv( + Tcl_Interp *interp, + CompileEnv *envPtr) +{ + unsigned char *pc; + int size; + + /* + * Special: procedures in the '::tcl' namespace (or its children) are + * considered to be well-behaved and so can have compaction applied even + * if it would otherwise be invalid. + */ + + if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL + && envPtr->procPtr->cmdPtr->nsPtr != NULL) { + Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr; + + if (strcmp(nsPtr->fullName, "::tcl") == 0 + || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) { + return 1; + } + } + + /* + * Go through and ensure that no operation involved can cause a desired + * change of bytecode sequence during running. This comes down to ensuring + * that there are no mapped variables (due to traces) or calls to external + * commands (traces, [uplevel] trickery). This is actually a very + * conservative check; it turns down a lot of code that is OK in practice. + */ + + for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { + switch (*pc) { + /* Invokes */ + case INST_INVOKE_STK1: + case INST_INVOKE_STK4: + case INST_INVOKE_EXPANDED: + case INST_INVOKE_REPLACE: + return 0; + /* Runtime evals */ + case INST_EVAL_STK: + case INST_EXPR_STK: + case INST_YIELD: + return 0; + /* Upvars */ + case INST_UPVAR: + case INST_NSUPVAR: + case INST_VARIABLE: + return 0; + } + size = tclInstructionTable[*pc].numBytes; + assert (size > 0); + } + + return 1; +} + +/* + * ---------------------------------------------------------------------- + * + * PeepholeOptimize -- + * + * A very simple peephole optimizer for bytecode. + * + * ---------------------------------------------------------------------- + */ + +static void +PeepholeOptimize( + CompileEnv *envPtr) +{ + unsigned char *pc, *prev1 = NULL, *prev2 = NULL, *target; + int size, isNew; + Tcl_HashTable targets; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + /* + * Find places where we should be careful about replacing instructions + * because they are the targets of various types of jumps. + */ + + Tcl_InitHashTable(&targets, TCL_ONE_WORD_KEYS); + for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { + size = tclInstructionTable[*pc].numBytes; + switch (*pc) { + case INST_JUMP1: + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + target = pc + TclGetInt1AtPtr(pc+1); + goto storeTarget; + case INST_JUMP4: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + target = pc + TclGetInt4AtPtr(pc+1); + goto storeTarget; + case INST_BEGIN_CATCH4: + target = envPtr->codeStart + envPtr->exceptArrayPtr[ + TclGetUInt4AtPtr(pc+1)].codeOffset; + storeTarget: + (void) Tcl_CreateHashEntry(&targets, (void *) target, &isNew); + break; + case INST_JUMP_TABLE: + hPtr = Tcl_FirstHashEntry( + &JUMPTABLEINFO(envPtr, pc+1)->hashTable, &hSearch); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { + target = pc + (int) Tcl_GetHashValue(hPtr); + (void) Tcl_CreateHashEntry(&targets, (void *) target, &isNew); + } + break; + } + } + + /* + * Replace PUSH/POP sequences (when non-hazardous) with NOPs. + */ + + (void) Tcl_CreateHashEntry(&targets, (void *) pc, &isNew); + for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { + int blank = 0, i; + + size = tclInstructionTable[*pc].numBytes; + prev2 = prev1; + prev1 = pc; + if (Tcl_FindHashEntry(&targets, (void *) (pc + size))) { + continue; + } + switch (*pc) { + case INST_PUSH1: + while (*(pc+size) == INST_NOP) { + size++; + } + if (*(pc+size) == INST_POP) { + blank = size + 1; + } else if (*(pc+size) == INST_CONCAT1 + && TclGetUInt1AtPtr(pc + size + 1) == 2) { + Tcl_Obj *litPtr = TclFetchLiteral(envPtr, + TclGetUInt1AtPtr(pc + 1)); + int numBytes; + + (void) Tcl_GetStringFromObj(litPtr, &numBytes); + if (numBytes == 0) { + blank = size + 2; + } + } + break; + case INST_PUSH4: + while (*(pc+size) == INST_NOP) { + size++; + } + if (*(pc+size) == INST_POP) { + blank = size + 1; + } else if (*(pc+size) == INST_CONCAT1 + && TclGetUInt1AtPtr(pc + size + 1) == 2) { + Tcl_Obj *litPtr = TclFetchLiteral(envPtr, + TclGetUInt4AtPtr(pc + 1)); + int numBytes; + + (void) Tcl_GetStringFromObj(litPtr, &numBytes); + if (numBytes == 0) { + blank = size + 2; + } + } + break; + } + if (blank > 0) { + for (i=0 ; i<blank ; i++) { + *(pc + i) = INST_NOP; + } + size = blank; + } + } + + /* + * Trim a trailing double DONE. + */ + + if (prev1 && prev2 && *prev1 == INST_DONE && *prev2 == INST_DONE + && !Tcl_FindHashEntry(&targets, (void *) prev1)) { + envPtr->codeNext--; + } + Tcl_DeleteHashTable(&targets); +} + +/* *---------------------------------------------------------------------- * * Tcl_SubstObj -- @@ -1194,6 +1434,8 @@ TclInitCompileEnv( { Interp *iPtr = (Interp *) interp; + assert(tclInstructionTable[LAST_INST_OPCODE].name == NULL); + envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; @@ -1689,7 +1931,7 @@ TclCompileScript( wordIdx < parsePtr->numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; + expand = INST_INVOKE_EXPANDED; break; } } @@ -1802,7 +2044,7 @@ TclCompileScript( * command. */ - if (envPtr->atCmdStart) { + if (envPtr->atCmdStart == 1) { if (savedCodeNext != 0) { /* * Increase the number of commands being @@ -1816,7 +2058,7 @@ TclCompileScript( TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1, fixPtr); } - } else { + } else if (envPtr->atCmdStart == 0) { TclEmitInstInt4(INST_START_CMD, 0, envPtr); TclEmitInt4(1, envPtr); update = 1; @@ -1860,7 +2102,7 @@ TclCompileScript( goto finishCommand; } - if (envPtr->atCmdStart && savedCodeNext != 0) { + if (envPtr->atCmdStart == 1 && savedCodeNext != 0) { /* * Decrease the number of commands being started * at the current point. Note that this depends on @@ -1899,6 +2141,25 @@ TclCompileScript( TclFetchLiteral(envPtr, objIndex), cmdPtr); } } else { + if (wordIdx == 0 && expand) { + TclDStringClear(&ds); + TclDStringAppendToken(&ds, &tokenPtr[1]); + cmdPtr = (Command *) Tcl_FindCommand(interp, + Tcl_DStringValue(&ds), + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + if ((cmdPtr != NULL) && + (cmdPtr->compileProc == TclCompileListCmd)) { + /* + * Special case! [list] command can be expanded + * directly provided the first word is not the + * expanded one. + */ + + expand = INST_LIST_EXPANDED; + continue; + } + } + /* * Simple argument word of a command. We reach this if and * only if the command word was not compiled for whatever @@ -1941,9 +2202,12 @@ TclCompileScript( * Note that the estimates are not correct while the command * is being prepared and run, INST_EXPAND_STKTOP is not * stack-neutral in general. + * + * The opcodes that may be issued here (both assumed to be + * non-zero) are INST_INVOKE_EXPANDED and INST_LIST_EXPANDED. */ - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + TclEmitOpcode(expand, envPtr); TclAdjustStackDepth((1-wordIdx), envPtr); } else if (wordIdx > 0) { /* @@ -3692,7 +3956,7 @@ TclInitAuxDataTypeTable(void) Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); /* - * There are only two AuxData type at this time, so register them here. + * There are only three AuxData types at this time, so register them here. */ RegisterAuxDataType(&tclForeachInfoType); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 79497d2..c68d3ec 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -309,7 +309,9 @@ typedef struct CompileEnv { int atCmdStart; /* Flag to say whether an INST_START_CMD * should be issued; they should never be * issued repeatedly, as that is significantly - * inefficient. */ + * inefficient. If set to 2, that instruction + * should not be issued at all (by the generic + * part of the command compiler). */ ContLineLoc *clLoc; /* If not NULL, the table holding the * locations of the invisible continuation * lines in the input script, to adjust the @@ -713,8 +715,11 @@ typedef struct ByteCode { #define INST_INVOKE_REPLACE 163 +#define INST_LIST_CONCAT 164 +#define INST_LIST_EXPANDED 165 + /* The last opcode */ -#define LAST_INST_OPCODE 163 +#define LAST_INST_OPCODE 165 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -848,6 +853,9 @@ typedef struct ForeachInfo { MODULE_SCOPE const AuxDataType tclForeachInfoType; +#define FOREACHINFO(envPtr, index) \ + ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) + /* * Structure used to hold information about a switch command that is needed * during program execution. These structures are stored in CompileEnv and @@ -861,6 +869,9 @@ typedef struct JumptableInfo { MODULE_SCOPE const AuxDataType tclJumptableInfoType; +#define JUMPTABLEINFO(envPtr, index) \ + ((JumptableInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) + /* * Structure used to hold information about a [dict update] command that is * needed during program execution. These structures are stored in CompileEnv @@ -879,6 +890,9 @@ typedef struct { MODULE_SCOPE const AuxDataType tclDictUpdateInfoType; +#define DICTUPDATEINFO(envPtr, index) \ + ((DictUpdateInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) + /* * ClientData type used by the math operator commands. */ @@ -1090,6 +1104,18 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); } while (0) /* + * Macros used to update the flag that indicates if we are at the start of a + * command, based on whether the opcode is INST_START_COMMAND. + * + * void TclUpdateAtCmdStart(unsigned char op, CompileEnv *envPtr); + */ + +#define TclUpdateAtCmdStart(op, envPtr) \ + if ((envPtr)->atCmdStart < 2) { \ + (envPtr)->atCmdStart = ((op) == INST_START_CMD ? 1 : 0); \ + } + +/* * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C * "prototype" for this macro is: * @@ -1102,7 +1128,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); TclExpandCodeArray(envPtr); \ } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, 0, envPtr); \ } while (0) @@ -1154,7 +1180,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, i, envPtr); \ } while (0) @@ -1172,7 +1198,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); (unsigned char) ((unsigned int) (i) >> 8); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) ); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, i, envPtr); \ } while (0) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 029f402..afde900 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2338,6 +2338,14 @@ TEBCresume( } inst = *(pc += 9); goto peepholeStart; + } else if (inst == INST_NOP) { +#ifndef TCL_COMPILE_DEBUG + while (inst == INST_NOP) +#endif + { + inst = *++pc; + } + goto peepholeStart; } switch (inst) { @@ -2369,14 +2377,28 @@ TEBCresume( TRACE(("=> ")); objResultPtr = POP_OBJECT(); result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; if (result == TCL_OK) { + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", O2S(objResultPtr))); NEXT_INST_F(1, 0, 0); + } else if (result == TCL_ERROR) { + /* + * BEWARE! Must do this in this order, because an error in the + * option dictionary overrides the result (and can be verified by + * test). + */ + + Tcl_SetObjResult(interp, objResultPtr); + Tcl_SetReturnOptions(interp, OBJ_AT_TOS); + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + } else { + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + Tcl_SetObjResult(interp, objResultPtr); } - Tcl_SetObjResult(interp, objResultPtr); cleanup = 1; goto processExceptionReturn; @@ -2501,9 +2523,6 @@ TEBCresume( TclDecrRefCount(objPtr); NEXT_INST_F(1, 0, 0); - case INST_NOP: - NEXT_INST_F(1, 0, 0); - case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); @@ -4418,6 +4437,14 @@ TEBCresume( TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(5, opnd, 1); + case INST_LIST_EXPANDED: + CLANG_ASSERT(auxObjList); + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; + POP_TAUX_OBJ(); + objResultPtr = Tcl_NewListObj(objc, &OBJ_AT_DEPTH(objc-1)); + TRACE_WITH_OBJ(("(%u) => ", objc), objResultPtr); + NEXT_INST_V(1, objc, 1); + case INST_LIST_LENGTH: valuePtr = OBJ_AT_TOS; if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) { @@ -4763,6 +4790,29 @@ TEBCresume( objResultPtr = TCONST(match); NEXT_INST_F(0, 2, 1); + case INST_LIST_CONCAT: + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + if (Tcl_ListObjAppendList(interp, objResultPtr, + value2Ptr) != TCL_OK) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TclDecrRefCount(objResultPtr); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } else { + if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); + } + /* * End of INST_LIST and related instructions. * ----------------------------------------------------------------- |