d7146444f9ab — Leonard Ritter 10 days ago
* CADAG: improved constructor
* CADAG: Id and TypeId are local to the CADAG instance
2 files changed, 98 insertions(+), 51 deletions(-)

M lib/tukan/CADAG.sc
M testing/test_cadag.sc
M lib/tukan/CADAG.sc +80 -36
@@ 23,26 23,16 @@ type Id
             inline (a b)
                 (storagecast a) == (storagecast b)
 
-    @@ memo
-    inline Type (T)
-        type (.. "(Id " (tostring T) ")") < this-type : u32
-            let Type = T
-            let __typecall = integer.__typecall
-
-    inline __typecall (cls T)
-        Type T
-
 '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)
+        let AnyId = cls.CADAGType.AnyId
         static-if (T == u32)
             storagecast
         elseif (T == integer)

          
@@ 50,8 40,6 @@ type+ Id
         elseif (T == AnyId)
             inline (self) (bitcast self AnyId)
 
-let NoId = (nullof (Id Nothing))
-
 ################################################################################
 
 global id-offset-func-map : (Map type (tuple Value usize))

          
@@ 300,7 288,15 @@ type CADAG < Struct
 
     spice typeinfo (cls code)
         let self = (getinstance cls)
-        code as:= u32
+        cls as:= type
+        let TypeIdType = (('@ cls 'TypeId) as type)
+        if (('typeof code) != TypeIdType)
+            error
+                .. "typeid must be of type " (repr TypeIdType) ", not "
+                    repr ('typeof code)
+        if (not ('constant? code))
+            error "argument must be constant"
+        let code = ((sc_const_int_extract code) as u32)
         if (not ('in? self.typeid->info-map code))
             error
                 .. "typeid " (repr code) " has no typeinfo"

          
@@ 340,7 336,7 @@ type CADAG < Struct
                 sc_switch_append_case sw code `(v (@ (ptr as PT)))
         sw
 
-    spice define-type (cls T name code ...)
+    spice define-type (cls name code T ...)
         cls as:= type
         let self = (getinstance cls)
         T as:= type

          
@@ 372,6 368,13 @@ type CADAG < Struct
 
         'set self.name->typeid-map name code
 
+        #let IdType = (('@ cls 'Id) as type)
+        let TypeIdType = (('@ cls 'TypeId) as type)
+        let enumval = (sc_const_int_new TypeIdType code)
+
+        let namesym = (Symbol name)
+        'set-symbol TypeIdType namesym enumval
+
         let code = `code
         let enum-id-offset = (('@ cls '_enum-id-offset) as type)
         Switcher.stage-case enum-id-offset code

          
@@ 395,13 398,15 @@ type CADAG < Struct
             spice-quote
                 inline "#hidden" () dedup?
 
-        let factory = (('@ cls 'FactoryType) as type)
-        'set-symbol factory (Symbol name)
+        let builder = (('@ cls 'BuilderType) as type)
+        'set-symbol builder namesym
             spice-quote
                 inline (self ...)
-                    'store (bitcast self cls) code ...
+                    'store (bitcast self cls) enumval ...
 
-        ;
+        spice-quote
+            'define-symbol cls [(Symbol (.. "Id-" name))]
+                cls.Id enumval
 
     inline vacount (cls typeid sz)
         cls.dispatch-any-type typeid

          
@@ 421,6 426,8 @@ inline alignoffsetu (offset align)
     """"align `offset` up to `align`, which must be a power of 2
     (offset + align - 1) & -align
 
+type TypeId < CEnum
+
 type Handle
     let __dispatch =
         inline "#hidden" (self ...)

          
@@ 443,14 450,14 @@ type Handle
                 let typeid sz ptr = (unpack (storagecast self))
                 'typenameof cls.CADAGType typeid
 
-type CADAGFactory
+type CADAGBuilder
 
 type+ CADAG
-    let factory =
+    let builder =
         Accessor
             inline (value key)
                 let cls = (typeof value)
-                bitcast (view value) cls.FactoryType
+                bitcast (view value) cls.BuilderType
 
     inline new-type (name)
         let T =

          
@@ 487,15 494,52 @@ type+ CADAG
             type (.. name "MutableHandle") < Handle : (tuple u32 u32 (mutable @u32))
                 let CADAGType = T
 
-        let AT =
-            type (.. name "Factory") < CADAGFactory :: (storageof T)
+        let BuilderType =
+            type (.. name "Builder") < CADAGBuilder :: (storageof T)
+                let CADAGType = T
+
+        let TypeIdType =
+            type (.. name "TypeId") < TypeId : u32
+                let CADAGType = T
+
+                inline typeinfo (self)
+                    'typeinfo T self
+
+                fn __repr (self)
+                    ..
+                        sc_default_styler style-number
+                            string ('typenameof T self)
+                        sc_default_styler style-operator ":"
+                        repr (typeof self)
+
+        let IdType =
+            type (.. name "Id") < Id
                 let CADAGType = T
 
-        'define-symbol T 'FactoryType AT
-        'define-symbol T 'HandleType HandleType
-        'define-symbol T 'MutableHandleType MutableHandleType
+                @@ memo
+                inline __typecall (cls typeid)
+                    let info = ('typeinfo typeid)
+                    let T =
+                        type (.. "(" (tostring cls) " " info.name ")") < cls : u32
+                            let Type = info.T
+                            let TypeId = typeid
+                            let Name = info.name
+                    'define-symbol T '__typecall integer.__typecall
+                    T
 
-        'define-type T Nothing "undefined" 0:u32
+        type+ T
+            let BuilderType
+            let HandleType
+            let MutableHandleType
+            let Id = IdType
+            let TypeId = TypeIdType
+
+        'define-type T "none" 0:u32 Nothing
+
+        type+ T
+            let AnyId = T.Id-none
+            let NoId = (nullof AnyId)
+
         T
 
     inline __typecall (cls ...)

          
@@ 532,9 576,9 @@ type+ CADAG
 
     @@ memo
     inline alloc-func (cls typeid)
-        let T = (('typeinfo cls typeid) . T)
+        let T = (('typeinfo typeid) . T)
         let ET = (flexible-struct-type T)
-        IdType := (Id T)
+        IdType := (cls.Id typeid)
         static-assert ((alignof T) <= 4)
             .. "type " (tostring T) " must have alignment <= 4, but has "
                 tostring (alignof T)

          
@@ 554,7 598,7 @@ type+ CADAG
                 let a b = (allocate self typeid sz)
                 _ (bitcast a IdType) (bitcast b (mutable @T))
 
-    inline... alloc (self, typeid : u32, ...)
+    inline... alloc (self, typeid : TypeId, ...)
         (alloc-func (typeof self) typeid) self ...
 
     fn... handleof (self, offset : u32)

          
@@ 754,8 798,8 @@ type+ CADAG
             idref = newid
 
     @@ memo
-    inline store-func (cls typeid)
-        let T = (('typeinfo cls typeid) . T)
+    inline store-func (typeid)
+        let T = (('typeinfo typeid) . T)
         static-if ((storageof T) < aggregate)
             let ET idx = (flexible-struct-type T)
             let ET... =

          
@@ 822,8 866,8 @@ type+ CADAG
                 ptr = value
                 id
 
-    inline... store (self, typeid : u32, ...)
-        (store-func (typeof self) typeid) self ...
+    inline... store (self, typeid : TypeId, ...)
+        (store-func typeid) self ...
 
     fn offsetof (self id)
         (id as u32) + 2

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

          
M testing/test_cadag.sc +18 -15
@@ 15,51 15,54 @@ inline print-offsets (cls typeid)
 do
     # generate a new DAG module type
     let M = (CADAG "TestDAG")
+    from M let Id-none
     from (methodsof M) let define-type
-    let T =
+    define-type "testT" (RIFF "TEST")
         tuple
             u32
-            array (tuple u32 (Id u32)) 4
+            array (tuple u32 Id-none) 4
             array u32 4
             u32
-            Id u32
+            Id-none
             u32
-            Id u32
+            Id-none
             u32
-            array (tuple u32 (Id u32))
-    define-type T "testT" 10:u32
-    print-offsets M 10:u32
+            array (tuple u32 Id-none)
+    print-offsets M M.TypeId.testT
     print "done."
 
+run-stage;
+
 do
     # generate a new DAG module type
     let TestDAG = (CADAG "TestDAG")
+    from TestDAG let AnyId NoId
     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")
+    define-type "const" (RIFF "CNST") u32
         #dedup = false
 
-    define-type u32 "const2" (RIFF "CNS2")
+    define-type "const2" (RIFF "CNS2") u32
         #dedup = false
 
-    let u32x3 = (array (Id u32) 3)
-    define-type u32x3 "vec3" (RIFF "VEC3")
+    let u32x3 = (array AnyId 3)
+    define-type "vec3" (RIFF "VEC3") u32x3
 
     let i32_id = (tuple i32 AnyId)
     let u32var = (tuple u32 (array i32_id))
-    define-type u32var "u32x" (RIFF "U32*")
+    define-type "u32x" (RIFF "U32*") u32var
 
     let strtype = (tuple (array char))
-    define-type strtype "str" (RIFF "STR*")
+    define-type "str" (RIFF "STR*") strtype
 
     # instantiate a module
     local module : TestDAG
 
     from (methodsof module) let store load rootid headerof transform descend alloc
 
-    from (methodsof module.factory) let const const2 vec3 u32x str
+    from (methodsof module.builder) let const const2 vec3 u32x str
 
     # store 4 nodes in DAG
     let k = (const 10:u32)

          
@@ 82,7 85,7 @@ do
                         print self
                         self += 1
                     case const2 (self)
-                        return (('const module.factory (self + 10)) as u32)
+                        return (('const module.builder (self + 10)) as u32)
                     case vec3 (self)
                         print (self @ 0) (self @ 1) (self @ 2)
                         dispatch ('handleof module (self @ 0))