5f21ae50d10c — Leonard Ritter 13 days ago
* gc now performs compaction in-place
1 files changed, 113 insertions(+), 109 deletions(-)

M testing/test_node4.sc
M testing/test_node4.sc +113 -109
@@ 8,6 8,10 @@ import ..lib.tukan.use
 using import tukan.logregion
 using import tukan.SHA256
 
+# print debug output while scanning
+let DEBUG_SCAN = false
+
+
 inline firstbit (mask bit)
     mask & (~ (mask - bit))
     # same as mask & (bit - (mask + 1))

          
@@ 119,6 123,9 @@ type+ Region
 
     let Empty = (bitcast 0:u32 this-type)
 
+    inline __copy (self)
+        dupe (deref self)
+
     fn parent (self)
         bitcast (parentaddr (storagecast self)) this-type
 

          
@@ 168,7 175,8 @@ type+ Region
                 let offset size = (unpack self)
                 other < offset
 
-    inline... from-offset (offset : u32, size : u32 = 1:u32)
+    inline... from-aligned-offset (offset : u32, size : u32 = 1:u32)
+        assert ((offset & (size - 1)) == 0)
         bitcast (encaddr offset size) Region
 
     inline... from-range (lhs : u32, rhs : u32)

          
@@ 228,7 236,7 @@ struct Module
         self.ref @ bitwordofs |= (1 as BitWordType) << bitofs
         ;
 
-    fn... dedup (self)
+    fn... dedup (self, root : Region)
         #   1. Iterate and hashmap the largest unique logregions
             (using SHA256 hashes), while also aliasing addresses
             (unique addresses are aliased to themselves). Then repeatedly

          
@@ 311,7 319,7 @@ struct Module
         drop map
 
         fn alias-region (aliases region)
-            try (deref ('get aliases region))
+            try (copy ('get aliases region))
             else
                 # region is in redundant range
                 let original-region = region

          
@@ 329,13 337,13 @@ struct Module
                     let oldofs = (unpack oldparent)
                     let newofs = (unpack newparent)
                     # compute offset relative to new parent block
-                    let newregion = (Region.from-offset
+                    let newregion = (Region.from-aligned-offset
                         (offset - oldofs + newofs) size)
                     try
                         let newregion = (deref ('get aliases newregion))
                         # write new alias for subsequent lookups
                         'set aliases original-region newregion
-                        break newregion
+                        break (copy newregion)
                     else
                         # new region is also redundant; offset once more
                         repeat newregion

          
@@ 352,42 360,13 @@ struct Module
                     # rewrite reference
                     addrptr = (storagecast newregion)
 
-        aliases
-
-
-    let DEBUG_COLLECT = true
+        alias-region aliases root
 
-    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.
-
+    fn... scan (self, root : Region)
+        """"build a reverse ordered array of regions (in)directly connected
+            to root. only memory within these regions is in use.
         let report =
-            static-if DEBUG_COLLECT report
+            static-if DEBUG_SCAN report
             else (inline (...))
 
         fn mark (self regions region)

          
@@ 437,7 416,7 @@ struct Module
         'set regions rootregion false # add terminator
 
         # mark null
-        mark self regions (Region.from-offset 0 1)
+        mark self regions (Region.from-aligned-offset 0 1)
         # mark root
         mark self regions root
 

          
@@ 479,89 458,114 @@ struct Module
             # try the next one
             repeat ('prev region)
 
+        visited
+
+    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 visited = ('scan self root)
         # usermap is complete, perform the translocation
 
         # inplace
-        local oldp : (typeof self.p)
-        local oldref : (typeof self.ref)
-        # swap out values
-        swap (view oldp) self.p
-        swap (view oldref) self.ref
+        local aliases : (Map Region Region)
+        fn find-alias (aliases region)
+            # try a direct translation
+            try (copy ('get aliases region))
+            else
+                # reference is in existing block
+                let original-region = region
+                # find existing block
+                let oldparent newparent =
+                    loop (oldparent = ('parent region))
+                        assert (oldparent != Region.Empty)
+                        try
+                            break oldparent
+                                deref ('get aliases oldparent)
+                        else
+                            repeat ('parent oldparent)
+                let offset size = (unpack region)
+                let oldofs = (unpack oldparent)
+                let newofs = (unpack newparent)
+                # compute offset relative to new parent block
+                let newregion = (Region.from-aligned-offset
+                    (offset - oldofs + newofs) size)
+                # write new alias for subsequent lookups
+                'set aliases original-region newregion
+                copy newregion
 
+        local newbuffersize = 0:u32
         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)
+            let newbuffersizebefore = (copy newbuffersize)
+            let offset paddedsize = (alignoffset newbuffersizebefore size)
+            # pad with null bytes
+            for i in (range newbuffersizebefore offset)
+                p @ i = 0:u32
+            newbuffersize = offset + paddedsize
+            let newregion = (Region.from-aligned-offset offset paddedsize)
+            'set aliases oldregion newregion
+            let move? = (startpos != offset)
             for i in (range size)
                 srcoffset := (startpos + i)
                 dstoffset := (offset + i)
-                srcval := oldp @ srcoffset
+                assert (dstoffset <= srcoffset)
+                srcval := p @ 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
+                let refbit = ((1 as BitWordType) << bitofs)
+                if ((ref @ bitwordofs) & refbit)
+                    let oldref = (bitcast value Region)
+                    let newref = (find-alias aliases oldref)
+                    destval = (storagecast newref)
+                    if move?
+                        # clear old bit
+                        ref @ bitwordofs &= (~ bitofs)
+                        # set new bit
+                        dstbitwordofs := (dstoffset // BitWordWidth)
+                        dstbitofs := dstoffset & (BitWordWidth - 1)
+                        ref @ dstbitwordofs |= (1 as BitWordType) << dstbitofs
+                elseif move?
                     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
+        'resize p newbuffersize
+        bitcount := (newbuffersize + BitWordWidth - 1) // BitWordWidth
+        'resize ref bitcount
+        # mask out any unused bits
+        lastbit := (newbuffersize - 1) & (BitWordWidth - 1)
+        rmask := (-1 as BitWordType) >> (BitWordWidth - (lastbit as BitWordType) - 1)
+        reftail := ('last ref)
+        reftail &= rmask
 
-        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
-        bitcast (encaddr newofs (copy size)) Region
+        find-alias aliases root
 
 ################################################################################
 

          
@@ 584,13 588,13 @@ do
     'setref module (n2 @ 3) n01
     #'setref module (n5 @ 2) (n3 @ 0)
     'setref module (n5 @ 2) n4
-    'setref module (n5 @ 35) n3
+    'setref module (n5 @ 39) n3
     'setref module (n3 @ 0) (n1 @ 2)
     'setref module (n3 @ 1) (n2 @ 3)
     'setref module (n2 @ 2) n0
-    drop ('dedup module)
+    let n5 = ('dedup module n5)
 
-    fold (n5) for i in (range 1)
+    fold (n5) for i in (range 3)
         print "size:" (countof module.p)
         print "connect n5=" n5
         'collect module n5