summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2013-04-29 09:31:53 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2013-04-29 09:31:53 (GMT)
commit1d75b0eb9444d42e7399a40853deb8bb47a88e4d (patch)
tree157750afa28177a9e7bdea789280ccf451698196
parent51ced0ecdafd3e996e1ce9de767b004ba5a9bfad (diff)
downloadtcl-1d75b0eb9444d42e7399a40853deb8bb47a88e4d.zip
tcl-1d75b0eb9444d42e7399a40853deb8bb47a88e4d.tar.gz
tcl-1d75b0eb9444d42e7399a40853deb8bb47a88e4d.tar.bz2
Improve code generation for [array set] in a common case.
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclCompCmds.c82
-rw-r--r--tests/set-old.test5
3 files changed, 69 insertions, 23 deletions
diff --git a/ChangeLog b/ChangeLog
index 0d8f622..9b2dc51 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2013-04-29 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCompCmds.c (TclCompileArraySetCmd): Generate better code
+ when the list of things to set is a literal.
+
2013-04-23 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclDecls.h: Implement Tcl_NewBooleanObj, Tcl_DbNewBooleanObj
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 40348fa..f6ca0e0 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -286,8 +286,10 @@ TclCompileArraySetCmd(
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *dataTokenPtr;
int simpleVarName, isScalar, localIndex;
+ int isDataLiteral, isDataValid, isDataEven, len;
int dataVar, iterVar, keyVar, valVar, infoIndex;
int back, fwd, offsetBack, offsetFwd, savedStackDepth;
+ Tcl_Obj *literalObj;
ForeachInfo *infoPtr;
if (parsePtr->numWords != 3) {
@@ -297,18 +299,22 @@ TclCompileArraySetCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
- dataTokenPtr = TokenAfter(varTokenPtr);
if (!isScalar) {
return TCL_ERROR;
}
+ dataTokenPtr = TokenAfter(varTokenPtr);
+ literalObj = Tcl_NewObj();
+ isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
+ isDataValid = (isDataLiteral
+ && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK);
+ isDataEven = (isDataValid && (len & 1) == 0);
/*
* Special case: literal empty value argument is just an "ensure array"
* operation.
*/
- if (dataTokenPtr->type == TCL_TOKEN_SIMPLE_WORD
- && dataTokenPtr[1].size == 0) {
+ if (isDataEven && len == 0) {
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
@@ -324,7 +330,24 @@ TclCompileArraySetCmd(
TclEmitOpcode( INST_POP, envPtr);
}
PushLiteral(envPtr, "", 0);
- return TCL_OK;
+ goto done;
+ }
+
+ /*
+ * Special case: literal odd-length argument is always an error.
+ */
+
+ if (isDataValid && !isDataEven) {
+ savedStackDepth = envPtr->currStackDepth;
+ PushLiteral(envPtr, "list must have an even number of elements",
+ strlen("list must have an even number of elements"));
+ PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
+ strlen("-errorCode {TCL ARGUMENT FORMAT}"));
+ TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr);
+ TclEmitInt4( 0, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ PushLiteral(envPtr, "", 0);
+ goto done;
}
/*
@@ -359,7 +382,7 @@ TclCompileArraySetCmd(
}
CompileWord(envPtr, dataTokenPtr, interp, 2);
TclEmitInstInt1(INST_INVOKE_STK1, 3, envPtr);
- return TCL_OK;
+ goto done;
}
infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
@@ -377,22 +400,31 @@ TclCompileArraySetCmd(
*/
CompileWord(envPtr, dataTokenPtr, interp, 2);
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- PushLiteral(envPtr, "1", 1);
- TclEmitOpcode( INST_BITAND, envPtr);
- offsetFwd = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
- savedStackDepth = envPtr->currStackDepth;
- PushLiteral(envPtr, "list must have an even number of elements",
- strlen("list must have an even number of elements"));
- PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
- strlen("-errorCode {TCL ARGUMENT FORMAT}"));
- TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr);
- TclEmitInt4( 0, envPtr);
- envPtr->currStackDepth = savedStackDepth;
- fwd = CurrentOffset(envPtr) - offsetFwd;
- TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ if (!isDataLiteral || !isDataValid) {
+ /*
+ * Only need this safety check if we're handling a non-literal or list
+ * containing an invalid literal; with valid list literals, we've
+ * already checked (worth it because literals are a very common
+ * use-case with [array set]).
+ */
+
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ PushLiteral(envPtr, "1", 1);
+ TclEmitOpcode( INST_BITAND, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
+ savedStackDepth = envPtr->currStackDepth;
+ PushLiteral(envPtr, "list must have an even number of elements",
+ strlen("list must have an even number of elements"));
+ PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
+ strlen("-errorCode {TCL ARGUMENT FORMAT}"));
+ TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr);
+ TclEmitInt4( 0, envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ }
Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
@@ -439,9 +471,13 @@ TclCompileArraySetCmd(
envPtr->currStackDepth = savedStackDepth;
TclEmitOpcode( INST_POP, envPtr);
}
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( dataVar, envPtr);
+ if (!isDataLiteral) {
+ TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( dataVar, envPtr);
+ }
PushLiteral(envPtr, "", 0);
+ done:
+ Tcl_DecrRefCount(literalObj);
return TCL_OK;
}
diff --git a/tests/set-old.test b/tests/set-old.test
index 52dc0ff..4c25ec5 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -678,6 +678,11 @@ test set-old-8.57 {array command, array get with trivial pattern} {
set a(y) 2
array get a x
} {x 1}
+test set-old-8.58 {array command, array set with LVT and odd length literal} {
+ list [catch {apply {{} {
+ array set a {b c d}
+ }}} msg] $msg
+} {1 {list must have an even number of elements}}
test set-old-9.1 {ids for array enumeration} {
catch {unset a}