3c5553246c0c — Leonard Ritter 27 days ago
* initial work on arena GC
* generic toposort
5 files changed, 460 insertions(+), 17 deletions(-)

A => testing/arena_gc.sc
A => testing/elemental.sc
A => testing/lc.sc
A => testing/toposort.sc
M testing/voxel_bvh.sc
A => testing/arena_gc.sc +129 -0
@@ 0,0 1,129 @@ 
+# based on https://gist.github.com/paniq/34e50c524bfb538053e0e730d2254676
+
+using import struct
+using import Array
+
+import ..lib.tukan.use
+using import tukan.logtile
+
+let WordType = u64
+
+type APointer
+type ARef
+
+@@ memo
+inline genatypes (T)
+    static-assert ((typeof T) == type)
+
+    let Tstr = (tostring T)
+    let ElementType = T
+    let MutablePointerType = (mutable @T)
+    let APtr =
+        type (.. "(APointer " Tstr ")") < APointer : WordType
+            let ElementType
+            let MutablePointerType
+
+    let ARef =
+        type (.. "(ARef " Tstr ")") < ARef : WordType
+            let ElementType
+            let MutablePointerType
+            let APointerType = APtr
+    'define-symbol APtr 'ARefType ARef
+    _ APtr ARef
+
+type+ APointer
+    inline __typecall (cls T)
+        let aptrT = (genatypes T)
+        aptrT
+
+type+ ARef
+    inline __typecall (cls T)
+        let x arefT = (genatypes T)
+        arefT
+
+struct Arena
+    mem : (Array WordType)
+
+    fn alloc-bytes (self size)
+        let mem = self.mem
+        sz := (countof mem)
+        'resize mem (sz + size)
+        bitcast sz (APointer void)
+
+    inline... alloc (self, T : type)
+        assert ('plain? T) "type must be plain"
+        let ptr = (alloc-bytes self (sizeof T))
+        bitcast ptr (APointer T)
+
+    inline aptrtoptr (self aptr)
+        bitcast (reftoptr (self.mem @ (storagecast aptr)))
+            (typeof aptr) . MutablePointerType
+
+    inline store (self value dest)
+        store value (aptrtoptr self dest)
+
+    inline load (self src)
+        load (aptrtoptr self src)
+
+global arena : Arena
+
+type+ ARef
+    @@ memo
+    inline __= (cls T)
+        let ET = cls.ElementType
+        static-if (imply? T ET)
+            inline (self other)
+                'store arena other self
+
+    @@ memo
+    inline __imply (cls T)
+        let ET = cls.ElementType
+        static-if (imply? ET T)
+            inline (self)
+                imply ('load arena self) T
+
+    @@ memo
+    inline __as (cls T)
+        let ET = cls.ElementType
+        static-if (as? ET T)
+            inline (self)
+                as ('load arena self) T
+
+    inline tomemref (self)
+        ptrtoref ('aptrtoptr arena self)
+
+    fn __repr (self)
+        repr (tomemref self)
+
+    inline __toptr (self)
+        bitcast self ((typeof self) . APointerType)
+
+type+ APointer
+    inline __toref (self)
+        bitcast self ((typeof self) . ARefType)
+
+from (methodsof arena) let alloc alloc-array
+
+let locarena =
+    gen-allocator-sugar
+        spice "locarena-copy" (expr-head T value)
+            spice-quote
+                let val = (alloc T)
+                dump (qualifiersof val)
+                'store arena (imply value T) val
+                @ val
+        spice "locarena-new" (expr-head T args...)
+            spice-quote
+                let val = (alloc T)
+                'store arena (T args...) val
+                @ val
+
+run-stage;
+
+locarena x = 0
+x = 2
+print (x + 3)
+print (as x u16)
+print (tupleof x)
+
+;
  No newline at end of file

          
A => testing/elemental.sc +61 -0
@@ 0,0 1,61 @@ 
+
+# likely inadequate scopes emulation of ELEMENTAL keyword from fortran
+
+using import itertools
+
+inline all-scalar? (x...)
+    va-lfold true
+        inline (k v s)
+            static-if (as? v Generator) false
+            else s
+        x...
+
+inline scalar->gen (x)
+    static-if (as? x Generator) x
+    else
+        inline nop ()
+        Generator nop
+            inline () true
+            inline () x
+            nop
+
+inline elemental (f)
+    inline (args...)
+        static-if (all-scalar? args...) (f args...)
+        else (imap (zip (va-map scalar->gen args...)) f)
+
+# let's test it!
+
+@@ elemental
+fn elem+ (x y)
+    x + y
+
+@@ elemental
+fn elem* (x y)
+    x * y
+
+@@ elemental
+fn elem*+ (x y z) # composition
+    elem+ (elem* x y) z
+
+local A = (arrayof i32 1 2 3)
+local B = (arrayof i32 4 5 6)
+local C = (arrayof i32 7 8 9)
+
+for x in (elem*+ A B C)
+    # output:
+        11
+        18
+        27
+    print x
+
+for x in (elem+ (elem* 4 B) C)
+    # output:
+        23
+        28
+        33
+    print x
+
+assert ((elem*+ 2 5 8) == 18)
+
+

          
A => testing/lc.sc +67 -0
@@ 0,0 1,67 @@ 
+
+using import itertools
+
+let λ = inline
+
+""""a test function
+fn... test (a b)
+    """"a test comment
+    a + b
+
+let scope =
+    sugar-eval sugar-scope
+print ('docstring scope 'test)
+print ('docstring test)
+
+λ t (f t) (t)
+λ f (f t) (f)
+
+λ Not (x)
+    λ (f t) (x t f)
+
+λ Bitmap (r00 r01 r10 r11)
+    λ (a b)
+        λ (f t)
+            a
+                λ () # a = 0
+                    b
+                        λ () (r00 f t) # b = 0
+                        λ () (r01 f t) # b = 1
+                λ () # a = 1
+                    b
+                        λ () (r10 f t) # b = 0
+                        λ () (r11 f t) # b = 1
+
+let And Or Xor =
+    Bitmap
+        λ (f t) (f); λ (f t) (f); λ (f t) (f); λ (f t) (t)
+    Bitmap
+        λ (f t) (f); λ (f t) (t); λ (f t) (t); λ (f t) (t)
+    Bitmap
+        λ (f t) (f); λ (f t) (t); λ (f t) (t); λ (f t) (f)
+
+λ T (a b)
+    call
+        And
+            (Xor a b)
+                λ () f
+                λ () t
+            b
+        λ () 0
+        λ () 1
+
+for x y in (dim 2 2)
+    if (x == 0)
+        if (y == 0)
+            print (T f f)
+        else
+            print (T f t)
+    else
+        if (y == 0)
+            print (T t f)
+        else
+            print (T t t)
+
+
+
+

          
A => testing/toposort.sc +73 -0
@@ 0,0 1,73 @@ 
+
+using import Set
+using import Array
+using import Rc
+
+inline toposort (edgef visitf vertices)
+    # vertex index, edge index
+    let vinit vvalid vat vnext = ((vertices as Generator))
+    let first = (vat (vinit))
+    let ET = (typeof first)
+
+    local visited : (Set ET)
+    let init valid at next = (((edgef first) as Generator))
+    local stack : (Array (tuple ET (va-map typeof (init))))
+
+    for vx in vertices
+        if (not (vx in visited))
+            'insert visited (copy vx)
+            'append stack (tupleof (copy vx) ((((edgef vx) as Generator))))
+            while (not (empty? stack))
+                let v it... = (unpack ('last stack))
+                let init valid at next = (((edgef v) as Generator))
+                'pop stack
+                if (valid it...)
+                    #print ">" v it...
+                    let vx = (at it...)
+                    'append stack (tupleof (copy v) (va-map copy (next it...)))
+                    if (not (vx in visited))
+                        'insert visited (copy vx)
+                        'append stack (tupleof (copy vx)
+                            ((((edgef vx) as Generator))))
+                else
+                    visitf v
+                    ;
+
+type+ (Array i32)
+    inline __hash (self)
+        fold (h = (hash 0)) for k in self
+            hash h k
+
+global arr : (Array (Rc (Array i32)))
+global indices : (Array i32)
+fn addnode (arr edges...)
+    local edges : (Array i32)
+    va-map
+        inline (i)
+            'append edges i
+        edges...
+    'append arr (Rc.wrap (deref edges))
+    'append indices ((countof indices) as i32)
+inline addnode (edges...)
+    addnode arr edges...
+
+addnode 6 1 2 3 5 # 0
+addnode; # 1
+addnode 3 # 2
+addnode 4 5 # 3
+addnode 9 # 4
+addnode; # 5
+addnode 9 4 # 6
+addnode 6 # 7
+addnode 7 # 8
+addnode 10 12 11 # 9
+addnode; # 10
+addnode 12 # 11
+addnode; # 12
+
+toposort
+    inline (vertex)
+        ((arr @ vertex) as Generator)
+    inline (vertex)
+        print vertex
+    indices

          
M testing/voxel_bvh.sc +130 -17
@@ 18,12 18,12 @@ fn df (p)
                 #radians 11.0
                 #radians 0.0
             p
-    #sdOr
+    sdOr
         sdSub
             sdSphere p 0.8
             sdSphere (p - (vec3 0.3 -0.3 0)) 0.8
         sdTorus (vec3 (p.x - 0.3) 0 (p.y + 0.3)) (vec2 0.4 0.1)
-    sdOr
+    #sdOr
         sdBox op (vec3 0.3)
         sdSub
             sdBox p (vec3 0.6)

          
@@ 40,7 40,7 @@ fn df (p)
         sdTorus ((p - (vec3 0.5 0 0)) . xzy) (vec2 0.35 0.05)
         0.6
 
-let MAPDIM = 64
+let MAPDIM = 128
 
 global distmap : (Array f32)
 'resize distmap (MAPDIM * MAPDIM) 0.0

          
@@ 158,7 158,7 @@ for x y in (dim MAPDIM MAPDIM)
     idx := (index x y)
     deltamap @ idx +=
         do  # count lines
-            if (s11 == 0)
+            if (s11 == 1)
                 s0 := (g (x + 1) y)
                 s1 := (g x (y + 1))
                 s2 := (g (x - 1) y)

          
@@ 277,9 277,11 @@ write-string outp
         id="svg">
 
         <rect x="0" y="0" width="800" height="800" fill="white"/>
-        <g transform="scale(12.5,12.5) translate(0,0)">
+        <g transform="scale(6.25,6.25) translate(0,0)">
+
 
-fn descend (id level sat sat2 outp bounds numblocks maxlevel)
+
+fn descend (id level sat sat2 outp bounds numblocks maxlevel slots)
     let dv = (volume sat bounds)
     if (dv == 0) # empty
         return;

          
@@ 287,7 289,10 @@ fn descend (id level sat sat2 outp bound
         return;
     let v = (volume bounds)
     let trim = (v - dv)
-    print id "level" level "bounds" bounds "trim" trim "volume" dv
+    #print id "level" level "bounds" bounds "trim" trim "volume" dv
+    if (id >= (countof slots))
+        'resize slots (id + 1) (ivec4 0)
+    slots @ id = bounds
     let x1 y1 x2 y2 = (unpack bounds)
     let w h = (x2 - x1) (y2 - y1)
     let m = 0.0

          
@@ 323,9 328,11 @@ fn descend (id level sat sat2 outp bound
         let v = (volume sat bounds)
         let pp = (perimeter bounds)
         inline testsplit (w x bestscore b1 b2)
-            let lbounds rbounds = (splitf x)
+            let lbounds rbounds lsbounds rsbounds = (splitf x)
             let lbounds = (tighten sat lbounds)
             let rbounds = (tighten sat rbounds)
+            let lsbounds = (tighten sat lsbounds)
+            let rsbounds = (tighten sat rsbounds)
             let lb = (volume lbounds)
             let lv = (volume sat lbounds)
             let rb = (volume rbounds)

          
@@ 334,6 341,11 @@ fn descend (id level sat sat2 outp bound
             let lo = (volume sat2 lbounds)
             let ro = (volume sat2 rbounds)
 
+            let lso = (volume sat2 lsbounds)
+            let lsb = (volume lsbounds)
+            let rso = (volume sat2 rsbounds)
+            let rsb = (volume rsbounds)
+
             let lsq = (sqvolume lbounds)
             let rsq = (sqvolume rbounds)
             let lsa = (sqaspect lbounds)

          
@@ 348,22 360,26 @@ fn descend (id level sat sat2 outp bound
             #score := (sqrt ((lsq + rsq) as f32)) + ((lb - lv) ** 2 + (rb - rv) ** 2) as f32
             let lm rm = (lb - lv) (rb - rv)
             #err_trim := lm ** 2 + rm ** 2
-            err_trim := ((lm / b) ** 2) + ((rm / b) ** 2)
-
-            print id err_trim
+            err_trim := (lm ** 2) + (rm ** 2)
 
             let lbb rbb = (lp - lo) (rp - ro)
             score :=
                 do
                     # prefer perfect solutions
-                    if ((lm == rm) & (lm == 0)) 0.0
+                    if ((lm == rm) & (lm == 0)) 0
                     #elseif (((min lo ro) == 0) & ((max lo ro) == 4)) 1
                     else
                         #2 + (max (lo - 1) (ro - 1))
-                        ((2 + (max (lo // 2) (ro // 2))) as f32) #+ err_trim
+                        #2 + (max (lo // 2 + lm // 8) (ro // 2 + rm // 8))
+                        2 + (max (lo // 2) (ro // 2))
+                        #2 + (lo - lso + lm) ** 2 + ro ** 2
                         #2 + (max lo ro)
+                        #2 + (max lm rm)
+                        #2 + (max ((lo + lm) // 2) ((ro + rm) // 2))
+                        #2 + (max lso rso)
                         #(lo - ro) ** 2
                         #err_trim
+                        #lv ** 2 + rv ** 2 + err_trim
 
             #score := lm ** 2 + rm ** 2
             #score := (lo - ro) ** 2 + lbb ** 2 + rbb ** 2

          
@@ 404,11 420,15 @@ fn descend (id level sat sat2 outp bound
                 split inf (ivec4 0) (ivec4 0) (y1 + 1) y2
                     inline (y)
                         _ (ivec4 x1 y1 x2 y) (ivec4 x1 y x2 y2)
+                            ivec4 x1 (y - 1) x2 y
+                            ivec4 x1 y x2 (y + 1)
             else
                 # vertical split
                 split inf (ivec4 0) (ivec4 0) (x1 + 1) x2
                     inline (x)
                         _ (ivec4 x1 y1 x y2) (ivec4 x y1 x2 y2)
+                            ivec4 (x - 1) y1 x y2
+                            ivec4 x y1 (x + 1) y2
 
 
     let b1 b2 =

          
@@ 418,12 438,15 @@ fn descend (id level sat sat2 outp bound
                 split inf (ivec4 0) (ivec4 0) (y1 + 1) y2
                     inline (y)
                         _ (ivec4 x1 y1 x2 y) (ivec4 x1 y x2 y2)
+                            ivec4 x1 (y - 1) x2 y
+                            ivec4 x1 y x2 (y + 1)
             # vertical split
             let vscore vb1 vb2 =
                 split inf (ivec4 0) (ivec4 0) (x1 + 1) x2
                     inline (x)
                         _ (ivec4 x1 y1 x y2) (ivec4 x y1 x2 y2)
-            print id hscore vscore
+                            ivec4 (x - 1) y1 x y2
+                            ivec4 x y1 (x + 1) y2
             if (hscore < vscore)
                 _ hb1 hb2
             elseif (hscore > vscore)

          
@@ 441,12 464,13 @@ fn descend (id level sat sat2 outp bound
                     _ vb1 vb2
 
     level := level + 1
-    this-function (id << 1) level sat sat2 outp b1 numblocks maxlevel
-    this-function ((id << 1) + 1) level sat sat2 outp b2 numblocks maxlevel
+    this-function ((id << 1) + 1) level sat sat2 outp b2 numblocks maxlevel slots
+    this-function (id << 1) level sat sat2 outp b1 numblocks maxlevel slots
 
 local numblocks = 0
 local maxlevel = 0
-descend 0 0 sat sat2 (view outp) bounds numblocks maxlevel
+local slots : (Array ivec4)
+descend 1 0 sat sat2 (view outp) bounds numblocks maxlevel slots
 
 write-string outp
     """"</g>

          
@@ 455,4 479,93 @@ drop outp
 
 print numblocks "blocks," (maxlevel + 1) "levels"
 
+local slotcounts : (Array i32)
+let TS = (countof slots)
+'resize slotcounts TS 0
+for i in (rrange (countof slotcounts))
+    if ((slots @ i) != (ivec4 0))
+        slotcounts @ i = 1
+    let k0 = (i << 1)
+    let k1 = (k0 + 1)
+    if (k0 < TS)
+        slotcounts @ i += slotcounts @ k0
+    if (k1 < TS)
+        slotcounts @ i += slotcounts @ k1
+
+local outslots : (Array ivec4)
+fn regentree (inid outid slots slotcounts outslots)
+    returning bool
+    #if (inid >= (countof slots))
+        return;
+    if ((slots @ inid) == (ivec4 0))
+        return false
+    if (outid >= (countof outslots))
+        'resize outslots (outid + 1) (ivec4 0)
+    outslots @ outid = slots @ inid
+    #print inid "->" outid
+    let outid0 = ((outid << 2) - 2)
+    let inid0 = (inid << 1)
+    let inid1 = (inid0 + 1)
+    if (inid1 >= (countof slotcounts))
+        return true
+    let inid0 inid1 =
+        if ((slotcounts @ inid0) < (slotcounts @ inid1))
+            _ inid1 inid0
+        else
+            _ inid0 inid1
+    let inid00 = (inid0 << 1)
+    let inid01 = (inid00 + 1)
+    let inid10 = (inid1 << 1)
+    let inid11 = (inid10 + 1)
+    local x = 0
+    if (inid00 >= (countof slotcounts))
+        if (this-function inid0 (outid0 + x) slots slotcounts outslots)
+            x += 1
+    else
+        if ((slotcounts @ inid00) < (slotcounts @ inid01))
+            if (this-function inid01 (outid0 + x) slots slotcounts outslots)
+                x += 1
+            if (this-function inid00 (outid0 + x) slots slotcounts outslots)
+                x += 1
+        else
+            if (this-function inid00 (outid0 + x) slots slotcounts outslots)
+                x += 1
+            if (this-function inid01 (outid0 + x) slots slotcounts outslots)
+                x += 1
+    if (inid10 >= (countof slotcounts))
+        if (this-function inid1 (outid0 + x) slots slotcounts outslots)
+            x += 1
+    else
+        if ((slotcounts @ inid10) < (slotcounts @ inid11))
+            if (this-function inid11 (outid0 + x) slots slotcounts outslots)
+                x += 1
+            if (this-function inid10 (outid0 + x) slots slotcounts outslots)
+                x += 1
+        else
+            if (this-function inid10 (outid0 + x) slots slotcounts outslots)
+                x += 1
+            if (this-function inid11 (outid0 + x) slots slotcounts outslots)
+                x += 1
+    true
+
+    #let inid0 inid1 =
+        if ((slotcounts @ inid0) < (slotcounts @ inid1))
+            _ inid1 inid0
+        else
+            _ inid0 inid1
+
+regentree 1 1 slots slotcounts outslots
+
+let slots = outslots
+
+print "table size" (countof slots)
+for i rc in (enumerate slots)
+    let x1 y1 x2 y2 = (va-map u32 (unpack rc))
+    let code = (x1 | (y1 << 8) | (x2 << 16) | (y2 << 24))
+    io-write!
+        .. "0x" (hex code) "u, "
+    if ((i % 8) == 7)
+        io-write! "\n"
+io-write! "\n"
+
 ;