Improve code generation for [array set] in a common case.

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}