1d32c5f356ae — Leonard Ritter 8 days ago
* dedup is performed for every built instruction
3 files changed, 124 insertions(+), 50 deletions(-)

M lib/tukan/CADAG/init.sc
M testing/test_cadag.sc
M testing/tukdag.sc
M lib/tukan/CADAG/init.sc +72 -47
@@ 13,6 13,7 @@ using import glm
 using import ..SHA256
 
 let u32_size = (sizeof u32)
+let u256 = (integer 256)
 
 ################################################################################
 

          
@@ 516,6 517,8 @@ type+ CADAG
         let T =
             struct (do name) < this-type
                 words : (Array u32)
+                temp : (Array u32)
+                dedup_map : (Map u256 u32)
 
                 let instance = (new-env-data)
 

          
@@ 585,18 588,57 @@ type+ CADAG
                 words @ 2 = 0:u32 # root id
             deref self
 
-    fn... allocate (self, typeid : u32, wordcount : u32)
+    fn... temp-allocate (self, typeid : u32, wordcount : u32)
+        let words = self.temp
+        # replace tail index
+        let endoffset = (wordcount + 2)
+        'resize words endoffset
+        words @ 0 = typeid
+        words @ 1 = wordcount
+        if (wordcount == 0)
+            null as (mutable @u32)
+        else
+            let dataptr = (& (words @ 2))
+            memset dataptr 0:u8 ((wordcount as u64) * u32_size)
+            dataptr
+
+    fn _commit-raw (self ptr size)
+        let cls = (typeof self)
         let words = self.words
         # replace tail index
         let offset = (((countof words) as u32) - 1)
-        let endoffset = (offset + wordcount + 2)
+        let endoffset = (offset + size)
         'resize words (endoffset + 1)
-        let dataptr = (& (words @ (offset + 2)))
-        memset dataptr 0:u8 ((wordcount as u64) * u32_size)
-        words @ offset = typeid
-        words @ (offset + 1) = wordcount
+        memcpy (& (words @ offset)) ptr (size * u32_size)
         words @ endoffset = offset
-        _ offset dataptr
+        bitcast offset cls.AnyId
+
+    fn commit-from (self ptr)
+        let cls = (typeof self)
+
+        let typeid = (copy (ptr @ 0))
+        let size = ((ptr @ 1) + 2)
+
+        let dedup? = ((typeid as cls.TypeId) . dedup?)
+        if dedup?
+            local sha : SHA256
+            'hash sha (bitcast ptr rawstring) (u32_size * size)
+            let digest = ('digest sha)
+            let digest = (@ (bitcast &digest @u256))
+            try
+                return (bitcast (copy ('get self.dedup_map digest)) cls.AnyId)
+            else;
+            let id = (_commit-raw self ptr size)
+            'set self.dedup_map digest id
+            id
+        else
+            _commit-raw self ptr size
+
+    fn commit (self)
+        let temp = self.temp
+        let id = (commit-from self (& (temp @ 0)))
+        'clear temp
+        id
 
     fn... rootid (self)
         # raw u32 without type id

          
@@ 606,15 648,14 @@ type+ CADAG
     inline alloc-func (cls typeid)
         let T = (('typeinfo typeid) . T)
         let ET = (flexible-struct-type T)
-        IdType := (cls.Id typeid)
+        IdType := cls.AnyId # (cls.Id typeid)
         static-assert ((alignof T) <= 4)
             .. "type " (tostring T) " must have alignment <= 4, but has "
                 tostring (alignof T)
         static-if (ET == Nothing)
             sz := (((sizeof T) + (u32_size - 1)) // u32_size) as u32
-            fn (self)
-                let a b = (allocate self typeid sz)
-                _ (bitcast a IdType) (bitcast b (mutable @T))
+            inline (self)
+                bitcast (temp-allocate self typeid sz) (mutable @T)
         else
             # flexible array
             fn (self numelements)

          
@@ 623,8 664,7 @@ type+ CADAG
                     else numelements
                 sz := (((sizeof T) + (sizeof ET) * numelements
                     + (u32_size - 1)) // u32_size) as u32
-                let a b = (allocate self typeid sz)
-                _ (bitcast a IdType) (bitcast b (mutable @T))
+                bitcast (temp-allocate self typeid sz) (mutable @T)
 
     inline... alloc (self, typeid : TypeId, ...)
         (alloc-func (typeof self) typeid) self ...

          
@@ 727,16 767,18 @@ type+ CADAG
         fn pop (self)
             from self let data metadata
             let md = ('pop metadata)
-            'resize data ((countof data) - md.size)
+            'resize data ((countof data) - md.size - 2)
 
         fn push (self module id)
             from self let data metadata
             let typeid sz = ('headerof module id)
             let ptr = ('load module id)
             let dataoffset = (countof data)
-            'resize data (dataoffset + sz)
+            'resize data (dataoffset + sz + 2)
+            data @ dataoffset = typeid
+            data @ (dataoffset + 1) = sz
             if (sz != 0)
-                memcpy (& (data @ dataoffset)) ptr (u32_size * sz)
+                memcpy (& (data @ (dataoffset + 2))) ptr (u32_size * sz)
             'append metadata
                 StackEntry
                     id = id

          
@@ 746,12 788,9 @@ type+ CADAG
                     refoffset = -1:u32
                     refindex = 0
 
-    let u256 = (integer 256)
-
     fn transform (self root ...)
         let cls = (typeof self)
         local newmodule : cls
-        local dedup_map : (Map u256 u32)
         local aliases : (Map u32 u32)
         let alias =
             va-option alias ...

          
@@ 779,28 818,14 @@ type+ CADAG
             let wordofs = (ofs // u32_size)
             vvv bind oldid newid
             if (wordofs >= md.size)
+                # includes header
+                let stackptr = (& (stack.data @ md.offset))
+                capture finalize () {&newmodule &md stackptr}
+                    'commit-from newmodule stackptr
+                # skip header
                 let stackptr =
-                    if md.size (& (stack.data @ md.offset))
+                    if md.size (& (stackptr @ 2))
                     else (null as (mutable @u32))
-                capture finalize () {&newmodule &md stackptr &dedup_map}
-                    let dedup? = ((md.typeid as cls.TypeId) . dedup?)
-                    if dedup?
-                        local sha : SHA256
-                        'hash sha (bitcast &md.typeid rawstring) u32_size
-                        'hash sha (bitcast stackptr rawstring) (u32_size * md.size)
-                        let digest = ('digest sha)
-                        let digest = (@ (bitcast &digest @u256))
-                        try
-                            return (copy ('get dedup_map digest))
-                        else;
-                        let newid ptr = ('allocate newmodule (copy md.typeid) (copy md.size))
-                        'set dedup_map digest newid
-                        memcpy ptr stackptr (u32_size * md.size)
-                        newid
-                    else
-                        let newid ptr = ('allocate newmodule (copy md.typeid) (copy md.size))
-                        memcpy ptr stackptr (u32_size * md.size)
-                        newid
                 let handle = (bitcast
                     ((storageof cls.MutableHandleType) md.typeid md.size stackptr)
                     cls.MutableHandleType)

          
@@ 811,10 836,10 @@ type+ CADAG
                 'pop stack
                 if (empty? stack)
                     return newmodule (copy newid)
-                _ oldid newid
+                _ oldid (storagecast newid)
             else
                 assert ((ofs % u32_size) == 0)
-                let ofs = (md.offset + wordofs)
+                let ofs = (md.offset + 2 + wordofs)
                 md.refoffset = (ofs as u32)
                 md.refindex += 1
                 let oldid = (copy (stack.data @ ofs))

          
@@ 845,13 870,13 @@ type+ CADAG
             let ETcount = (va-countof ET...)
             static-if (ET == Nothing) # not variadic
                 inline (self ...)
-                    let id ptr = (alloc self typeid)
+                    let ptr = (alloc self typeid)
                     let ptr = (@ ptr)
                     va-map
                         inline (i)
                             (extractvalue ptr i) = (va@ i ...)
                         va-range ETcount
-                    id
+                    commit self
             else
                 let string? = (ET == char)
                 let ETcount = (ETcount - 1)

          
@@ 868,7 893,7 @@ type+ CADAG
                                         else 1
                                     va-range ETcount argcount
                         else (argcount - ETcount)
-                    let id ptr = (alloc self typeid extra)
+                    let ptr = (alloc self typeid extra)
                     let ptr = (@ ptr)
                     va-map
                         inline (i)

          
@@ 894,13 919,13 @@ type+ CADAG
                             inline (i)
                                 (extractvalue tail i) = (va@ (i + ETcount) ...)
                             va-range extra
-                    id
+                    commit self
         else
             inline (self value)
-                let id ptr = (alloc self typeid)
+                let ptr = (alloc self typeid)
                 let ptr = (@ ptr)
                 ptr = value
-                id
+                commit self
 
     inline... store (self, typeid : TypeId, ...)
         (store-func typeid) self ...

          
M testing/test_cadag.sc +1 -1
@@ 89,7 89,7 @@ do
                         print self
                         self += 1
                     case const2 (self)
-                        return (('const module.builder (self + 10)) as u32)
+                        return ('const module.builder (self + 10))
                     case vec3 (self)
                         print (self @ 0) (self @ 1) (self @ 2)
                         dispatch ('handleof module (self @ 0))

          
M testing/tukdag.sc +51 -2
@@ 81,6 81,8 @@ define-type "ILString"          (RIFF "I
     stringcolor...
 define-type "ILConstInt"        (RIFF "ICIN") (tuple (type = AnyId) (value = u32))
     constcolor...
+define-type "ILConstReal"       (RIFF "ICRE") (tuple (type = AnyId) (value = f32))
+    constcolor...
 define-type "ILParams"          (RIFF "IPMS") (tuple (level = i32) (count = i32))
     dedup = false
 define-type "ILVAGet"           (RIFF "IGET") (tuple (index = i32) (args = AnyId))

          
@@ 98,6 100,8 @@ define-type "ILNoReturnType"    (RIFF "I
     typecolor...
 define-type "ILIntegerType"     (RIFF "IINT") (tuple (width = i32) (signed? = bool))
     typecolor...
+define-type "ILRealType"        (RIFF "IREA") (tuple (width = i32))
+    typecolor...
 define-type "ILArgumentsType"   (RIFF "IATY") (tuple (types = (array AnyId)))
     typecolor...
 define-type "ILStringType"      (RIFF "ISTY") (tuple)

          
@@ 138,9 142,9 @@ define-type "input"     (RIFF "INPT") (t
     instrcolor...
 define-type "output"    (RIFF "OUTP") (tuple (array (tuple SystemKey AnyId)))
     instrcolor...
-define-type "uconst"    (RIFF "U32C") u32
+define-type "uconst"    (RIFF "U32C") (tuple (value = u32))
     constcolor...
-define-type "fconst"    (RIFF "F32C") f32
+define-type "fconst"    (RIFF "F32C") (tuple (value = f32))
     constcolor...
 define-type "range"     (RIFF "RANG") (tuple AnyId AnyId)
     stringcolor...

          
@@ 403,6 407,49 @@ fn generate-IL (self)
 ################################################################################
 
 fn translate-FIR (self)
+    'transform self ('rootid self)
+        #on-enter =
+            capture (module id) {&funcstack}
+                #report "enter" id
+                let handle = ('handleof module id)
+                dispatch handle
+                case ILTemplate (self)
+                    let f = (sc_template_new unnamed)
+                    local ctx : ILFunction
+                    ctx.func = f
+                    let paramsid = self.params
+                    dispatch ('handleof module paramsid)
+                    case ILParams (params)
+                        let args = (alloca-array Value params.count)
+                        for i in (range params.count)
+                            let arg = (sc_parameter_new unnamed)
+                            sc_template_append_parameter f arg
+                            args @ i = arg
+                        'set ctx.values paramsid
+                            sc_argument_list_new params.count args
+                    default;
+                    #'set ctx.values id f
+                    'append funcstack ctx
+                default;
+                true
+        visit =
+            capture (module handle finalize) {}
+                from (methodsof module.builder) let ILConstInt ILIntegerType
+                    \ ILConstReal ILRealType
+                let vacount = ('vacount handle)
+                dispatch handle
+                case output (self)
+                case uconst (self)
+                    return
+                        ILConstInt (ILIntegerType 32 false) self.value
+                case fconst (self)
+                    return
+                        ILConstReal (ILRealType 32) self.value
+                default;
+                    #error@ unknown-anchor
+                        .. "while translating " (string handle.typeid.name)
+                        "invalid node type"
+                finalize;
 
 ################################################################################
 

          
@@ 479,6 526,8 @@ module = newmodule
 #assert (newid == (rootid))
 #descend newid
 'dump module
+let newmodule newid = (translate-FIR module)
+module = newmodule
 'showdot module ('rootid module)
     module-dir .. "/tukdag"
 let f =