619de4e567c5 — Leonard Ritter 18 days ago
* content-agnostic garbage collector implementation
2 files changed, 200 insertions(+), 88 deletions(-)

M lib/tukan/logregion.sc
M testing/test_node4.sc
M lib/tukan/logregion.sc +26 -0
@@ 16,6 16,32 @@ 
     problem, because ranges are always subregions of allocations, and so by
     definition will never cross block alignments greater than the parent region.
 
+    also good to know:
+
+    fn next (addr)
+        sz := (addr & -addr)
+        addr + (size << 1)
+
+    fn prev (addr)
+        addr - (size << 1)
+
+    fn left (addr)
+        sz := (addr & -addr)
+        (addr ^ sz) | ((sz + 1) >> 1)
+
+    fn right (addr)
+        sz := (addr & -addr)
+        addr | ((sz + 1) >> 1)
+
+    fn sibling (addr)
+        sz := (addr & -addr)
+        addr ^ (sz << 1)
+
+    fn parent (addr)
+        sz := (addr & -addr)
+        (addr + (addr ^ (sz << 1))) >> 1
+
+
 """"round x to the next highest power of 2
 inline... alignsize (x : u32)
     x := x - 1

          
M testing/test_node4.sc +174 -88
@@ 13,7 13,16 @@ inline firstbit (mask bit)
 inline nextbit (mask bit)
     mask & (~ (mask - (bit << 1)))
 
-fn prevbit (mask bit)
+fn... prevbit (mask : u64, bit : u64)
+    mask := mask & (bit - 1)
+    mask := mask | mask >> 1
+    mask := mask | mask >> 2
+    mask := mask | mask >> 4
+    mask := mask | mask >> 8
+    mask := mask | mask >> 16
+    mask := mask | mask >> 32
+    mask & ((mask >> 1) + 1)
+case (mask : u32, bit : u32)
     mask := mask & (bit - 1)
     mask := mask | mask >> 1
     mask := mask | mask >> 2

          
@@ 90,14 99,17 @@ type+ Region
 
     fn __repr (self)
         let offset size = (unpack self)
-        let b = (max (0 as (typeof size)) (findlsb size))
-        .. "%" (hex offset) ":" (tostring b)
+        .. "%" (hex offset) ":" (hex (offset + size))
 
     fn... __@ (self, index : u32)
         let offset size = (unpack self)
         assert (index < size)
         bitcast (offset + index) Id
 
+    fn endpoints (self)
+        let offset size = (unpack self)
+        _ (bitcast offset Id) (bitcast (offset + size - 1) Id)
+
     @@ memo
     inline __rin (cls T)
         static-if (cls == Id)

          
@@ 121,8 133,12 @@ type+ Region
 
 ################################################################################
 
+
+
+################################################################################
+
 struct Module
-    BitWordType := WordType
+    BitWordType := u64
     BitWordWidth := (bitcountof BitWordType)
 
     p : (Array WordType)

          
@@ 131,15 147,16 @@ struct Module
 
     inline __typecall (cls)
         local self = (super-type.__typecall cls)
-        'append self.p 0:u32
-        'append self.ref 0:u32
+        'append self.p (0 as WordType)
+        'append self.ref (0 as BitWordType)
         deref self
 
     fn id2bitpos (id)
+        id := id as integer as BitWordType
         _ (id // BitWordWidth) (id & (BitWordWidth - 1))
 
     fn bitpos2id (bitwordofs bitofs)
-        bitwordofs * BitWordWidth + bitofs
+        bitcast ((bitwordofs * BitWordWidth + bitofs) as WordType) Id
 
     fn alloc (self wordcount)
         count := (countof self.p)

          
@@ 164,93 181,119 @@ struct Module
         self.ref @ bitwordofs |= (1 as BitWordType) << bitofs
         ;
 
-    #fn... collect (self, root : Id)
-        let bitwordofs bitofs = (id2bitpos root)
-        # dirty flags
-        local used : (Array BitWordType)
-        maxwordofs := ((countof self.sep) as u32)
-        'resize used maxwordofs 0:u32
+    let DEBUG_COLLECT = false
+
+    fn... collect (self, root : Region)
+        let report =
+            static-if DEBUG_COLLECT report
+            else (inline (...))
 
-        fn mark (self used id)
-            print "mark:" id
-            let bitwordofs bitofs = (id2bitpos id)
-            used @ bitwordofs |= (1 as BitWordType) << bitofs
+        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 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
+            ;
 
-        fn visit (self used bitwordofs bitofsmask maxwordofs)
-            let p sep ref = self.p self.sep self.ref
-            loop (bitwordofs bitofsmask = bitwordofs bitofsmask)
-                w := (deref (ref @ bitwordofs))
-                # terminate at next separator or next used bit
-                s := (sep @ bitwordofs) | (used @ bitwordofs)
-                endofsmask := (nextbit s bitofsmask)
-                vvv bind bitwordofs bitofsmask
-                loop (bitofsmask = bitofsmask)
-                    bitofsmask := (firstbit w bitofsmask)
-                    if (endofsmask == 0) # no terminator in this word
-                        if (bitofsmask == 0) # more refs in next word
-                            break (bitwordofs + 1) 1:u32
-                    else # terminator in this word
-                        if ((bitofsmask == 0) | (bitofsmask >= endofsmask)) # no more refs
-                            return;
-                    if (w & bitofsmask)
-                        # is a ref
-                        mark self used
-                            p @ (bitpos2id bitwordofs (findlsb bitofsmask))
-                    else
-                        report "ref miss"
-                    # go to next ref in this word
-                    repeat (bitofsmask << 1)
-                if (bitwordofs >= maxwordofs)
-                    break;
-                else
-                    repeat bitwordofs bitofsmask
+        # mark null
+        mark self usedl usedr (bitcast (encaddr 0 1) Region)
+        # mark root
+        mark self usedl usedr root
+
+        let bitwordofs bitofs = (id2bitpos (eofpos - 1))
+        let bitwordcount = (bitwordofs + 1)
+
+        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 = rc) for bit in (ritermaskbits (| lw rw refw))
+                rc := rc + (? ((rw & bit) == 0) 0 1)
+                if ((rc > 0) & ((refw & bit) != 0))
+                    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)
+
+        # now the usermap is complete
 
-        mark self used root
-        bitofsmask := (1:u32 << bitofs)
+        local oldp : (typeof self.p)
+        local oldref : (typeof self.ref)
+        # swap out values
+        swap (view oldp) self.p
+        swap (view oldref) self.ref
 
-        # tagging, from front to back
-        loop (bitwordofs bitofsmask = bitwordofs bitofsmask)
-            w := (used @ bitwordofs)
-            vvv bind bitwordofs bitofsmask
-            loop (bitofsmask = bitofsmask)
-                if (w & bitofsmask)
-                    print "visit:" (bitpos2id bitwordofs (findlsb bitofsmask))
-                    # is used
-                    visit self used bitwordofs bitofsmask maxwordofs
-                else
-                    report "used miss"
-                bitofsmask := (prevbit w bitofsmask)
-                if (bitofsmask == 0) # more used bits in prev word?
-                    break (bitwordofs - 1) 0:u32
-                # go to prev used bit in this word
-                repeat bitofsmask
-            if (bitwordofs >= maxwordofs)
-                break;
-            w := (used @ bitwordofs)
-            repeat bitwordofs (prevbit w bitofsmask)
+        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 = rc startpos) for bit in (itermaskbits (| lw rw))
+                let started? = ((lw & bit) != 0)
+                let stopped? = ((rw & bit) != 0)
+                rc := rc + (? started? 1 0)
+                let 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 old 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
+        let newofs = (copy (oldp @ offset))
+        assert ((newofs & (size - 1)) == 0)
+        # return address of new root
+        bitcast (encaddr newofs (copy size)) Region
 
-        # compaction
-        local t_p : (Array WordType)
-        local t_sep : (Array BitWordType)
-        local t_ref : (Array BitWordType)
-        'append t_p 0:u32
-        'append t_sep 1:u32
-        'append t_ref 0:u32
-
-        # sweep from back to front; first used flag in a sequence copies the
-            sequence to the new buffer, starting from that point; every used
-            word in the previous sequence is replaced with the id of the new
-            one. every reference being transferred looks up its new address
-            in the old buffer.
-
-
-        # tagging without separators and with ranged references:
-            create new empty buffer
-            flag beginning of range as used
-
+################################################################################
 
 do
     local module : Module
+    print "n0="
+        n0 := ('alloc module 4)
     print "n1="
         n1 := ('alloc module 5)
     print "n2="

          
@@ 261,13 304,56 @@ do
         n4 := ('alloc module 16)
     print "n5="
         n5 := ('alloc module 40)
-    print (n5 @ 2)
+    'setref module (n2 @ 3) n0
+    #'setref module (n5 @ 2) (n3 @ 0)
     'setref module (n5 @ 2) n4
     'setref module (n5 @ 35) n3
     'setref module (n3 @ 0) (n1 @ 2)
     'setref module (n3 @ 1) (n2 @ 3)
     'setref module (n2 @ 2) n1
-    #'collect module n5
+    let n5 = ('collect module n5)
+    print;
+    'collect module n5
+
+
+#static-if main-module?
+    local module : Module
+    do
+        from (methodsof module) let integerType realType arrayType stringType
+            \ getType vectorType intToReal state constFloat fadd fmul fdiv sin cos
+            \ constComposite compositeInsert compositeConstruct constBool constString
+            \ parameter parameters function tupleType else bind then merge
+            \ equal input load output constInt and or not xor if
+
+        let string =
+            stringType;
+        let inttype =
+            integerType 32 true
+        let readline =
+            input string Input.Readline
+        let setup =
+            input Input.Setup
+        let stdout =
+            output string Output.Stdout
+        let exit =
+            output inttype Output.Exit
+        let prompt =
+            output string Output.Prompt
+
+        let exit? =
+            equal (constString "\n") readline
+
+        bind exit
+            then exit? (constInt inttype 0)
+
+        bind prompt
+            then (merge setup (not exit?)) (constString "> ")
+
+        bind stdout
+            merge
+                then exit? (constString "exiting...\n")
+                else exit? readline
+            #if exit? (constString "exiting...\n") readline
 
 ;