e1d508652580 — Leonard Ritter 12 days ago
* dragon: SHA256 dedup option, node aliasing
1 files changed, 204 insertions(+), 28 deletions(-)

M testing/dragon.sc
M testing/dragon.sc +204 -28
@@ 11,7 11,12 @@ using import struct
 using import switcher
 using import Array
 using import Map
+using import Set
 using import Box
+using import Capture
+
+import ..lib.tukan.use
+using import tukan.SHA256
 
 ################################################################################
 

          
@@ 157,6 162,7 @@ fn... gen-id-offset-func (QT : type)
 struct TypeInfo plain
     typeid : u32
     name : string
+    dedup? : bool = true
 
 global type->info-map : (Map type TypeInfo)
 global typeid->type-map : (Map u32 type)

          
@@ 165,6 171,12 @@ 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
 
 spice typeidof (T)
     T as:= type

          
@@ 187,10 199,17 @@ spice typeoftypeid (code)
         error
             .. "no such typeid: " (repr code)
 
-spice dragon-type (T name code)
+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

          
@@ 213,23 232,67 @@ spice dragon-type (T name code)
         TypeInfo
             typeid = code
             name = name
+            dedup? = dedup?
     'set typeid->type-map code T
-    'stage-case enum-id-offset `code
+    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
+    '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
 
+fn value-typeid-repr (value)
+    let T = ('typeof value)
+    let ST = ('storageof T)
+    switch ('kind ST)
+    pass type-kind-array
+    pass type-kind-tuple
+    do
+        if (('sizeof ST) == 0) `""
+        else
+            spice-quote
+                ..
+                    va-rfold none
+                        inline (k v ...)
+                            let v =
+                                static-if ((typeof v) < Id)
+                                    default-styler style-symbol
+                                        .. "%" (tostring v)
+                                else (repr v)
+                            static-if (none? (_ ... ())) v
+                            else
+                                _ v " " ...
+                        unpack (storagecast value)
+    default
+        if (idtype? T)
+            spice-quote
+                default-styler style-symbol
+                    .. "%" (tostring value)
+        else `(repr value)
+
+spice value-typeid-repr (value)
+    value-typeid-repr value
+
 run-stage;
 
 inline print-offsets (T)

          
@@ 331,6 394,60 @@ struct Module
         # next reference index
         refindex : u32
 
+    struct DescendStack
+        metadata : (Array StackEntry)
+
+        inline __countof (self)
+            countof self.metadata
+
+        fn peek (self)
+            'last self.metadata
+
+        fn pop (self)
+            from self let metadata
+            let md = ('pop metadata)
+
+        fn push (self module id)
+            from self let metadata
+            let typeid sz = ('headerof module id)
+            'append metadata
+                StackEntry
+                    id = id
+                    offset = ('offsetof module id)
+                    typeid = typeid
+                    size = sz
+                    refoffset = -1:u32
+                    refindex = 0
+
+    fn descend (self root ...)
+        let visit =
+            va-option visit ...
+                inline (md ptr)
+                    report "done" md.id (string (get-typename md.typeid))
+        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))
+            if (ofs == -1:usize)
+                let stackptr = (& (self.words @ md.offset))
+                let oldid = (copy md.id)
+                visit md stackptr
+                # clear
+                'pop stack
+                if (empty? stack)
+                    return;
+            else
+                assert ((ofs % u32_size) == 0)
+                let ofs = (md.offset + (ofs // u32_size))
+                md.refoffset = (ofs as u32)
+                md.refindex += 1
+                let nextid = (copy (self.words @ ofs))
+                if (not ('in? seen nextid))
+                    'insert seen nextid
+                    'push stack self nextid
+
     struct TransformStack
         data : (Array u32)
         metadata : (Array StackEntry)

          
@@ 362,51 479,91 @@ struct Module
                     refoffset = -1:u32
                     refindex = 0
 
-    inline transform (self root ...)
+    let u256 = (integer 256)
+
+    fn transform (self root ...)
         local newmodule : this-type
+        local dedup_map : (Map u256 u32)
+        local aliases : (Map u32 u32)
+        let alias =
+            va-option alias ...
+                inline (id)
+                    copy ('get aliases id)
+        let on-enter =
+            va-option on-enter ...
+                inline (id)
+        let on-alias =
+            va-option on-alias ...
+                inline (oldid newid)
+                    'set aliases oldid newid
         let visit =
             va-option visit ...
                 inline (finalize md ptr)
                     let newid = (finalize)
-                    report "done" md.id "->" newid (string (get-typename md.typeid))
+                    #report "done" md.id "->" newid (string (get-typename md.typeid))
                     newid
         local stack : TransformStack
+        on-enter root
         'push stack self root
         loop ()
             let md = ('peek stack)
             let ofs = (enum-id-offset (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)
+                    if dedup?
+                        let digest = (sha256 (bitcast stackptr rawstring) (u32_size * md.size))
+                        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 newid = (visit finalize md stackptr)
                 let oldid = (copy md.id)
-                inline finalize ()
-                    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)
+                on-alias oldid newid
                 # clear
                 'pop stack
                 if (empty? stack)
                     return newmodule (copy newid)
-                else
-                    # update reference in parent
-                    let md = ('peek stack)
-                    let ofs = (enum-id-offset (copy md.typeid) (md.refindex - 1))
-                    let idref = (stack.data @ md.refoffset)
-                    assert (idref == oldid)
-                    idref = newid
+                _ oldid newid
             else
                 assert ((ofs % u32_size) == 0)
                 let ofs = (md.offset + (ofs // u32_size))
                 md.refoffset = (ofs as u32)
                 md.refindex += 1
-                let nextid = (copy (stack.data @ ofs))
-                'push stack self nextid
+                let oldid = (copy (stack.data @ ofs))
+                let newid =
+                    try (alias oldid)
+                    else
+                        on-enter oldid
+                        # no alias
+                        'push stack self oldid
+                        repeat;
+                _ oldid newid
+            # update reference in parent
+            let md = ('peek stack)
+            let ofs = (enum-id-offset (copy md.typeid) (md.refindex - 1))
+            let idref = (stack.data @ md.refoffset)
+            assert (idref == oldid)
+            idref = newid
 
     fn store (self value)
         let id ptr = (alloc self (typeof value))
         @ptr = value
         id
 
+    fn offsetof (self id)
+        (id as u32) + 2
+
     fn... load (self, id : Id)
         let IdT = (typeof id)
         let T = IdT.Type

          
@@ 415,40 572,59 @@ struct Module
         offset := (id as u32) + 2
         & (self.words @ offset)
 
+    fn... repr (self, id : u32)
+        let typeid sz = ('headerof self id)
+        let ptr = ('load self id)
+        ..
+            default-styler style-symbol
+                .. "%" (tostring id)
+            default-styler style-operator " = "
+            default-styler style-keyword
+                string (get-typename typeid)
+            " "
+            dispatch-any-type typeid ptr value-typeid-repr
+
+    fn dump (self)
+        descend self ('rootid self)
+            visit =
+                capture (md ptr) {&self}
+                    print ('repr self md.id)
+
 do
     # register the types / instructions we want to use in the DAG
     # type, printable name, persistent typeid
     dragon-type u32 "const" 1:u32
+        dedup = false
 
     let u32x3 = (array (Id u32) 3)
     dragon-type u32x3 "vec3" 2:u32
 
     local module : Module
-    from (methodsof module) let store load rootid headerof transform
+    from (methodsof module) let store load rootid headerof transform descend
 
     # store 4 nodes in DAG
+    let k = (store 10:u32)
+    let m = (store 10:u32)
     store
-        u32x3
-            store 10:u32
-            store 20:u32
-            store 30:u32
+        u32x3 k k m
 
     # perform an identity transform and swap out the new module
         all transformations are immutable.
     let newmodule newid = (transform (rootid))
-    swap (view module) (view newmodule); drop newmodule
+    module = newmodule
     # perform a topological transform where we increment the constant values
     let newmodule newid =
         transform newid
             visit =
-                inline (finalize md ptr)
+                capture (finalize md ptr) {}
                     switch md.typeid
                     case (typeidof u32)
                         (@ ptr) += 1
                     default;
                     finalize;
-    swap (view module) (view newmodule); drop newmodule
+    module = newmodule
     assert (newid == (rootid))
-
+    descend newid
+    'dump module
 
     ;
  No newline at end of file