8ddf0dc19b5f — Leonard Ritter 10 days ago
* CADAG provides memory handles that can be dispatched to types
2 files changed, 302 insertions(+), 19 deletions(-)

M lib/tukan/CADAG.sc
A => testing/test_cadag.sc
M lib/tukan/CADAG.sc +202 -19
@@ 7,6 7,7 @@ using import Array
 using import Map
 using import Set
 using import Capture
+using import String
 
 using import .SHA256
 

          
@@ 17,13 18,6 @@ let u32_size = (sizeof u32)
 type Id
 
     @@ memo
-    inline __imply (cls T)
-        static-if (T == u32)
-            storagecast
-        elseif (T == integer)
-            storagecast
-
-    @@ memo
     inline __== (cls T)
         static-if (T < this-type)
             inline (a b)

          
@@ 41,10 35,21 @@ type Id
 'define-symbol Id '__copy integer.__copy
 'define-symbol Id '__hash integer.__hash
 
+let AnyId = (Id Nothing)
+
 type+ Id
     inline __tobool (self)
         (storagecast self) as bool
 
+    @@ memo
+    inline __imply (cls T)
+        static-if (T == u32)
+            storagecast
+        elseif (T == integer)
+            storagecast
+        elseif (T == AnyId)
+            inline (self) (bitcast self AnyId)
+
 let NoId = (nullof (Id Nothing))
 
 ################################################################################

          
@@ 159,8 164,8 @@ fn _flexible-struct-type (T)
             let ET = ('element@ T (count - 1))
             if (('kind ET) == type-kind-array)
                 if ('unsized? ET)
-                    return ('element@ ET 0)
-    Nothing
+                    return ('element@ ET 0) (count - 1)
+    _ Nothing -1
 
 spice flexible-struct-type (T)
     T as:= type

          
@@ 168,6 173,15 @@ spice flexible-struct-type (T)
 
 ################################################################################
 
+fn riff->string (code)
+    local str : String
+    'resize str 4
+    str @ 0 = (code & 0xff:u32) as char
+    str @ 1 = ((code >> 8) & 0xff:u32) as char
+    str @ 2 = ((code >> 16) & 0xff:u32) as char
+    str @ 3 = ((code >> 24) & 0xff:u32) as char
+    str
+
 spice RIFF (name)
     name as:= string
     if ((countof name) != 4)

          
@@ 188,6 202,7 @@ struct TypeInfo plain
 struct CADAGEnvData
     type->info-map : (Map type TypeInfo)
     typeid->type-map : (Map u32 type)
+    name->typeid-map : (Map string u32)
 
     inline __drop (self)
         print "drop"

          
@@ 290,6 305,31 @@ type CADAG < Struct
             error
                 .. "no such typeid: " (repr code)
 
+    spice dispatch-type (cls typeid ptr ...)
+        let self = (getinstance cls)
+        let sw = (sc_switch_new typeid)
+        let mutable? = ('writable? ('typeof ptr))
+        for arg in ('args ...)
+            let k v = ('dekey arg)
+            if (k == unnamed)
+                sc_switch_append_default sw `(v)
+            else
+                name := (k as string)
+                let code =
+                    try (copy ('get self.name->typeid-map name))
+                    else
+                        error
+                            .. "cannot dispatch unbound type name: " name
+                let T =
+                    try (deref ('get self.typeid->type-map code))
+                    else Nothing
+                let PT = (pointer.type T)
+                let PT =
+                    if mutable? ('mutable PT)
+                    else PT
+                sc_switch_append_case sw code `(v (@ (ptr as PT)))
+        sw
+
     spice define-type (cls T name code ...)
         cls as:= type
         let self = (getinstance cls)

          
@@ 328,6 368,8 @@ type CADAG < Struct
                 dedup? = dedup?
         'set self.typeid->type-map code T
 
+        'set self.name->typeid-map name code
+
         let code = `code
         let enum-id-offset = (('@ cls '_enum-id-offset) as type)
         Switcher.stage-case enum-id-offset code

          
@@ 344,15 386,28 @@ type CADAG < Struct
         let dispatch-any-type = (('@ cls 'dispatch-any-type) as type)
         Switcher.stage-case dispatch-any-type code
             spice-quote
-                inline "#hidden" (code ptr f sz)
-                    f (@ (bitcast ptr @T)) sz
+                inline "#hidden" (code f) (f T)
 
         let do-dedup? = (('@ cls '_do-dedup?) as type)
         Switcher.stage-case do-dedup? code
             spice-quote
                 inline "#hidden" () dedup?
+
+        let factory = (('@ cls 'FactoryType) as type)
+        'set-symbol factory (Symbol name)
+            spice-quote
+                inline (self ...)
+                    'store (bitcast self cls) T ...
+
         ;
 
+    inline vacount (cls typeid sz)
+        cls.dispatch-any-type typeid
+            inline (T)
+                let ET idx = (flexible-struct-type T)
+                static-if (ET == Nothing) 0:u32
+                else ((sz * u32_size - (sizeof T)) // (sizeof ET))
+
 run-stage;
 
 let memset =

          
@@ 364,6 419,29 @@ inline alignoffsetu (offset align)
     """"align `offset` up to `align`, which must be a power of 2
     (offset + align - 1) & -align
 
+type Handle
+    inline __dispatch (self ...)
+        let cls = (typeof self)
+        let typeid sz ptr = (unpack (storagecast self))
+        'dispatch-type cls.CADAGType typeid ptr ...
+
+    inline __unpack (self)
+        unpack (storagecast self)
+
+    fn vacount (self)
+        let cls = (typeof self)
+        let typeid sz = (unpack (storagecast self))
+        'vacount cls.CADAGType typeid sz
+
+    let name =
+        Accessor
+            inline (self key)
+                let cls = (typeof self)
+                let typeid sz ptr = (unpack (storagecast self))
+                'typenameof cls.CADAGType typeid
+
+type CADAGFactory
+
 type+ CADAG
 
     inline new-type (name)

          
@@ 393,6 471,28 @@ type+ CADAG
                 fn typenameof (cls typeid)
                     _get-typename typeid
 
+                let factory =
+                    Accessor
+                        inline (value key)
+                            let cls = (typeof value)
+                            bitcast (view value) cls.FactoryType
+
+        let HandleType =
+            type (.. name "Handle") < Handle : (tuple u32 u32 @u32)
+                let CADAGType = T
+
+        let MutableHandleType =
+            type (.. name "MutableHandle") < Handle : (tuple u32 u32 (mutable @u32))
+                let CADAGType = T
+
+        let AT =
+            type (.. name "Factory") < CADAGFactory :: (storageof T)
+                let CADAGType = T
+
+        'define-symbol T 'FactoryType AT
+        'define-symbol T 'HandleType HandleType
+        'define-symbol T 'MutableHandleType MutableHandleType
+
         'define-type T Nothing "undefined" 0:u32
         T
 

          
@@ 438,12 538,12 @@ type+ CADAG
                 tostring (alignof T)
         static-if (ET == Nothing)
             sz := (((sizeof T) + (u32_size - 1)) // u32_size) as u32
-            inline (self)
+            fn (self)
                 let a b = (allocate self typeid sz)
                 _ (bitcast a IdType) (bitcast b (mutable @T))
         else
             # flexible array
-            inline (self numelements)
+            fn (self numelements)
                 let numelements =
                     static-if (none? numelements) 0
                     else numelements

          
@@ 455,6 555,14 @@ type+ CADAG
     inline... alloc (self, T : type, ...)
         (alloc-func (typeof self) T) self ...
 
+    fn... handleof (self, offset : u32)
+        let cls = (typeof self)
+        let typeid sz = ('headerof self offset)
+        let ptr = ('load self offset)
+        bitcast
+            ((storageof cls.HandleType) typeid sz ptr)
+            cls.HandleType
+
     fn... headerof (self, offset : u32)
         _
             deref (self.words @ offset)

          
@@ 581,7 689,7 @@ type+ CADAG
                     'set aliases oldid newid
         let visit =
             va-option visit ...
-                inline (finalize md ptr)
+                inline (finalize handle)
                     let newid = (finalize)
                     #report "done" md.id "->" newid (string (get-typename md.typeid))
                     newid

          
@@ 611,7 719,10 @@ type+ CADAG
                         let newid ptr = ('allocate newmodule (copy md.typeid) (copy md.size))
                         memcpy ptr stackptr (u32_size * md.size)
                         newid
-                let newid = (visit finalize md stackptr)
+                let handle = (bitcast
+                    ((storageof cls.MutableHandleType) md.typeid md.size stackptr)
+                    cls.MutableHandleType)
+                let newid = (visit finalize handle)
                 let oldid = (copy md.id)
                 on-alias oldid newid
                 # clear

          
@@ 640,10 751,80 @@ type+ CADAG
             assert (idref == oldid)
             idref = newid
 
-    fn store (self value)
-        let id ptr = (alloc self (typeof value))
+    @@ memo
+    inline store-func (T)
+        static-if ((storageof T) < aggregate)
+            let ET idx = (flexible-struct-type T)
+            let ET... =
+                static-if ((storageof T) < aggregate)
+                    elementsof T
+                else T
+            let ETcount = (va-countof ET...)
+            static-if (ET == Nothing) # not variadic
+                inline (self ...)
+                    let id ptr = (alloc self T)
+                    let ptr = (@ ptr)
+                    va-map
+                        inline (i)
+                            (extractvalue ptr i) = (imply (va@ i ...) (va@ i ET...))
+                        va-range ETcount
+                    id
+            else
+                let ETcount = (ETcount - 1)
+                inline (self ...)
+                    let argcount = (va-countof ...)
+                    let extra = (argcount - ETcount)
+                    let id ptr = (alloc self T extra)
+                    let ptr = (@ ptr)
+                    va-map
+                        inline (i)
+                            (extractvalue ptr i) = (va@ i ...)
+                        va-range ETcount
+                    let tail = (extractvalue ptr idx)
+                    va-map
+                        inline (i)
+                            (extractvalue tail i) = (va@ (i + ETcount) ...)
+                        va-range extra
+                    id
+        else
+            inline (self value)
+                let id ptr = (alloc self T)
+                let ptr = (@ ptr)
+                ptr = value
+                id
+
+    inline... store (self, T : type, ...)
+        (store-func T) self ...
+    case (self, value)
+        (store-func (typeof value)) self value
+    #
+        let T = (typeof value)
+
+        let ET idx = (flexible-struct-type T)
+        let argcount = (va-countof ...)
+        static-if (ET == Nothing) # not variadic
+
+        else # variadic
+        let id ptr = (alloc self T extra)
+
+        let id ptr = (alloc self T)
+
         @ptr = value
         id
+    #case (self, value, ...)
+        let T = (typeof value)
+        let ET idx = (flexible-struct-type T)
+        static-assert (ET != Nothing)
+        let extra = (va-countof ...)
+        let id ptr = (alloc self T extra)
+        let ptr = (@ ptr)
+        ptr = value
+        let tail = (extractvalue ptr idx)
+        va-map
+            inline (i)
+                tail @ i = (va@ i ...)
+            va-range extra
+        id
 
     fn offsetof (self id)
         (id as u32) + 2

          
@@ 666,7 847,9 @@ type+ CADAG
             default-styler style-operator " = "
             default-styler style-keyword
                 string ('typenameof cls typeid)
-            cls.dispatch-any-type typeid ptr value-typeid-repr sz
+            cls.dispatch-any-type typeid
+                inline (T)
+                    value-typeid-repr (@ (bitcast ptr @T)) sz
 
     fn dump (self)
         descend self ('rootid self)

          
@@ 675,5 858,5 @@ type+ CADAG
                     print ('repr self md.id)
 
 do
-    let CADAG Id RIFF
+    let CADAG Id AnyId NoId RIFF riff->string
     locals;

          
A => testing/test_cadag.sc +100 -0
@@ 0,0 1,100 @@ 
+
+using import Capture
+
+import ..lib.tukan.use
+using import tukan.CADAG
+
+inline print-offsets (cls T)
+    typeid := ('typeidof cls T)
+    report T "typeid" typeid "offsets:"
+    for i in (infinite-range usize)
+        ofs := ('enum-id-offset cls typeid i)
+        if (ofs > 200:usize)
+            break;
+        report i "=" ofs
+
+do
+    # generate a new DAG module type
+    let M = (CADAG "TestDAG")
+    from (methodsof M) let define-type
+    let T =
+        tuple
+            u32
+            array (tuple u32 (Id u32)) 4
+            array u32 4
+            u32
+            Id u32
+            u32
+            Id u32
+            u32
+            array (tuple u32 (Id u32))
+    define-type T "testT" 10:u32
+    print-offsets M T
+    print "done."
+
+
+do
+    # generate a new DAG module type
+    let TestDAG = (CADAG "TestDAG")
+    from (methodsof TestDAG) let define-type
+
+    # register the types / instructions we want to use in the DAG
+    # type, printable name, persistent typeid, options...
+    define-type u32 "const" (RIFF "CNST")
+        #dedup = false
+
+    let u32x3 = (array (Id u32) 3)
+    define-type u32x3 "vec3" (RIFF "VEC3")
+
+    let i32_id = (tuple i32 AnyId)
+    let u32var = (tuple u32 (array i32_id))
+    define-type u32var "u32..." (RIFF "U32*")
+
+    # instantiate a module
+    local module : TestDAG
+
+    from (methodsof module) let store load rootid headerof transform descend
+
+    from (methodsof module.factory) let const vec3 u32...
+
+    # store 4 nodes in DAG
+    let k = (const 10:u32)
+    let m = (const 20:u32)
+    u32... 25
+        i32_id 1 k
+        i32_id 2 m
+        i32_id 3 k
+        i32_id 4
+            vec3 k k m
+
+    # perform a topological transform where we increment the constant values
+    let newmodule newid =
+        transform (rootid)
+            visit =
+                capture (finalize handle) {&module}
+                    dispatch handle
+                    case const (self)
+                        print self
+                        self += 1
+                    case vec3 (self)
+                        print (self @ 0) (self @ 1) (self @ 2)
+                        dispatch ('handleof module (self @ 0))
+                        case const (self)
+                            print "yes is a const"
+                        default;
+                    case u32... (self)
+                        print ('vacount handle)
+                    default
+                        print "unhandled:" (string handle.name)
+                    finalize;
+
+    # perform an identity transform and swap out the new module
+        all transformations are immutable.
+    #let newmodule newid = (transform (rootid))
+    #module = newmodule
+    module = newmodule
+    #assert (newid == (rootid))
+    #descend newid
+    'dump module
+
+    ;
  No newline at end of file