From 1bd8f407a5fc44a8b7a54bb78d8d29a2e5b0358f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 18 Jul 2014 12:18:44 +0000 Subject: [b43f2b49f7] New compilation strategy for lappend that allows multi-value lappend to not have quadratic performance (through better reference management). --- generic/tclAssembly.c | 4 ++ generic/tclCompCmdsGR.c | 60 +++++------------ generic/tclCompile.c | 13 ++++ generic/tclCompile.h | 7 +- generic/tclExecute.c | 167 +++++++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 206 insertions(+), 45 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index d1866c8..6d5676b 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -410,6 +410,10 @@ static const TalInstDesc TalInstructionTable[] = { {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 | INST_LAPPEND_ARRAY4),2, 1}, {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, + {"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1}, + {"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1}, + {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1}, + {"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 1}, {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, {"le", ASSEM_1BYTE, INST_LE, 2, 1}, {"lindexMulti", ASSEM_LINDEX_MULTI, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index b3e273f..166fea0 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -868,28 +868,16 @@ TclCompileLappendCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i, fwd, offsetFwd; + int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; } - if (numWords != 3) { - /* - * LAPPEND instructions currently only handle one value, but we can - * handle some multi-value cases by stringing them together. - */ + if (numWords != 3 || envPtr->procPtr == NULL) { goto lappendMultiple; } @@ -943,42 +931,28 @@ 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, + PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &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); - + TclEmitInstInt4( INST_LIST, numWords-2, envPtr); + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_LIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr); + } + } return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 347e3f0..838b195 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -650,6 +650,19 @@ InstructionDesc const tclInstructionTable[] = { * satisfy the class check (standard definition of "all"). * Stack: ... stringValue => ... boolean */ + {"lappendList", 5, 0, 1, {OPERAND_LVT4}}, + /* Lappend list to scalar variable at op4 in frame. + * Stack: ... list => ... listVarContents */ + {"lappendListArray", 5, -1, 1, {OPERAND_LVT4}}, + /* Lappend list to array element; array at op4. + * Stack: ... elem list => ... listVarContents */ + {"lappendListArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Lappend list to array element. + * Stack: ... arrayName elem list => ... listVarContents */ + {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, + /* Lappend list to general variable. + * Stack: ... varName list => ... listVarContents */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5665ca9..fa4a360 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -799,8 +799,13 @@ typedef struct ByteCode { #define INST_TRY_CVT_TO_BOOLEAN 183 #define INST_STR_CLASS 184 +#define INST_LAPPEND_LIST 185 +#define INST_LAPPEND_LIST_ARRAY 186 +#define INST_LAPPEND_LIST_ARRAY_STK 187 +#define INST_LAPPEND_LIST_STK 188 + /* The last opcode */ -#define LAST_INST_OPCODE 184 +#define LAST_INST_OPCODE 188 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0cd074d..2098e50 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3347,7 +3347,7 @@ TEBCresume( */ { - int storeFlags; + int storeFlags, len; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3587,6 +3587,171 @@ TEBCresume( #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); + + case INST_LAPPEND_LIST: + opnd = TclGetUInt4AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + varPtr = LOCAL(opnd); + cleanup = 1; + pcAdjustment = 5; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (TclIsVarDirectReadable(varPtr) + && TclIsVarDirectWritable(varPtr)) { + goto lappendListDirect; + } + arrayPtr = NULL; + part1Ptr = part2Ptr = NULL; + goto lappendListPtr; + + case INST_LAPPEND_LIST_ARRAY: + opnd = TclGetUInt4AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + part1Ptr = NULL; + part2Ptr = OBJ_UNDER_TOS; + arrayPtr = LOCAL(opnd); + cleanup = 2; + pcAdjustment = 5; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" \"%.30s\" => ", + opnd, O2S(part2Ptr), O2S(valuePtr))); + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr) + && !WriteTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (varPtr && TclIsVarDirectReadable(varPtr) + && TclIsVarDirectWritable(varPtr)) { + goto lappendListDirect; + } + } + varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); + if (varPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; + } + goto lappendListPtr; + + case INST_LAPPEND_LIST_ARRAY_STK: + pcAdjustment = 1; + cleanup = 3; + valuePtr = OBJ_AT_TOS; + part2Ptr = OBJ_UNDER_TOS; /* element name */ + part1Ptr = OBJ_AT_DEPTH(2); /* array name */ + TRACE(("\"%.30s(%.30s)\" \"%.30s\" => ", + O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); + goto lappendList; + + case INST_LAPPEND_LIST_STK: + pcAdjustment = 1; + cleanup = 2; + valuePtr = OBJ_AT_TOS; + part2Ptr = NULL; + part1Ptr = OBJ_UNDER_TOS; /* variable name */ + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr))); + goto lappendList; + + lappendListDirect: + objResultPtr = varPtr->value.objPtr; + if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (Tcl_IsShared(objResultPtr)) { + Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr); + + TclDecrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr = newValue; + Tcl_IncrRefCount(newValue); + } + if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + + lappendList: + opnd = -1; + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + DECACHE_STACK_INFO(); + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); + CACHE_STACK_INFO(); + if (!varPtr) { + TRACE_ERROR(interp); + goto gotError; + } + + lappendListPtr: + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)++; + } + DECACHE_STACK_INFO(); + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, + part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)--; + } + + { + int createdNewObj = 0; + + if (!objResultPtr) { + objResultPtr = valuePtr; + } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } else { + if (Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + createdNewObj = 1; + } + if (Tcl_ListObjReplace(interp, objResultPtr, len,0, objc,objv) + != TCL_OK) { + goto errorInLappendListPtr; + } + } + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, objResultPtr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (!objResultPtr) { + errorInLappendListPtr: + if (createdNewObj) { + TclDecrRefCount(objResultPtr); + } + TRACE_ERROR(interp); + goto gotError; + } + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); } /* -- cgit v0.12