summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2013-05-12 00:44:22 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2013-05-12 00:44:22 (GMT)
commit1ca1aefb24495d43ae986af6c1a2ad1fa5bf22ce (patch)
treef9eb716588b605bb661c61135b0ad0cf6dde8984
parentebbffb3ea5b1b5609e3fb86ddea543aa3d24693d (diff)
parentd7477a9621b19997f770d8df75b8a071704973d0 (diff)
downloadtcl-1ca1aefb24495d43ae986af6c1a2ad1fa5bf22ce.zip
tcl-1ca1aefb24495d43ae986af6c1a2ad1fa5bf22ce.tar.gz
tcl-1ca1aefb24495d43ae986af6c1a2ad1fa5bf22ce.tar.bz2
Optimizations and general bytecode generation improvements.
-rw-r--r--ChangeLog13
-rw-r--r--generic/tclAssembly.c3
-rw-r--r--generic/tclCompCmds.c202
-rw-r--r--generic/tclCompile.c298
-rw-r--r--generic/tclCompile.h36
-rw-r--r--generic/tclExecute.c66
6 files changed, 564 insertions, 54 deletions
diff --git a/ChangeLog b/ChangeLog
index 6330666..bcd089d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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..c2495bd 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);
+ 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;
+ }
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ if (listObj != NULL) {
+ int len;
+ const char *bytes = Tcl_GetStringFromObj(listObj, &len);
- numWords = parsePtr->numWords;
- valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
- for (i = 1; i < numWords; i++) {
- CompileWord(envPtr, valueTokenPtr, interp, i);
- valueTokenPtr = TokenAfter(valueTokenPtr);
+ 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);
}
- TclEmitInstInt4( INST_LIST, numWords - 1, 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]);
}
@@ -5649,6 +5761,7 @@ TclCompileReturnCmd(
Tcl_DecrRefCount(returnOpts);
TclEmitOpcode(INST_DONE, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
return TCL_OK;
}
}
@@ -5666,6 +5779,37 @@ TclCompileReturnCmd(
*/
CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
+ envPtr->currStackDepth = savedStackDepth + 1;
+ 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);
+ envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 0e98385..7f6b7d4 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+1].name == NULL);
+
envPtr->iPtr = iPtr;
envPtr->source = stringPtr;
envPtr->numSrcBytes = numBytes;
@@ -1637,6 +1879,13 @@ TclCompileScript(
if (parsePtr->numWords > 0) {
int expand = 0; /* Set if there are dynamic expansions to
* handle */
+ int expandIgnoredWords = 0;
+ /* The number of *apparent* words that we are
+ * generating code from directly during
+ * expansion processing. For [list {*}blah]
+ * expansion, we set this to one because we
+ * ignore the first word and generate code
+ * directly. */
/*
* If not the first command, pop the previous command's result
@@ -1689,7 +1938,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 +2051,7 @@ TclCompileScript(
* command.
*/
- if (envPtr->atCmdStart) {
+ if (envPtr->atCmdStart == 1) {
if (savedCodeNext != 0) {
/*
* Increase the number of commands being
@@ -1816,7 +2065,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 +2109,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 +2148,26 @@ 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;
+ expandIgnoredWords = 1;
+ continue;
+ }
+ }
+
/*
* Simple argument word of a command. We reach this if and
* only if the command word was not compiled for whatever
@@ -1941,10 +2210,13 @@ 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);
- TclAdjustStackDepth((1-wordIdx), envPtr);
+ TclEmitOpcode(expand, envPtr);
+ TclAdjustStackDepth(1 + expandIgnoredWords - wordIdx, envPtr);
} else if (wordIdx > 0) {
/*
* Save PC -> command map for the TclArgumentBC* functions.
@@ -3692,7 +3964,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..f994ba5 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,18 @@ 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);
+ while (objc--) {
+ valuePtr = POP_OBJECT();
+ TclDecrRefCount(valuePtr);
+ }
+ NEXT_INST_F(1, 0, 1);
+
case INST_LIST_LENGTH:
valuePtr = OBJ_AT_TOS;
if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) {
@@ -4763,6 +4794,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.
* -----------------------------------------------------------------