22fdfa9703f5 — Leonard Ritter 8 days ago
* CADAG: simplified interface
3 files changed, 76 insertions(+), 76 deletions(-)

M lib/tukan/CADAG/dot.sc
M lib/tukan/CADAG/init.sc
M testing/test_cadag.sc
M lib/tukan/CADAG/dot.sc +6 -5
@@ 28,6 28,7 @@ type+ CADAG
         'append tmp
             """"digraph "CADAG" {
                     ranksep=0.2 rankdir="TB";
+                    splines=ortho;
                     node [shape=box height=0.01 fontsize=8 fontname="sans"];
                     edge [arrowsize=0.3 fontsize=7 fontname="sans"];
         commit tmp

          
@@ 50,11 51,11 @@ type+ CADAG
                     let handle = ('handleof module id)
                     writeattr "label"
                         tostring
-                            .. "%" idstr " = " (string handle.name)
+                            .. "%" idstr " = " (string handle.typeid.name)
                     let typeid = (unpack handle)
-                    cls.dispatch-any-type typeid
-                        inline (T typeid)
-                            let info = ('typeinfo cls typeid)
+                    'dispatch typeid
+                        inline "#hidden" (code cls)
+                            let info = ('typeinfo cls code)
                             writeattr "fillcolor"
                                 translate-color info.fillcolor
                             writeattr "textcolor"

          
@@ 69,7 70,7 @@ type+ CADAG
                         'append tmp " -> "
                         'append tmp idstr
                         'append tmp " ["
-                        writeattr "label" (tostring k)
+                        writeattr "headlabel" (tostring k)
                         'append tmp "]"
                         'append tmp ";\n"
                         commit;

          
M lib/tukan/CADAG/init.sc +66 -67
@@ 50,7 50,7 @@ fn idtype? (QT)
 
 # given a type, produce a function that maps indices to byte offsets to Id
     fields within the type. the first invalid index will produce -1:usize
-fn... gen-id-offset-func (QT : type)
+fn... _gen-id-offset-func (QT : type)
     returning Value usize
     raising Error
     let QT = ('storageof QT)

          
@@ 145,6 145,9 @@ fn... gen-id-offset-func (QT : type)
     'set id-offset-func-map QT (tupleof idoffsets nextindex)
     _ idoffsets nextindex
 
+spice gen-id-offset-func (QT)
+    _gen-id-offset-func (QT as type)
+
 fn _flexible-struct-type (T)
     let T = ('storageof T)
     if (('kind T) == type-kind-tuple)

          
@@ 391,28 394,10 @@ type CADAG < Struct
         '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
-            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 f) (f T enumval)
-
-        let do-dedup? = (('@ cls '_do-dedup?) as type)
-        let dedup? = (copy ti.dedup?)
-        Switcher.stage-case do-dedup? code
-            spice-quote
-                inline "#hidden" () dedup?
+                inline "#hidden" (code f ...) (f enumval ...)
 
         let builder = (('@ cls 'BuilderType) as type)
         'set-symbol builder namesym

          
@@ 424,13 409,6 @@ type CADAG < Struct
             'define-symbol cls [(Symbol (.. "Id-" name))]
                 cls.Id enumval
 
-    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 =

          
@@ 443,6 421,52 @@ inline alignoffsetu (offset align)
     (offset + align - 1) & -align
 
 type TypeId < CEnum
+    inline dispatch (self handler args...)
+        let cls = (typeof self)
+        cls := cls.CADAGType
+        cls.dispatch-any-type self handler cls args...
+
+    inline typeinfo (self)
+        let cls = (typeof self)
+        cls := cls.CADAGType
+        'typeinfo cls self
+
+    fn... enum-id-offset (self, index : usize)
+        'dispatch self
+            inline "#hidden" (code cls index)
+                (gen-id-offset-func (('typeinfo cls code) . T)) index
+            index
+
+    inline vacount (self sz)
+        let cls = (typeof self)
+        cls := cls.CADAGType
+        'dispatch self
+            inline "#hidden" (code cls)
+                let T = (('typeinfo cls code) . T)
+                let ET idx = (flexible-struct-type T)
+                static-if (ET == Nothing) 0:u32
+                else ((sz * u32_size - (sizeof T)) // (sizeof ET))
+
+    fn __repr (self)
+        ..
+            sc_default_styler style-number (string self.name)
+            sc_default_styler style-operator ":"
+            repr (typeof self)
+
+    fn _dedup? (self)
+        'dispatch self
+            inline "#hidden" (code cls)
+                ('typeinfo cls code) . dedup?
+
+    fn _name (self)
+        'dispatch self
+            inline "#hidden" (code cls)
+                x := (('typeinfo cls code) . name) as rawstring
+                static-assert (constant? x)
+                x
+
+    let dedup? = (Accessor (inline (self) ('_dedup? (copy self))))
+    let name = (Accessor (inline (self) ('_name (copy self))))
 
 type Handle
     let __dispatch =

          
@@ 455,28 479,26 @@ type Handle
         unpack (storagecast self)
 
     fn vacount (self)
-        let cls = (typeof self)
         let typeid sz = (unpack (storagecast self))
-        'vacount cls.CADAGType typeid sz
+        'vacount typeid sz
 
     inline sources (self)
         let cls = (typeof self)
         let typeid sz ptr = (unpack (storagecast self))
         let cls = cls.CADAGType
         Generator
-            inline () (_ 0:u32 (('enum-id-offset cls typeid 0:u32) // u32_size))
+            inline () (_ 0:u32 (('enum-id-offset typeid 0:u32) // u32_size))
             inline (i wordofs) (wordofs < sz)
             inline (i wordofs) (copy (ptr @ wordofs))
             inline (i wordofs)
                 i := i + 1
-                _ i (('enum-id-offset cls typeid i) // u32_size)
+                _ i (('enum-id-offset typeid i) // u32_size)
 
-    let name =
+    let typeid =
         Accessor
             inline (self key)
                 let cls = (typeof self)
-                let typeid sz ptr = (unpack (storagecast self))
-                'typenameof cls.CADAGType typeid
+                ((storagecast self) @ 0) as TypeId
 
 type CADAGBuilder
 

          
@@ 494,25 516,10 @@ type+ CADAG
 
                 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
-
-                fn enum-id-offset (cls typeid index)
-                    _enum-id-offset typeid index
-
-                fn typenameof (cls typeid)
-                    _get-typename typeid
 
         let BuilderType =
             type (.. name "Builder") < CADAGBuilder :: (storageof T)

          
@@ 522,16 529,6 @@ type+ CADAG
             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 HandleType =
             type (.. name "Handle") < Handle : (tuple TypeIdType u32 @u32)
                 let CADAGType = T

          
@@ 638,8 635,9 @@ type+ CADAG
             cls.HandleType
 
     fn... headerof (self, offset : u32)
+        let cls = (typeof self)
         _
-            deref (self.words @ offset)
+            bitcast (deref (self.words @ offset)) cls.TypeId
             deref (self.words @ (offset + 1))
 
     struct StackEntry plain

          
@@ 693,7 691,7 @@ type+ CADAG
             'push stack self root
         loop ()
             let md = ('peek stack)
-            let ofs = ('enum-id-offset cls (copy md.typeid) (copy md.refindex))
+            let ofs = ('enum-id-offset ((copy md.typeid) as cls.TypeId) (copy md.refindex))
             let wordofs = (ofs // u32_size)
             if (wordofs >= md.size)
                 let oldid = (copy md.id)

          
@@ 774,7 772,7 @@ type+ CADAG
         'push stack self root
         loop ()
             let md = ('peek stack)
-            let ofs = ('enum-id-offset cls (copy md.typeid) (copy md.refindex))
+            let ofs = ('enum-id-offset ((copy md.typeid) as cls.TypeId) (copy md.refindex))
             let wordofs = (ofs // u32_size)
             vvv bind oldid newid
             if (wordofs >= md.size)

          
@@ 782,7 780,7 @@ type+ CADAG
                     if md.size (& (stack.data @ md.offset))
                     else (null as (mutable @u32))
                 capture finalize () {&newmodule &md stackptr &dedup_map}
-                    let dedup? = ('do-dedup? cls md.typeid)
+                    let dedup? = ((md.typeid as cls.TypeId) . dedup?)
                     if dedup?
                         local sha : SHA256
                         'hash sha (bitcast &md.typeid rawstring) u32_size

          
@@ 827,7 825,7 @@ type+ CADAG
                 _ oldid newid
             # update reference in parent
             let md = ('peek stack)
-            let ofs = ('enum-id-offset cls (copy md.typeid) (md.refindex - 1))
+            let ofs = ('enum-id-offset ((copy md.typeid) as cls.TypeId) (md.refindex - 1))
             let idref = (stack.data @ md.refoffset)
             assert (idref == oldid)
             idref = newid

          
@@ 924,9 922,10 @@ type+ CADAG
                 .. "%" (tostring id)
             default-styler style-operator " = "
             default-styler style-keyword
-                string ('typenameof cls typeid)
-            cls.dispatch-any-type typeid
-                inline (T)
+                string typeid.name
+            'dispatch typeid
+                inline "#hidden" (code cls)
+                    T := ('typeinfo cls code) . T
                     value-typeid-repr (@ (bitcast ptr @T)) sz
 
     fn dump (self)

          
M testing/test_cadag.sc +4 -4
@@ 5,10 5,10 @@ import ..lib.tukan.use
 using import tukan.CADAG
 using import tukan.CADAG.dot
 
-inline print-offsets (cls typeid)
+inline print-offsets (typeid)
     report "typeid" typeid "offsets:"
     for i in (infinite-range usize)
-        ofs := ('enum-id-offset cls typeid i)
+        ofs := ('enum-id-offset typeid i)
         if (ofs > 200:usize)
             break;
         report i "=" ofs

          
@@ 29,7 29,7 @@ do
             Id-none
             u32
             array (tuple u32 Id-none)
-    print-offsets M M.TypeId.testT
+    print-offsets M.TypeId.testT
     print "done."
 
 run-stage;

          
@@ 110,7 110,7 @@ do
                             repr
                                 string (& (ptr @ 0)) count
                     default
-                        print "unhandled:" (string handle.name)
+                        print "unhandled:" (string handle.typeid.name)
                     finalize;
 
     # perform an identity transform and swap out the new module