From 0f6d3fd95989e7b5c22a40bbdc90631e3ae10bc1 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Thu, 28 Dec 2017 23:54:57 +0000 Subject: Optimise lrange for unshared object. --- generic/tclExecute.c | 13 +++++++ tests/lrange.test | 102 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 115 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f2cda0c..0f501b9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5140,12 +5140,25 @@ TEBCresume( if (toIdx >= objc) { toIdx = objc-1; } + + /* + * If we are just removing the beginning or the end from an + * unshared object, Tcl_ListObjReplace is very efficient, and also + * guarantees a pure list. + */ + if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { Tcl_ListObjReplace(interp, valuePtr, toIdx + 1, LIST_MAX, 0, NULL); TRACE_APPEND(("%.30s\n", O2S(valuePtr))); NEXT_INST_F(9, 0, 0); } + if (toIdx == objc-1 && !Tcl_IsShared(valuePtr)) { + Tcl_ListObjReplace(interp, valuePtr, + 0, fromIdx, 0, NULL); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(9, 0, 0); + } objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); } else { TclNewObj(objResultPtr); diff --git a/tests/lrange.test b/tests/lrange.test index 02b9c65..0b1a7ca 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -90,6 +90,108 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} { lrange $l 0 end-5 }} {1 2 3 4 5} } {} + +test lrange-4.1 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # Shared + set ll2 $ll1 + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get new pure object + set x [lrange $ll1 0 end] + set rep2 [tcl::unsupported::representation $x] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Check for a new clean object +} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} + +test lrange-4.2 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # Shared + set ll2 $ll1 + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get new pure object, not compiled + set x [[string cat l range] $ll1 0 end] + set rep2 [tcl::unsupported::representation $x] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Check for a new clean object +} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} + +test lrange-4.3 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get pure object, unshared + set ll2 [lrange $ll1[set ll1 {}] 0 end] + set rep2 [tcl::unsupported::representation $ll2] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Internal optimisations should keep the same object +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} + +test lrange-4.4 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get pure object, unshared, not compiled + set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end] + set rep2 [tcl::unsupported::representation $ll2] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Internal optimisations should keep the same object +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} + +# Testing for compiled vs non-compiled behaviour, and shared vs non-shared. +# Far too many variations to check with spelt-out tests. +# Note that this *just* checks whether the different versions are the same +# not whether any of them is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lrange lrange + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + # Shared, uncompiled + set ls2 $ls + set expected [list [catch {$lrange $ls $a $b} m] $m] + # Shared, compiled + set tester [list lrange $ls $a $b] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.[incr n].1 {lrange shared compiled} \ + [list apply [list {} $script]] $expected + # Unshared, uncompiled + set tester [string map [list %l [list $ls] %a $a %b $b] { + [string cat l range] [lrange %l 0 end] %a %b + }] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.$n.2 {lrange unshared uncompiled} \ + [list apply [list {} $script]] $expected + # Unshared, compiled + set tester [string map [list %l [list $ls] %a $a %b $b] { + lrange [lrange %l 0 end] %a %b + }] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.$n.3 {lrange unshared compiled} \ + [list apply [list {} $script]] $expected + } + } + } +}} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 651697f7cd746dded1a031d4217376000a176037 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Fri, 29 Dec 2017 18:58:01 +0000 Subject: Refactored lrange to common function. --- generic/tclCmdIL.c | 44 +--------------------------- generic/tclExecute.c | 40 ++------------------------ generic/tclInt.h | 2 ++ generic/tclListObj.c | 81 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 87 insertions(+), 80 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b41d312..001b62d 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2543,7 +2543,6 @@ Tcl_LrangeObjCmd( register Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj **elemPtrs; int listLen, first, last, result; if (objc != 4) { @@ -2561,55 +2560,14 @@ Tcl_LrangeObjCmd( if (result != TCL_OK) { return result; } - if (first < 0) { - first = 0; - } result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, &last); if (result != TCL_OK) { return result; } - if (last >= listLen) { - last = listLen - 1; - } - - if (first > last) { - /* - * Returning an empty list is easy. - */ - - return TCL_OK; - } - - result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - - if (Tcl_IsShared(objv[1]) || - ((ListRepPtr(objv[1])->refCount > 1))) { - Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1, - &elemPtrs[first])); - } else { - /* - * In-place is possible. - */ - - if (last < (listLen - 1)) { - Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last, - 0, NULL); - } - - /* - * This one is not conditioned on (first > 0) in order to preserve the - * string-canonizing effect of [lrange 0 end]. - */ - - Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL); - Tcl_SetObjResult(interp, objv[1]); - } + Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0f501b9..8568642 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5087,11 +5087,11 @@ TEBCresume( TclGetInt4AtPtr(pc+5))); /* - * Get the contents of the list, making sure that it really is a list + * Get the length of the list, making sure that it really is a list * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -5128,41 +5128,7 @@ TEBCresume( toIdx = objc; } - /* - * Check if we are referring to a valid, non-empty list range, and if - * so, build the list of elements in that range. - */ - - if (fromIdx<=toIdx && fromIdx=0) { - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= objc) { - toIdx = objc-1; - } - - /* - * If we are just removing the beginning or the end from an - * unshared object, Tcl_ListObjReplace is very efficient, and also - * guarantees a pure list. - */ - - if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { - Tcl_ListObjReplace(interp, valuePtr, - toIdx + 1, LIST_MAX, 0, NULL); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); - } - if (toIdx == objc-1 && !Tcl_IsShared(valuePtr)) { - Tcl_ListObjReplace(interp, valuePtr, - 0, fromIdx, 0, NULL); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); - } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); - } else { - TclNewObj(objResultPtr); - } + objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); diff --git a/generic/tclInt.h b/generic/tclInt.h index 2ba0493..8322095 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3069,6 +3069,8 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); +MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx, + int toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 43d90ab..c4dafba 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -423,6 +423,87 @@ TclListObjCopy( /* *---------------------------------------------------------------------- * + * TclListObjRange -- + * + * Makes a slice of a list value. + * *listPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the sliced list. + * This may be a new object or the same object if not shared. + * + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjRange( + Tcl_Obj *listPtr, /* List object to take a range from. */ + int fromIdx, /* Index of first element to include. */ + int toIdx) /* Index of last element to include. */ +{ + Tcl_Obj **elemPtrs; + int listLen, i, newLen; + List *listRepPtr; + + TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); + + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= listLen) { + toIdx = listLen-1; + } + if (fromIdx > toIdx) { + return Tcl_NewObj(); + } + + newLen = toIdx - fromIdx + 1; + + if (Tcl_IsShared(listPtr) || + ((ListRepPtr(listPtr)->refCount > 1))) { + return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]); + } + + /* + * In-place is possible. + */ + + /* + * Even if nothing below cause any changes, we still want the + * string-canonizing effect of [lrange 0 end]. + */ + + TclInvalidateStringRep(listPtr); + + /* + * Delete elements that should not be included. + */ + + for (i = 0; i < fromIdx; i++) { + TclDecrRefCount(elemPtrs[i]); + } + for (i = toIdx + 1; i < listLen; i++) { + TclDecrRefCount(elemPtrs[i]); + } + + if (fromIdx > 0) { + memmove(elemPtrs, &elemPtrs[fromIdx], + (size_t) newLen * sizeof(Tcl_Obj*)); + } + + listRepPtr = ListRepPtr(listPtr); + listRepPtr->elemCount = newLen; + + return listPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ListObjGetElements -- * * This function returns an (objc,objv) array of the elements in a list -- cgit v0.12