85966deeb41e — Leonard Ritter 12 days ago
* updates to the dragon
1 files changed, 244 insertions(+), 118 deletions(-)

M testing/dragon.sc
M testing/dragon.sc +244 -118
@@ 50,45 50,10 @@ let NoId = (nullof (Id Nothing))
 
 ################################################################################
 
-global type->typeid-map : (Map type u32)
-global typeid->type-map : (Map u32 type)
-
-spice typeidof (T)
-    T as:= type
-    try (copy ('get type->typeid-map T))
-    else
-        error
-            .. "type " (repr T) " has no typeid"
-
-spice typeoftypeid (code)
-    code as:= u32
-    try ('get typeid->type-map code)
-    else
-        error
-            .. "no such typeid: " (repr code)
+global id-offset-func-map : (Map type (tuple Value usize))
 
-spice def-typeid (T code)
-    T as:= type
-    code as:= u32
-    if ('in? type->typeid-map T)
-        let code =
-            try ('get type->typeid-map T)
-            else
-                unreachable;
-        error
-            .. "type " (repr T) " already mapped to typeid " (repr code)
-    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)
-    'set type->typeid-map T code
-    'set typeid->type-map code T
-    ;
-
-global id-offset-func-map : (Map type (tuple Value usize))
+fn idtype? (QT)
+    ('strip-qualifiers QT) < Id
 
 # 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

          
@@ 112,20 77,36 @@ fn... gen-id-offset-func (QT : type)
             let unsized? = ('unsized? T)
             let ET = ('element@ T 0)
             let ETsz = ('sizeof ET)
+            if (ETsz == 0)
+                return false
             assert ((sz % ETsz) == 0)
-            let f numindices = (gen-id-offset-func ET)
-            if (numindices == 0)
-                return unsized?
-            if (numindices == -1:usize)
-                error "array elements must not contain unsized array"
             let numelements = (sz // ETsz)
             let startindex = (deref nextindex)
-            let cond_body =
-                spice-quote
-                    let localindex = (index - startindex)
-                    let blockindex = (localindex // numindices)
-                    return (offset + blockindex * ETsz
-                         + (f (localindex % numindices)))
+            vvv bind numindices cond_body
+            if (idtype? ET)
+                _ 1:usize
+                    spice-quote
+                        let localindex = (index - startindex)
+                        return (offset + localindex * ETsz)
+            else
+                switch ('kind ('storageof ET))
+                pass type-kind-array
+                pass type-kind-tuple
+                do;
+                default
+                    # not going to contain any ids
+                    return false
+                let f numindices = (gen-id-offset-func ET)
+                if (numindices == 0)
+                    return false
+                if (numindices == -1:usize)
+                    error "array elements must not contain unsized array"
+                _ numindices
+                    spice-quote
+                        let localindex = (index - startindex)
+                        let blockindex = (localindex // numindices)
+                        return (offset + blockindex * ETsz
+                            + (f (localindex % numindices)))
             if unsized?
                 sc_expression_append defaultblock cond_body
                 true

          
@@ 148,23 129,21 @@ fn... gen-id-offset-func (QT : type)
                     break true
             else false
         default
-            if (('strip-qualifiers QT) < Id)
+            if (idtype? QT)
                 let idx = (deref nextindex)
-                print "field at index" idx index "offset" offset
                 sc_switch_append_case sw `idx `(return offset)
                 nextindex += 1
             false
 
     local nextindex = 0:usize
     spice-quote
-        fn idoffsets (index)
+        inline idoffsets (index)
             spice-unquote
                 let sw = (sc_switch_new index)
                 let defaultblock = (sc_expression_new)
                 let period? = (recur sw defaultblock index QT 0:usize nextindex)
                 sc_switch_append_default sw defaultblock
                 if (not period?)
-                    print "adding default block"
                     sc_expression_append defaultblock `(return -1:usize)
                 else
                     nextindex = -1:usize

          
@@ 173,12 152,95 @@ 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)
+################################################################################
+
+struct TypeInfo plain
+    typeid : u32
+    name : string
+
+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)
+
+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)
+
+spice dragon-type (T name code)
+    T as:= type
+    code as:= u32
+    name as:= string
+    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)
+
+    'set type->info-map T
+        TypeInfo
+            typeid = code
+            name = name
+    'set typeid->type-map code T
+    '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
+    ;
+
+fn enum-id-offset (typeid index)
+    enum-id-offset typeid index
+
+fn get-typename (typeid)
+    get-typename typeid
 
 run-stage;
 
-do
+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

          
@@ 190,32 252,16 @@ do
             Id u32
             u32
             array (tuple u32 (Id u32))
-        #tuple
-            array
-                Id u32
-                2
-            u8
-            u16
-            Id u32
-            u32
-            array
-                tuple
-                    u32
-                    Id u32
-                3
-    for i in (infinite-range usize)
-        ofs := ((gen-id-offset-func T) i)
-        if (ofs > 1000:usize)
-            break;
-        print i ofs
+    dragon-type T "testT" 10:u32
+    print-offsets T
     print "done."
 
-def-typeid Nothing 0:u32
+dragon-type Nothing "undefined" 0:u32
 
-#declare void @llvm.memset.p0i8.i64(i8* <dest>, i8 <val>,
-                                   i64 <len>, i1 <isvolatile>)
 let memset =
-    extern 'llvm.memset.p0i8.i64 (function void (mutable @u32) u8 u64 bool)
+    extern 'memset (function void (mutable @u32) u32 usize)
+let memcpy =
+    extern 'memcpy (function void (mutable @u32) @u32 usize)
 let u32_size = (sizeof u32)
 
 inline alignoffsetu (offset align)

          
@@ 244,7 290,7 @@ struct Module
         let endoffset = (offset + wordcount + 2)
         'resize words (endoffset + 1)
         let dataptr = (& (words @ (offset + 2)))
-        memset dataptr 0:u8 ((wordcount as u64) * u32_size) false
+        memset dataptr 0:u8 ((wordcount as u64) * u32_size)
         words @ offset = typeid
         words @ (offset + 1) = wordcount
         words @ endoffset = offset

          
@@ 258,6 304,7 @@ struct Module
     inline alloc-func (T)
         sz := (((sizeof T) + (u32_size - 1)) // u32_size) as u32
         typeid := (typeidof T)
+        static-assert (constant? typeid)
         IdType := (Id T)
         static-assert ((alignof T) <= 4)
             .. "type " (tostring T) " must have alignment <= 4, but has "

          
@@ 269,60 316,139 @@ struct Module
     inline... alloc (self, T : type)
         (alloc-func T) self
 
-    fn store (self value)
-        let id ptr = (alloc self (typeof value))
-        @ptr = value
-        id
-
-    fn load (self id)
-        let IdT = (typeof id)
-        let T = IdT.Type
-        offset := (id as u32) + 2
-        bitcast (& (self.words @ offset)) @T
-
     fn... headerof (self, offset : u32)
         _
             deref (self.words @ offset)
             deref (self.words @ (offset + 1))
 
-    #inline transform (self root)
-        local data : (Array u32)
-        # offset into data array, typeid, size, offset of next pointer
-        local metadata : (Array (tuple u32 u32 u32 u32))
-        inline read (id
-        let typeid sz = (headerof root)
+    struct StackEntry plain
+        id : u32
+        offset : u32
+        typeid : u32
+        size : u32
+        # last reference offset
+        refoffset : u32
+        # next reference index
+        refindex : u32
+
+    struct TransformStack
+        data : (Array u32)
+        metadata : (Array StackEntry)
+
+        inline __countof (self)
+            countof self.metadata
+
+        fn peek (self)
+            'last self.metadata
 
+        fn pop (self)
+            from self let data metadata
+            let md = ('pop metadata)
+            'resize data ((countof data) - md.size)
 
-
+        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)
+            memcpy (& (data @ dataoffset)) ptr (u32_size * sz)
+            'append metadata
+                StackEntry
+                    id = id
+                    offset = (dataoffset as u32)
+                    typeid = typeid
+                    size = sz
+                    refoffset = -1:u32
+                    refindex = 0
 
-    #fn rootid (self)
-        (copy ((countof self.cells) - 1)) as u32 as Id
+    inline transform (self root ...)
+        local newmodule : this-type
+        let visit =
+            va-option visit ...
+                inline (finalize md ptr)
+                    let newid = (finalize)
+                    report "done" md.id "->" newid (string (get-typename md.typeid))
+                    newid
+        local stack : TransformStack
+        '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 = (& (stack.data @ md.offset))
+                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)
+                # 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
+            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
 
-    #fn... build (self, cmd : List)
-        try
-            copy ('get self.memomap cmd)
-        else
-            idx := (bitcast ((countof self.cells) as u32) Id)
-            'append self.cells cmd
-            'set self.memomap cmd idx
-            copy idx
-    #case (self, ...)
-        this-function self (List ...)
+    fn store (self value)
+        let id ptr = (alloc self (typeof value))
+        @ptr = value
+        id
+
+    fn... load (self, id : Id)
+        let IdT = (typeof id)
+        let T = IdT.Type
+        bitcast (this-function self id) @T
+    case (self, id : u32)
+        offset := (id as u32) + 2
+        & (self.words @ offset)
 
 do
-    using import glm
-    let u32x3 = (tuple u32 u32 u32)
-    def-typeid u32x3 1:u32
+    # register the types / instructions we want to use in the DAG
+    # type, printable name, persistent typeid
+    dragon-type u32 "const" 1:u32
+
+    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
+    # store 4 nodes in DAG
+    store
+        u32x3
+            store 10:u32
+            store 20:u32
+            store 30:u32
 
-    let id = (store (tupleof 1:u32 2:u32 3:u32))
-    print id
-    print (load id)
-    print (headerof (rootid))
-    print
+    # 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
+    # perform a topological transform where we increment the constant values
+    let newmodule newid =
+        transform newid
+            visit =
+                inline (finalize md ptr)
+                    switch md.typeid
+                    case (typeidof u32)
+                        (@ ptr) += 1
+                    default;
+                    finalize;
+    swap (view module) (view newmodule); drop newmodule
+    assert (newid == (rootid))
 
 
     ;
  No newline at end of file