From a034ecec4fd9513f2d8df0636bdbca1118fc7938 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 16 Jul 2022 17:22:11 +0000 Subject: First few list representation tests --- generic/tclListObj.c | 5 + tests/listRep.test | 296 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 301 insertions(+) create mode 100644 tests/listRep.test diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 8f8d0b9..3a3c531 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1858,6 +1858,7 @@ Tcl_ListObjAppendList( LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); if (toLen) { + /* T:listrep-2.2 */ ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv); } ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv); @@ -2254,20 +2255,24 @@ Tcl_ListObjReplace( &newRep); toObjs = ListRepSlotPtr(&newRep, 0); if (leadSegmentLen > 0) { + /* T:listrep-2.{2,3} */ ObjArrayCopy(toObjs, leadSegmentLen, listObjs); } if (numToInsert > 0) { + /* T:listrep-2.{1,2,3} */ ObjArrayCopy(&toObjs[leadSegmentLen], numToInsert, insertObjs); } if (tailSegmentLen > 0) { + /* T:listrep-2.{1,2,3} */ ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert], tailSegmentLen, &listObjs[leadSegmentLen+numToDelete]); } newRep.storePtr->numUsed = origListLen + lenChange; if (newRep.spanPtr) { + /* T:listrep-2.{1,2,3} */ newRep.spanPtr->spanLength = newRep.storePtr->numUsed; } LISTREP_CHECK(&newRep); diff --git a/tests/listRep.test b/tests/listRep.test new file mode 100644 index 0000000..654ae5d --- /dev/null +++ b/tests/listRep.test @@ -0,0 +1,296 @@ +# This file contains tests that specifically exercise the internal representation +# of a list. +# +# Copyright © 2022 Ashok P. Nadkarni +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# Unlike the other files related to list commands which for the most part do +# black box testing focusing on functionality, this file does more of white box +# testing to exercise code paths that implement different list representations +# (with spans, leading free space etc., shared/unshared etc.) In addition to +# functional correctness, the tests also check for the expected internal +# representation as that pertains to performance heuristics. Generally speaking, +# combinations of the following need to be tested, +# - free space in front, back, neither, both of list representation +# - shared Tcl_Objs +# - shared internal reps (independent of shared Tcl_Objs) +# - byte-compiled vs non-compiled +# +# Being white box tests, they are sensitive to changes to further optimizations +# and changes in heuristics. That cannot be helped. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands + +testConstraint testlistrep [llength [info commands testlistrep]] +interp alias {} describe {} testlistrep describe + +proc irange {first last} { + set l {} + while {$first <= $last} { + lappend l $first + incr first + } + return $l +} +proc leadSpace {l} { + # Returns the leading space in a list store + return [dict get [describe $l] store firstUsed] +} +proc tailSpace {l} { + # Returns the trailing space in a list store + array set rep [describe $l] + dict with rep(store) { + return [expr {$numAllocated - ($firstUsed + $numUsed)}] + } +} +proc allocated {l} { + # Returns the allocated space in a list store + return [dict get [describe $l] store numAllocated] +} +proc repStoreRefCount {l} { + # Returns the ref count for the list store + return [dict get [describe $l] store refCount] +} +proc validate {l} { + # Panics if internal listrep structures are not valid + testlistrep validate $l +} +proc leadSpaceMore {l} { + expr {[leadSpace $l] >= 2*[tailSpace $l]} +} +proc tailSpaceMore {l} { + expr {[tailSpace $l] >= 2*[leadSpace $l]} +} +proc spaceEqual {l} { + # 1 if lead and tail space shared (diff of 1 at most) + set diff [expr {[leadSpace $l] - [tailSpace $l]}] + return [expr {$diff >= -1 && $diff <= 1}] +} +proc hasSpan {l args} { + # Returns 1 if list has a span. If args are specified, they are checked with + # span values (start and length) + array set rep [describe $l] + if {![info exists rep(span)]} { + return 0 + } + if {[llength $args] == 0} { + return 1; # No need to check values + } + lassign $args start len + if {[dict get $rep(span) spanStart] == $start && + [dict get $rep(span) spanLength] == $len} { + return 1 + } + return 0 +} +proc checkListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} { + # Checks if the internal representation of $l match + # passed arguments. Return "" if yes, else error messages. + array set rep [testlistrep describe $l] + + set rep(leadSpace) [dict get $rep(store) firstUsed] + set rep(numAllocated) [dict get $rep(store) numAllocated] + set rep(tailSpace) [expr { + $rep(numAllocated) - ($rep(leadSpace) + [dict get $rep(store) numUsed]) + }] + set rep(refCount) [dict get $rep(store) refCount] + + if {[info exists rep(span)]} { + set rep(listLen) [dict get $rep(span) spanLength] + } else { + set rep(listLen) [dict get $rep(store) numUsed] + } + + set errors [list] + foreach arg {listLen numAllocated leadSpace tailSpace} { + if {$rep($arg) != [set $arg]} { + lappend errors "$arg in list representation ($rep($arg)) is not expected value ([set $arg])." + } + } + # Check refCount only if caller has specified it as non-0 + if {$refCount && $refCount != $rep(refCount)} { + lappend errors "refCount in list representation ($rep(refCount)) is not expected value ($refCount)." + } + return $errors +} + +proc assertListrep {l listLen numAllocated leadSpace tailSpace {refCount 0}} { + # Like check_listrep but raises error + set errors [checkListrep $l $listLen $numAllocated $leadSpace $tailSpace $refCount] + if {[llength $errors]} { + error [join $errors \n] + } + return +} + +# The default length should be large enough that doubling the allocation will +# clearly distinguish free space allocation difference between front and back. +# (difference in the two should at least be 2 else we cannot tell if front +# or back was favored appropriately) +proc freeSpaceNone {{len 8}} {return [testlistrep new $len 0 0]} +proc freeSpaceLead {{len 8} {lead 3}} {return [testlistrep new $len $lead 0]} +proc freeSpaceTail {{len 8} {tail 3}} {return [testlistrep new $len 0 $tail]} +proc freeSpaceBoth {{len 8} {lead 3} {tail 3}} { + return [testlistrep new $len $lead $tail] +} + +# Just ensure above stubs return what's expected +if {[testConstraint testlistrep]} { + assertListrep [freeSpaceNone] 8 8 0 0 1 + assertListrep [freeSpaceLead] 8 11 3 0 1 + assertListrep [freeSpaceTail] 8 11 0 3 1 + assertListrep [freeSpaceBoth] 8 14 3 3 1 +} + +# Define some variables for some indices because the Tcl compiler will do some +# operations completely in byte code if indices are literals +set zero 0 +set one 1 +set four 4 +set end end + +# +# listrep-1.* tests all operate on unshared lists with no free space + +test listrep-1.1 { + Inserts in front of unshared list with no free space should reallocate with + equal free space at front and back +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $zero 99] + validate $l + list $l [spaceEqual $l] +} -result [list {99 0 1 2 3 4 5 6 7} 1] + +test listrep-1.2 { + Inserts at back of unshared list with no free space should allocate all + space at back (essentially old lappend behavior) +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $end 99] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {0 1 2 3 4 5 6 7 99} 0 9] + +test listrep-1.3 { + Inserts in middle of unshared list with no free space should reallocate with + equal free space at front and back +} -constraints testlistrep -body { + set l [linsert [freeSpaceNone] $four 99] + validate $l + list $l [spaceEqual $l] +} -result [list {0 1 2 3 99 4 5 6 7} 1] + +test listrep-1.4 { + Deletes from front of small unshared list with no free space should + just shift up leaving room at back +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] $zero $zero] + validate $l + list $l [leadSpace $l] [tailSpace $l] +} -result [list {1 2 3 4 5 6 7} 0 1] + +test listrep-1.5 { + Deletes from front of large unshared list with no free space should + create a span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] $zero $one] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 2 998] +} -result [list [irange 2 999] 2 0 1] + +test listrep-1.6 { + Deletes closer to front of large list should move (smaller) front segment +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] $four $four] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l 1 999] +} -result [list [concat [irange 0 3] [irange 5 999]] 1 0 1] + +test listrep-1.7 { + Deletes closer to back of large list should move (smaller) back segment + and will not need a span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] end-$four end-$four] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [concat [irange 0 994] [irange 996 999]] 0 1 0] + +test listrep-1.8 { + Deletes at back of small unshared list should not need a span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone] end-$one end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list {0 1 2 3 4 5} 0 2 0] + +test listrep-1.9 { + Deletes at back of large unshared list should not need a span +} -constraints testlistrep -body { + set l [lreplace [freeSpaceNone 1000] end-$four end] + validate $l + list $l [leadSpace $l] [tailSpace $l] [hasSpan $l] +} -result [list [irange 0 994] 0 5 0] + +test listrep-1.10 { + lreplace no-op should force a canonical list representation +} -body { + lreplace { 1 2 3 4 } $zero -1 +} -result {1 2 3 4} + +test listrep-1.11 { + Append elements to large unshared list using lreplace is optimized as lappend + so no free space in front +} -body { + # Note $end, not end else byte code compiler short-cuts + set l [lreplace [freeSpaceNone 1000] $end+1 $end+1 99] + list $l [leadSpace $l] [expr {[tailSpace $l] > 0}] [hasSpan $l] +} -result [list [linsert [irange 0 999] end+1 99] 0 1 0] + +# +# listrep-2.* tests all operate on shared lists with no free space +# The lrange construct on an variable's value will result in a listrep +# that is shared (it's not enough that the Tcl_Obj is shared so just +# assigning to another variable does not suffice) + +test listrep-2.1 { + Inserts in front of shared list with no free space should reallocate with + more leading space in front +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end] + set l [linsert $b $zero 99] + validate $l + list [repStoreRefCount $b] $l [leadSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {99 0 1 2 3 4 5 6 7} 1 1] + +test listrep-2.2 { + Inserts at back of shared list with no free space should reallocate with + more leading space in back +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end] + set l [linsert $b $end 99] + validate $l + list [repStoreRefCount $b] $l [tailSpaceMore $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 4 5 6 7 99} 1 1] + +test listrep-2.3 { + Inserts in middle of shared list with no free space should reallocate with + equal spacing +} -constraints testlistrep -body { + set a [freeSpaceNone] + set b [lrange $a 0 end] + set l [linsert $b $four 99] + validate $l + list [repStoreRefCount $b] $l [spaceEqual $l] [repStoreRefCount $l] +} -result [list 2 {0 1 2 3 99 4 5 6 7} 1 1] + +# +::tcltest::cleanupTests +return -- cgit v0.12