8bb790eea6d5 — Leonard Ritter 17 days ago
* fixed GC implementation
2 files changed, 260 insertions(+), 104 deletions(-)

M lib/tukan/logregion.sc
M testing/test_node4.sc
M lib/tukan/logregion.sc +33 -15
@@ 140,15 140,10 @@ inline addrin? (addr parentaddr)
     let mn mx = (addrxbounds parentaddr)
     (addr > mn) & (addr < mx)
 
-""""compute the first child region of `addr`
-inline leftaddr (addr)
-    sz := addr & -addr
-    addr - (sz >> 1)
-
-""""compute the second child region of `addr`
-inline rightaddr (addr)
-    sz := addr & -addr
-    addr + (sz >> 1)
+""""compute the two child regions of `addr`
+inline childaddr (addr)
+    sz := ((addr & -addr) >> 1)
+    _ (addr - sz) (addr + sz)
 
 """"compute the sibling region sharing the same parent as `addr`
 inline siblingaddr (addr)

          
@@ 165,6 160,21 @@ inline neighboraddr (addr offset)
     sz := addr & -addr
     addr + (sz << 1) * offset
 
+""""compute the largest region following `addr`
+    if the region covers the entire range, the result is zero
+inline iternextaddr (addr)
+    sz := addr & -addr
+    ofs := ((addr + (sz << 1)) ^ sz)
+    sz2 := ofs & -ofs
+    ofs | (sz2 >> 1)
+
+""""compute the largest region preceding `addr`
+    if the region covers the entire range, the result is zero
+inline iterprevaddr (addr)
+    ofs := (addr ^ (addr & -addr))
+    sz2 := ofs & -ofs
+    (ofs - sz2) | (sz2 >> 1)
+
 static-if main-module?
     # 0:u32
     print

          
@@ 211,23 221,31 @@ static-if main-module?
         using import String
         local s : String
         let offset size = (decaddr addr)
+        'append s "\x1b[30;1m"
         for i in (range offset)
-            'append s "_"
+            'append s (hex (i % 16))
+        'append s "\x1b[36;1m"
         for i in (range size)
-            'append s "#"
+            'append s (hex ((offset + i) % 16))
+        'append s "\x1b[0m"
         s
     for i in (range 1:u32 17:u32)
         print " "
             regionstr i
         let d u = (addrbounds i)
+        print "<"
+            regionstr (iterprevaddr i)
+        print ">"
+            regionstr (iternextaddr i)
         print "d"
             regionstr d
         print "u"
             regionstr u
+        let l r = (childaddr i)
         print "L"
-            regionstr (leftaddr i)
+            regionstr l
         print "R"
-            regionstr (rightaddr i)
+            regionstr r
         print "S"
             regionstr (siblingaddr i)
         print "P"

          
@@ 235,8 253,8 @@ static-if main-module?
 
 do
     let encaddr encaddrun encaddrrangeun decaddr alignoffsetu alignoffsetd
-        \ alignsizeu alignsized leftaddr rightaddr siblingaddr parentaddr
-        \ neighboraddr addrbounds addrxbounds addrin?
+        \ alignsizeu alignsized childaddr siblingaddr parentaddr
+        \ neighboraddr addrbounds addrxbounds addrin? iternextaddr iterprevaddr
     locals;
 
 

          
M testing/test_node4.sc +227 -89
@@ 122,10 122,31 @@ type+ Region
     fn parent (self)
         bitcast (parentaddr (storagecast self)) this-type
 
+    fn children (self)
+        let l r = (childaddr (storagecast self))
+        _ (bitcast l this-type) (bitcast r this-type)
+
+    inline left (self)
+        addr := (storagecast self)
+        bitcast (addr - ((addr & -addr) >> 1)) Region
+
+    inline right (self)
+        addr := (storagecast self)
+        bitcast (addr + ((addr & -addr) >> 1)) Region
+
     fn endpoints (self)
         let offset size = (unpack self)
         _ (bitcast offset Id) (bitcast (offset + size - 1) Id)
 
+    fn neighbor (self offset)
+        bitcast (neighboraddr (storagecast self) offset) Region
+
+    fn next (self)
+        bitcast (iternextaddr (storagecast self)) Region
+
+    fn prev (self)
+        bitcast (iterprevaddr (storagecast self)) Region
+
     @@ memo
     inline __rin (cls T)
         static-if (cls == Id)

          
@@ 150,6 171,9 @@ type+ Region
     inline... from-offset (offset : u32, size : u32 = 1:u32)
         bitcast (encaddr offset size) Region
 
+    inline... from-range (lhs : u32, rhs : u32)
+        bitcast (encaddrrangeun lhs rhs) Region
+
 ################################################################################
 
 

          
@@ 177,11 201,15 @@ struct Module
     fn bitpos2id (bitwordofs bitofs)
         bitcast ((bitwordofs * BitWordWidth + bitofs) as WordType) Id
 
+    fn... alignoffset (offset : u32, size : u32)
+        """"return the aligned offset and size of a region of size `size`
+            whose offset is greater or equal to `offset`
+        size := (alignsizeu size)
+        offset := (alignoffsetu offset size)
+        _ offset size
+
     fn alloc (self wordcount)
-        count := (countof self.p)
-        offset := (count as u32)
-        size := (alignsizeu (wordcount as u32))
-        offset := (alignoffsetu offset size)
+        let offset size = (alignoffset ((countof self.p) as u32) (wordcount as u32))
         newcount := offset + size
         'resize self.p newcount (nullof WordType)
         bitcount := (newcount + BitWordWidth - 1) // BitWordWidth

          
@@ 214,6 242,11 @@ struct Module
             alias map until we find an alias for the parent block, and
             recalculate its new offset and try again.
 
+            TODO: with this technique, we'd need to dedup multiple times, because
+            references are aliased after the deduplication, permitting to
+            deduplicate blocks further. in fact, we'd need in the worst case
+            log2(k) dedups for a tree depth of k.
+
         let u256 = (integer 256)
 
         # map hash to region

          
@@ 280,6 313,7 @@ struct Module
         fn alias-region (aliases region)
             try (deref ('get aliases region))
             else
+                # region is in redundant range
                 let original-region = region
                 loop (region)
                     # find first unique parent

          
@@ 324,52 358,130 @@ struct Module
     let DEBUG_COLLECT = true
 
     fn... collect (self, root : Region)
+        #   Instead of an indices bitmap, we use a mapping of region to boolean,
+            where the boolean is true if the region is a leaf. When a region is
+            marked, all its parent regions are mapped to false if not already
+            mapped, and if none of its parent regions are mapped as true, the
+            region is mapped to true. We begin by marking the root node and the
+            zero node (0:1). We define a sweep line starting at the end of the
+            buffer. We use the map to find the deepest rightmost marked
+            logregion that is intersecting or touching the sweep line and mark
+            all references that it contains. Then we move the sweep line to the
+            front of the region and repeat. This ensures that we process all
+            regions in topological order, exactly once. We can therefore also
+            record all logregions that we have visited.
+
+            The number of iterations required to descend the tree can be reduced
+            by continuing with the left neighbor of the last processed block. If
+            the block isn't tagged, we ascend the hierarchy until we find one
+            that is, then descend to find the rightmost subregion mapped true
+            that's not past the sweep line. The walk is over when no more marked
+            blocks are found.
+
+            For compaction, we walk our recorded logregions in reverse (so
+            they're in the correct order), and move the allocations back -
+            which can be done in-place. We store an alias mapping from old
+            logregion to new logregion. For every reference we encounter, we
+            search the aliases for a mapping; If there is no direct mapping, we
+            try to find the first mapped parent region and recompute the local
+            offset of the reference. We also move the reference bits.
+
         let report =
             static-if DEBUG_COLLECT report
             else (inline (...))
 
-        let offset size = (unpack root)
-        let eofpos = (offset + size)
-        # usage flags
-        local usedl : (Array BitWordType)
-        local usedr : (Array BitWordType)
-        'resize usedl eofpos 0
-        'resize usedr eofpos 0
+        fn mark (self regions region)
+            let topregion =
+                loop (region)
+                    if (region == Region.Empty)
+                        break region
+                    try
+                        let leaf? = (deref ('get regions region))
+                        if leaf? # leaf overrides our region
+                            return;
+                        else # hierarchy exits
+                            break region
+                    else
+                        'parent region
+            # check rest of region for leaf
+                this check only prevents redundant leaf writes and is expensive
+            #loop (region = ('parent topregion))
+                if (region == Region.Empty)
+                    break;
+                try
+                    let leaf? = (deref ('get regions region))
+                    if leaf? # leaf overrides our region
+                        return;
+                    else # keep going
+                        'parent region
+                else
+                    break;
+            assert (topregion != Region.Empty)
+            report "mark leaf" region
+            'set regions region true
+            if (region != topregion)
+                loop (region = ('parent region))
+                    if (region == topregion)
+                        break;
+                    assert (region != Region.Empty)
+                    report "mark branch" region
+                    'set regions region false
+                    'parent region
 
-        fn mark (self usedl usedr region)
-            let lhs rhs = ('endpoints region)
-            report "mark:" lhs rhs
-            let bitwordofs bitofs = (id2bitpos lhs)
-            usedl @ bitwordofs |= (1 as BitWordType) << bitofs
-            let bitwordofs bitofs = (id2bitpos rhs)
-            usedr @ bitwordofs |= (1 as BitWordType) << bitofs
-            ;
+        let offset size = (unpack root)
+        let wordcount = (offset + size)
+        local regions : (Map Region bool)
+        let rootregion =
+            do
+                (Region.from-range 0:u32 wordcount)
+        'set regions rootregion false # add terminator
 
         # mark null
-        mark self usedl usedr (bitcast (encaddr 0 1) Region)
+        mark self regions (Region.from-offset 0 1)
         # mark root
-        mark self usedl usedr root
+        mark self regions root
 
-        let bitwordofs bitofs = (id2bitpos (eofpos - 1))
-        let bitwordcount = (bitwordofs + 1)
+        fn scan (self regions region)
+            report "scan" region
+            let lhs size = (unpack region)
+            let rhs = (lhs + size)
 
-        let p ref = self.p self.ref
-        fold (rc = 0) for wordword in (rrange bitwordcount)
-            # used words must be references, so we catch in-word updates
-            lw := (usedl @ wordword)
-            rw := (usedr @ wordword)
-            refw := (copy (ref @ wordword))
-            fold (rc) for bit in (ritermaskbits (| lw rw refw))
-                rc := rc + (? ((rw & bit) == 0) 0 1)
-                if ((rc > 0) & ((refw & bit) != 0))
+            let lhso lhsb = (id2bitpos lhs)
+            let rhso rhsb = (id2bitpos (rhs - 1))
+
+            lmask := (-1 as BitWordType) << (lhsb as BitWordType)
+            rmask := (-1 as BitWordType) >> (BitWordWidth - (rhsb as BitWordType) - 1)
+            #assert ((bitcount (lmask & rmask)) == size)
+
+            let p ref = self.p self.ref
+            for wordword in (rrange lhso (rhso + 1))
+                word := (copy (ref @ wordword))
+                let word = (? (wordword == rhso) (word & rmask) word)
+                let word = (? (wordword == lhso) (word & lmask) word)
+                for bit in (ritermaskbits word)
                     let id = (bitpos2id wordword (findlsb bit))
                     let target = (bitcast (copy (p @ id)) Region)
-                    #print rc "ref!" id "->" target
-                    mark self usedl usedr target
-                rc + (? ((lw & bit) == 0) 0 -1)
+                    report "ref" id "->" target
+                    mark self regions target
 
-        # now the usermap is complete
+        local visited : (Array Region)
+        # iterate marked regions back to front
+        loop (region = root)
+            if (region == Region.Empty)
+                break;
+            try
+                if (deref ('get regions region))
+                    'append visited region
+                    scan self regions region
+                else
+                    repeat ('right region)
+            except ()
+            # try the next one
+            repeat ('prev region)
 
+        # usermap is complete, perform the translocation
+
+        # inplace
         local oldp : (typeof self.p)
         local oldref : (typeof self.ref)
         # swap out values

          
@@ 377,55 489,75 @@ struct Module
         swap (view oldref) self.ref
 
         let p ref = self.p self.ref
-        fold (rc startpos = 0 (nullof WordType))
-            \ for wordword in (range bitwordcount)
-            lw := (copy (usedl @ wordword))
-            rw := (copy (usedr @ wordword))
-            fold (rc startpos)
-                \ for bit in (itermaskbits (| lw rw))
-                let started? = ((lw & bit) != 0)
-                let stopped? = ((rw & bit) != 0)
-                rc := rc + (? started? 1 0)
-                vvv bind startpos
-                if (rc == 1)
-                    let startpos =
-                        if started?
-                            let id = (bitpos2id wordword (findlsb bit))
-                            report "start" id
-                            id as integer
-                        else startpos
-                    if stopped?
-                        let endpos = (bitpos2id wordword (findlsb bit))
-                        report "end" endpos
-                        endpos := endpos as integer + 1
-                        # copy over region
-                        size := endpos - startpos
-                        let regval = ('alloc self size)
-                        let offset = (unpack regval)
-                        for i in (range size)
-                            srcoffset := (startpos + i)
-                            dstoffset := (offset + i)
-                            srcval := oldp @ srcoffset
-                            destval := p @ dstoffset
-                            let bitwordofs bitofs = (id2bitpos srcoffset)
-                            let value = (copy srcval)
-                            # write new address to previous location
-                            srcval = dstoffset
-                            if ((oldref @ bitwordofs)
-                                & ((1 as BitWordType) << bitofs))
-                                let oldofs oldsz = (decaddr value)
-                                let newofs = (copy (oldp @ oldofs))
-                                # new offset should be aligned
-                                assert ((newofs & (oldsz - 1)) == 0)
-                                destval = (encaddr newofs oldsz)
-                                bitwordofs := (dstoffset // BitWordWidth)
-                                bitofs := dstoffset & (BitWordWidth - 1)
-                                ref @ bitwordofs |= (1 as BitWordType) << bitofs
-                            else
-                                destval = value
-                    startpos
-                else startpos
-                _ (rc + (? stopped? -1 0)) startpos
+        for oldregion in ('reverse visited)
+            # copy over region
+            let startpos size = (unpack oldregion)
+            let endpos = (startpos + size)
+            let regval = ('alloc self size)
+            let offset = (unpack regval)
+            for i in (range size)
+                srcoffset := (startpos + i)
+                dstoffset := (offset + i)
+                srcval := oldp @ srcoffset
+                destval := p @ dstoffset
+                let bitwordofs bitofs = (id2bitpos srcoffset)
+                let value = (copy srcval)
+                # write new address to previous location
+                srcval = dstoffset
+                if ((oldref @ bitwordofs)
+                    & ((1 as BitWordType) << bitofs))
+                    let oldofs oldsz = (decaddr value)
+                    let newofs = (copy (oldp @ oldofs))
+                    # new offset should be aligned
+                    assert ((newofs & (oldsz - 1)) == 0)
+                    destval = (encaddr newofs oldsz)
+                    bitwordofs := (dstoffset // BitWordWidth)
+                    bitofs := dstoffset & (BitWordWidth - 1)
+                    ref @ bitwordofs |= (1 as BitWordType) << bitofs
+                else
+                    destval = value
+
+        let newofs = (copy (oldp @ offset))
+        assert ((newofs & (size - 1)) == 0)
+        # return address of new root
+        bitcast (encaddr newofs (copy size)) Region
+
+    # secondary buffer:
+        local oldp : (typeof self.p)
+        local oldref : (typeof self.ref)
+        # swap out values
+        swap (view oldp) self.p
+        swap (view oldref) self.ref
+
+        let p ref = self.p self.ref
+        for oldregion in ('reverse visited)
+            # copy over region
+            let startpos size = (unpack oldregion)
+            let endpos = (startpos + size)
+            let regval = ('alloc self size)
+            let offset = (unpack regval)
+            for i in (range size)
+                srcoffset := (startpos + i)
+                dstoffset := (offset + i)
+                srcval := oldp @ srcoffset
+                destval := p @ dstoffset
+                let bitwordofs bitofs = (id2bitpos srcoffset)
+                let value = (copy srcval)
+                # write new address to previous location
+                srcval = dstoffset
+                if ((oldref @ bitwordofs)
+                    & ((1 as BitWordType) << bitofs))
+                    let oldofs oldsz = (decaddr value)
+                    let newofs = (copy (oldp @ oldofs))
+                    # new offset should be aligned
+                    assert ((newofs & (oldsz - 1)) == 0)
+                    destval = (encaddr newofs oldsz)
+                    bitwordofs := (dstoffset // BitWordWidth)
+                    bitofs := dstoffset & (BitWordWidth - 1)
+                    ref @ bitwordofs |= (1 as BitWordType) << bitofs
+                else
+                    destval = value
+
         let newofs = (copy (oldp @ offset))
         assert ((newofs & (size - 1)) == 0)
         # return address of new root

          
@@ 437,7 569,7 @@ do
     local module : Module
     print "n0="
         n0 := ('alloc module 4)
-    print "n0="
+    print "n01="
         n01 := ('alloc module 4)
     print "n1="
         n1 := ('alloc module 5)

          
@@ 456,9 588,15 @@ do
     'setref module (n3 @ 0) (n1 @ 2)
     'setref module (n3 @ 1) (n2 @ 3)
     'setref module (n2 @ 2) n0
-    let addrmap = ('dedup module)
+    drop ('dedup module)
 
-    try
+    fold (n5) for i in (range 1)
+        print "size:" (countof module.p)
+        print "connect n5=" n5
+        'collect module n5
+    print "size:" (countof module.p)
+
+    #try
         print n5
         let n5 = (deref ('get addrmap n5))
         print n5

          
@@ 468,7 606,7 @@ do
         let n5 = ('collect module n5)
         print n5
         ;
-    else;
+    #else;
 
 
 #static-if main-module?