5d542c5d17f9 — Leonard Ritter 12 days ago
* dragon: instancing support
1 files changed, 226 insertions(+), 146 deletions(-)

M testing/dragon.sc
M testing/dragon.sc +226 -146
@@ 159,107 159,36 @@ fn... gen-id-offset-func (QT : type)
 
 ################################################################################
 
+spice RIFF (name)
+    name as:= string
+    if ((countof name) != 4)
+        error "RIFF code must have four characters"
+    |
+        (name @ 0) as u32
+        (name @ 1) as u32 << 8
+        (name @ 2) as u32 << 16
+        (name @ 3) as u32 << 24
+
+################################################################################
+
 struct TypeInfo plain
     typeid : u32
     name : string
     dedup? : bool = true
 
-global type->info-map : (Map type TypeInfo)
-global typeid->type-map : (Map u32 type)
-
-switcher enum-id-offset
-    default -1:usize
-switcher get-typename
-    default ("?undefined?" as rawstring)
-switcher dispatch-any-type
-    default
-        assert false "cannot dispatch type"
-        unreachable;
-switcher do-dedup?
-    default false
+struct ModuleEnvData
+    type->info-map : (Map type TypeInfo)
+    typeid->type-map : (Map u32 type)
 
-spice typeidof (T)
-    T as:= type
-    if (not ('in? type->info-map T))
-        error
-            .. "type " (repr T) " has no typeinfo"
-    ('getdefault type->info-map T (TypeInfo 0 "")) . typeid
-
-spice typeinfo (T)
-    T as:= type
-    if (not ('in? type->info-map T))
-        error
-            .. "type " (repr T) " has no typeinfo"
-    'getdefault type->info-map T (TypeInfo 0 "")
-
-spice typeoftypeid (code)
-    code as:= u32
-    try ('get typeid->type-map code)
-    else
-        error
-            .. "no such typeid: " (repr code)
+    inline __drop (self)
+        print "drop"
 
-spice dragon-type (T name code ...)
-    T as:= type
-    code as:= u32
-    name as:= string
-    local dedup? = true
-    for arg in ('args ...)
-        let k v = ('dekey arg)
-        switch k
-        case 'dedup
-            dedup? = ((sc_prove v) as bool)
-        default;
-    let name =
-        if (name == "") (tostring T)
-        else name
-    if ('in? type->info-map T)
-        let info =
-            try ('get type->info-map T)
-            else
-                unreachable;
-        error
-            .. "type " (repr T) " already mapped to typeid " (repr info.typeid)
-    if ('in? typeid->type-map code)
-        let T =
-            try ('get typeid->type-map code)
-            else
-                unreachable;
-        error
-            .. "typeid " (repr code) " already mapped to type " (repr T)
+let InstancePointerType = (viewof (mutable @ModuleEnvData) 999)
 
-    'set type->info-map T
-        TypeInfo
-            typeid = code
-            name = name
-            dedup? = dedup?
-    'set typeid->type-map code T
-    let code = `code
-    'stage-case enum-id-offset code
-        spice-quote
-            inline "#hidden" (code index)
-                ([(gen-id-offset-func T)] index)
-    'stage-case get-typename code
-        spice-quote
-            inline "#hidden" ()
-                name as rawstring
-    'stage-case dispatch-any-type code
-        spice-quote
-            inline "#hidden" (code ptr f)
-                f (@ (bitcast ptr @T))
-    'stage-case do-dedup? code
-        spice-quote
-            inline "#hidden" () dedup?
-    ;
-
-fn do-dedup? (typeid)
-    do-dedup? typeid
-
-fn enum-id-offset (typeid index)
-    enum-id-offset typeid index
-
-fn get-typename (typeid)
-    get-typename typeid
+spice new-env-data ()
+    let data = (malloc ModuleEnvData)
+    store (ModuleEnvData) data
+    sc_const_pointer_new voidstar data
 
 fn value-typeid-repr (value)
     let T = ('typeof value)

          
@@ 295,31 224,106 @@ spice value-typeid-repr (value)
 
 run-stage;
 
-inline print-offsets (T)
-    report T "typeid" (typeidof T) "offsets:"
-    for i in (infinite-range usize)
-        ofs := (enum-id-offset (typeidof T) i)
-        if (ofs > 1000:usize)
-            break;
-        report i "=" ofs
+type Module < Struct
+
+    inline getinstance (T)
+        let self = ('@ (T as type) 'instance)
+        # hack to turn pointer into view
+        let ptr = (sc_const_pointer_extract self)
+        let ptr = (bitcast ptr InstancePointerType)
+        let val = (alloca InstancePointerType)
+        store ptr val
+        let self = @@val
+        self
+
+    spice typeidof (cls T)
+        let self = (getinstance cls)
+        T as:= type
+        if (not ('in? self.type->info-map T))
+            error
+                .. "type " (repr T) " has no typeinfo"
+        ('getdefault self.type->info-map T (TypeInfo 0 "")) . typeid
+
+    spice typeinfo (cls T)
+        let self = (getinstance cls)
+        T as:= type
+        if (not ('in? self.type->info-map T))
+            error
+                .. "type " (repr T) " has no typeinfo"
+        'getdefault self.type->info-map T (TypeInfo 0 "")
+
+    spice typeoftypeid (cls code)
+        let self = (getinstance cls)
+        cls as:= type
+        code as:= u32
+        try ('get self.typeid->type-map code)
+        else
+            error
+                .. "no such typeid: " (repr code)
 
-#do
-    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))
-    dragon-type T "testT" 10:u32
-    print-offsets T
-    print "done."
+    spice define-type (cls T name code ...)
+        cls as:= type
+        let self = (getinstance cls)
+        T as:= type
+        code as:= u32
+        name as:= string
+        local dedup? = true
+        for arg in ('args ...)
+            let k v = ('dekey arg)
+            switch k
+            case 'dedup
+                dedup? = ((sc_prove v) as bool)
+            default;
+        let name =
+            if (name == "") (tostring T)
+            else name
+        if ('in? self.type->info-map T)
+            let info =
+                try ('get self.type->info-map T)
+                else
+                    unreachable;
+            error
+                .. "type " (repr T) " already mapped to typeid " (repr info.typeid)
+        if ('in? self.typeid->type-map code)
+            let T =
+                try ('get self.typeid->type-map code)
+                else
+                    unreachable;
+            error
+                .. "typeid " (repr code) " already mapped to type " (repr T)
 
-dragon-type Nothing "undefined" 0:u32
+        'set self.type->info-map T
+            TypeInfo
+                typeid = code
+                name = name
+                dedup? = dedup?
+        'set self.typeid->type-map code T
+        let code = `code
+        let enum-id-offset = (('@ cls '_enum-id-offset) as type)
+        Switcher.stage-case enum-id-offset code
+            spice-quote
+                inline "#hidden" (code index)
+                    ([(gen-id-offset-func T)] index)
+
+        let get-typename = (('@ cls '_get-typename) as type)
+        Switcher.stage-case get-typename code
+            spice-quote
+                inline "#hidden" ()
+                    name as rawstring
+
+        let dispatch-any-type = (('@ cls 'dispatch-any-type) as type)
+        Switcher.stage-case dispatch-any-type code
+            spice-quote
+                inline "#hidden" (code ptr f)
+                    f (@ (bitcast ptr @T))
+
+        let do-dedup? = (('@ cls '_do-dedup?) as type)
+        Switcher.stage-case do-dedup? code
+            spice-quote
+                inline "#hidden" () dedup?
+        ;
+
+run-stage;
 
 let memset =
     extern 'memset (function void (mutable @u32) u32 usize)

          
@@ 331,20 335,52 @@ inline alignoffsetu (offset align)
     """"align `offset` up to `align`, which must be a power of 2
     (offset + align - 1) & -align
 
-struct Module
-    words : (Array u32)
+type+ Module
+
+    inline new-type (name)
+        let T =
+            struct (do name) < this-type
+                words : (Array u32)
+
+                let instance = (new-env-data)
+
+                switcher _enum-id-offset
+                    default -1:usize
+                switcher _get-typename
+                    default ("?undefined?" as rawstring)
+                switcher dispatch-any-type
+                    default
+                        assert false "cannot dispatch type"
+                        unreachable;
+                switcher _do-dedup?
+                    default false
+
+                fn do-dedup? (cls typeid)
+                    _do-dedup? typeid
 
-    inline __typecall (cls)
-        local self =
-            super-type.__typecall cls
-        do
-            # add null element
-            let words = self.words
-            'resize words 3
-            words @ 0 = 0:u32 # typeid
-            words @ 1 = 0:u32 # size
-            words @ 2 = 0:u32 # root id
-        deref self
+                fn enum-id-offset (cls typeid index)
+                    _enum-id-offset typeid index
+
+                fn typenameof (cls typeid)
+                    _get-typename typeid
+
+        'define-type T Nothing "undefined" 0:u32
+        T
+
+    inline __typecall (cls ...)
+        static-if (cls == this-type)
+            new-type ...
+        else
+            local self =
+                super-type.__typecall cls
+            do
+                # add null element
+                let words = self.words
+                'resize words 3
+                words @ 0 = 0:u32 # typeid
+                words @ 1 = 0:u32 # size
+                words @ 2 = 0:u32 # root id
+            deref self
 
     fn... allocate (self, typeid : u32, wordcount : u32)
         let words = self.words

          
@@ 364,9 400,9 @@ struct Module
         deref ('last self.words)
 
     @@ memo
-    inline alloc-func (T)
+    inline alloc-func (cls T)
         sz := (((sizeof T) + (u32_size - 1)) // u32_size) as u32
-        typeid := (typeidof T)
+        typeid := ('typeidof cls T)
         static-assert (constant? typeid)
         IdType := (Id T)
         static-assert ((alignof T) <= 4)

          
@@ 377,7 413,7 @@ struct Module
             _ (bitcast a IdType) (bitcast b (mutable @T))
 
     inline... alloc (self, T : type)
-        (alloc-func T) self
+        (alloc-func (typeof self) T) self
 
     fn... headerof (self, offset : u32)
         _

          
@@ 420,16 456,20 @@ struct Module
                     refindex = 0
 
     fn descend (self root ...)
+        let cls = (typeof self)
         let visit =
             va-option visit ...
                 inline (md ptr)
-                    report "done" md.id (string (get-typename md.typeid))
+                    report "done" md.id (string ('typenameof cls md.typeid))
+        let on-enter =
+            va-option on-enter ...
+                inline (id)
         local stack : DescendStack
         local seen : (Set u32)
         'push stack self root
         loop ()
             let md = ('peek stack)
-            let ofs = (enum-id-offset (copy md.typeid) (copy md.refindex))
+            let ofs = ('enum-id-offset cls (copy md.typeid) (copy md.refindex))
             if (ofs == -1:usize)
                 let stackptr = (& (self.words @ md.offset))
                 let oldid = (copy md.id)

          
@@ 446,6 486,7 @@ struct Module
                 let nextid = (copy (self.words @ ofs))
                 if (not ('in? seen nextid))
                     'insert seen nextid
+                    on-enter nextid
                     'push stack self nextid
 
     struct TransformStack

          
@@ 482,7 523,8 @@ struct Module
     let u256 = (integer 256)
 
     fn transform (self root ...)
-        local newmodule : this-type
+        let cls = (typeof self)
+        local newmodule : cls
         local dedup_map : (Map u256 u32)
         local aliases : (Map u32 u32)
         let alias =

          
@@ 507,12 549,12 @@ struct Module
         'push stack self root
         loop ()
             let md = ('peek stack)
-            let ofs = (enum-id-offset (copy md.typeid) (copy md.refindex))
+            let ofs = ('enum-id-offset cls (copy md.typeid) (copy md.refindex))
             vvv bind oldid newid
             if (ofs == -1:usize)
                 let stackptr = (& (stack.data @ md.offset))
                 capture finalize () {&newmodule &md stackptr &dedup_map}
-                    let dedup? = (do-dedup? md.typeid)
+                    let dedup? = ('do-dedup? cls md.typeid)
                     if dedup?
                         let digest = (sha256 (bitcast stackptr rawstring) (u32_size * md.size))
                         let digest = (@ (bitcast &digest @u256))

          
@@ 551,7 593,7 @@ struct Module
                 _ oldid newid
             # update reference in parent
             let md = ('peek stack)
-            let ofs = (enum-id-offset (copy md.typeid) (md.refindex - 1))
+            let ofs = ('enum-id-offset cls (copy md.typeid) (md.refindex - 1))
             let idref = (stack.data @ md.refoffset)
             assert (idref == oldid)
             idref = newid

          
@@ 573,6 615,7 @@ struct Module
         & (self.words @ offset)
 
     fn... repr (self, id : u32)
+        let cls = (typeof self)
         let typeid sz = ('headerof self id)
         let ptr = ('load self id)
         ..

          
@@ 580,9 623,9 @@ struct Module
                 .. "%" (tostring id)
             default-styler style-operator " = "
             default-styler style-keyword
-                string (get-typename typeid)
+                string ('typenameof cls typeid)
             " "
-            dispatch-any-type typeid ptr value-typeid-repr
+            cls.dispatch-any-type typeid ptr value-typeid-repr
 
     fn dump (self)
         descend self ('rootid self)

          
@@ 590,16 633,50 @@ struct Module
                 capture (md ptr) {&self}
                     print ('repr self md.id)
 
+run-stage;
+
+#inline print-offsets (T)
+    report T "typeid" (typeidof T) "offsets:"
+    for i in (infinite-range usize)
+        ofs := (enum-id-offset (typeidof T) i)
+        if (ofs > 1000:usize)
+            break;
+        report i "=" ofs
+
+#do
+    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))
+    dragon-type T "testT" 10:u32
+    print-offsets T
+    print "done."
+
+
 do
+    # generate a new DAG module type
+    let TestDAG = (Module "TestDAG")
+    from (methodsof TestDAG) let define-type
+
     # register the types / instructions we want to use in the DAG
-    # type, printable name, persistent typeid
-    dragon-type u32 "const" 1:u32
+    # type, printable name, persistent typeid, options...
+    define-type u32 "const" (RIFF "CNST")
         dedup = false
 
     let u32x3 = (array (Id u32) 3)
-    dragon-type u32x3 "vec3" 2:u32
+    define-type u32x3 "vec3" (RIFF "VEC3")
 
-    local module : Module
+    # instantiate a module
+    local module : TestDAG
+
+
     from (methodsof module) let store load rootid headerof transform descend
 
     # store 4 nodes in DAG

          
@@ 608,6 685,8 @@ do
     store
         u32x3 k k m
 
+    'dump module
+
     # perform an identity transform and swap out the new module
         all transformations are immutable.
     let newmodule newid = (transform (rootid))

          
@@ 618,7 697,7 @@ do
             visit =
                 capture (finalize md ptr) {}
                     switch md.typeid
-                    case (typeidof u32)
+                    case ('typeidof TestDAG u32)
                         (@ ptr) += 1
                     default;
                     finalize;

          
@@ 627,4 706,5 @@ do
     descend newid
     'dump module
 
-    ;
  No newline at end of file
+    ;
+;
  No newline at end of file