From 25b5f03d7a8f8c50e31c2498d9b9fef6e48c51f5 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 27 Jul 2022 16:19:36 +0000 Subject: Final prep for TIP625 vote --- generic/tclListObj.c | 28 +++++++++++-------- tests/listRep.test | 78 +++++++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 84 insertions(+), 22 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 6e195e3..43307ad 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -12,8 +12,11 @@ #include "tclInt.h" #include -/* TODO - memmove is fast. Measure at what size we should prefer memmove - (for unshared objects only) in lieu of range operations */ +/* + * TODO - memmove is fast. Measure at what size we should prefer memmove + * (for unshared objects only) in lieu of range operations. On the other + * hand, more cache dirtied? + */ /* * Macros for validation and bug checking. @@ -1451,7 +1454,7 @@ ListRepRange( if (!preserveSrcRep) { /* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */ ListRepFreeUnreferenced(srcRepPtr); - } + } /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */ if (rangeStart < 0) { rangeStart = 0; @@ -1486,7 +1489,7 @@ ListRepRange( */ if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) { /* Option 0 - entire list. This may be used to canonicalize */ - /* T:listrep-1.10.1 */ + /* T:listrep-1.10.1,2.8.1 */ *rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */ } else if (rangeStart == 0 && (!preserveSrcRep) && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) { @@ -1513,7 +1516,7 @@ ListRepRange( if (!preserveSrcRep && srcRepPtr->spanPtr && srcRepPtr->spanPtr->refCount <= 1) { /* If span is not shared reuse it */ - /* T:listrep-3.{16,18} */ + /* T:listrep-2.7.3,3.{16,18} */ srcRepPtr->spanPtr->spanStart = spanStart; srcRepPtr->spanPtr->spanLength = rangeLen; *rangeRepPtr = *srcRepPtr; @@ -1636,7 +1639,7 @@ TclListObjRange( ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep); if (isShared) { - /* T:listrep-1.10.1 */ + /* T:listrep-1.10.1,2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */ TclNewObj(listObj); } /* T:listrep-1.{4.3,5.1,5.2} */ ListObjReplaceRepAndInvalidate(listObj, &resultRep); @@ -1846,7 +1849,7 @@ Tcl_ListObjAppendList( LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed); listRep.spanPtr->spanLength = finalLen; - } + } /* else T:listrep-3.6.3 */ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); LIST_ASSERT(ListRepLength(&listRep) == finalLen); LISTREP_CHECK(&listRep); @@ -2179,7 +2182,7 @@ Tcl_ListObjReplace( if (numToDelete == 0) { /* Case (2a) - Append to list. */ if (first == origListLen) { - /* T:listrep-1.11,2.9,3.{5,6} */ + /* T:listrep-1.11,2.9,3.{5,6},2.2.1 */ return TclListObjAppendElements( interp, listObj, numToInsert, insertObjs); } @@ -2740,7 +2743,7 @@ TclLsetList( && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) == TCL_OK) { /* indexArgPtr designates a single index. */ - /* T:listrep-1.{2.1,12.1,15.1,19.1} */ + /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } @@ -3023,13 +3026,13 @@ TclLsetFlat( len = -1; TclListObjLengthM(NULL, subListObj, &len); if (valueObj == NULL) { - /* T:listrep-1.{4.2,5.4,6.1,7.1,8.3} */ + /* T:listrep-1.{4.2,5.4,6.1,7.1,8.3},2.{4,5}.4 */ Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL); } else if (index == len) { - /* T:listrep-1.2.1 */ + /* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */ Tcl_ListObjAppendElement(NULL, subListObj, valueObj); } else { - /* T:listrep-1.{12.1,15.1,19.1} */ + /* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */ TclListObjSetElement(NULL, subListObj, index, valueObj); TclInvalidateStringRep(subListObj); } @@ -3102,6 +3105,7 @@ TclListObjSetElement( /* Replace a shared internal rep with an unshared copy */ if (listRep.storePtr->refCount > 1) { ListRep newInternalRep; + /* T:listrep-2.{10,13,16}.1 */ /* TODO - leave extra space? */ ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL); listRep = newInternalRep; diff --git a/tests/listRep.test b/tests/listRep.test index 9cfaeb2..7d0dda2 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -2306,17 +2306,75 @@ test listrep-4.18 { } -result [list [irange 2 997] [concat [irange 2 994] {1000 1001 1002 997}] 0 1 1 2 1] # -# Tests when tcl-obj is shared but listrep is not (lappend, lset etc.) +# Tests when tcl-obj is shared but listrep is not. This is to ensure that +# checks for shared values check the Tcl_Obj reference counts in addition to +# the list internal representation reference counts. Probably some or all +# cases are already covered elsewhere but easier to just test than look. +test listrep-5.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lappend version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lappend l 8 + list $same $l $l2 [sameStore $l $l2] +} -result [list 1 [irange 0 8] [irange 0 7] 0] -# TBD - canonical output on shared and spanned lists (see 1.10) -# TBD - range and subrange tests -# - spanned and unspanned -# TBD - zombie tests -# -# Special cases -# - nested lset (does not seem tested in 8.6) -# - lremove with multiple indices -# - nested lpop +test listrep-5.1.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lset version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lset l $end+1 8 + list $same $l $l2 [sameStore $l $l2] +} -result [list 1 [irange 0 8] [irange 0 7] 0] + +test listrep-5.1.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanless + list representation only modifies the target object - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone] + set l2 $l + set same [sameStore $l $l2] + lpop l + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] +} -result [list 1 [irange 0 6] [irange 0 7] 0 0] + +test listrep-5.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lappend version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set l2 $l + set same [sameStore $l $l2] + lappend l 1000 + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 1000] [irange 0 999] 0 1 1] + +test listrep-5.2.1 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lset version +} -constraints testlistrep -body { + set l [freeSpaceBoth 1000 10 10] + set l2 $l + set same [sameStore $l $l2] + lset l $end+1 1000 + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 1000] [irange 0 999] 0 1 1] + +test listrep-5.2.2 { + Verify that operation on a shared Tcl_Obj with a single-ref, spanned + list representation only modifies the target object - lpop version +} -constraints testlistrep -body { + set l [freeSpaceNone 1000] + set l2 $l + set same [sameStore $l $l2] + lpop l + list $same $l $l2 [sameStore $l $l2] [hasSpan $l] [hasSpan $l2] +} -result [list 1 [irange 0 998] [irange 0 999] 1 1 0] ::tcltest::cleanupTests return -- cgit v0.12