fd1a2f93e8f7 — Leonard Ritter 12 days ago
* initial check-in of `CADAG` module
* structs with flexible arrays are properly supported
2 files changed, 679 insertions(+), 710 deletions(-)

A => lib/tukan/CADAG.sc
R testing/dragon.sc => 
A => lib/tukan/CADAG.sc +679 -0
@@ 0,0 1,679 @@ 
+
+# CADAG - Content Agnostic Directed Acyclic Graph
+
+using import struct
+using import switcher
+using import Array
+using import Map
+using import Set
+using import Capture
+
+using import .SHA256
+
+let u32_size = (sizeof u32)
+
+################################################################################
+
+type Id
+
+    @@ memo
+    inline __imply (cls T)
+        static-if (T == u32)
+            storagecast
+        elseif (T == integer)
+            storagecast
+
+    @@ memo
+    inline __== (cls T)
+        static-if (T < this-type)
+            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
+
+type+ Id
+    inline __tobool (self)
+        (storagecast self) as bool
+
+let NoId = (nullof (Id Nothing))
+
+################################################################################
+
+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
+fn... gen-id-offset-func (QT : type)
+    returning Value usize
+    raising Error
+    let QT = ('storageof QT)
+    try
+        return (unpack (copy ('get id-offset-func-map QT)))
+    else;
+    let gen-id-offset-func = this-function
+    fn... recur (sw : Value, defaultblock : Value, index : Value, QT : type,
+                    offset : usize, nextindex)
+        returning bool
+        raising Error
+        let recur = this-function
+        let T = ('storageof QT)
+        let sz = ('sizeof T)
+        switch ('kind T)
+        case type-kind-array
+            let unsized? = ('unsized? T)
+            let ET = ('element@ T 0)
+            let ETsz = ('sizeof ET)
+            if (ETsz == 0)
+                return false
+            assert ((sz % ETsz) == 0)
+            let numelements = (sz // ETsz)
+            let startindex = (deref nextindex)
+            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
+            else
+                let totalcount = (numindices * numelements)
+                nextindex += totalcount
+                let endindex = (startindex + totalcount)
+                sc_expression_append defaultblock
+                    spice-quote
+                        if ((index >= startindex) & (index < endindex)) cond_body
+                false
+        case type-kind-tuple
+            let count = ('element-count T)
+            for i in (range count)
+                let ET = ('element@ T i)
+                let ofs = (offset + ('offsetof T i))
+                if (recur sw defaultblock index ET ofs nextindex)
+                    if ((i + 1) != count)
+                        error "unsized array must be last field"
+                    break true
+            else false
+        default
+            if (idtype? QT)
+                let idx = (deref nextindex)
+                sc_switch_append_case sw `idx `(return offset)
+                nextindex += 1
+            false
+
+    local nextindex = 0:usize
+    spice-quote
+        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?)
+                    sc_expression_append defaultblock `(return -1:usize)
+                else
+                    nextindex = -1:usize
+                sw
+    let nextindex = (deref nextindex)
+    'set id-offset-func-map QT (tupleof idoffsets nextindex)
+    _ idoffsets nextindex
+
+fn _flexible-struct-type (T)
+    let T = ('storageof T)
+    if (('kind T) == type-kind-tuple)
+        let count = ('element-count T)
+        if (count > 0)
+            let ET = ('element@ T (count - 1))
+            if (('kind ET) == type-kind-array)
+                if ('unsized? ET)
+                    return ('element@ ET 0)
+    Nothing
+
+spice flexible-struct-type (T)
+    T as:= type
+    _flexible-struct-type T
+
+################################################################################
+
+spice RIFF (name)
+    name as:= string
+    if ((countof name) != 4)
+        error "RIFF code must have four characters"
+    |
+        (name @ 0) as u32
+        (name @ 1) as u32 << 8
+        (name @ 2) as u32 << 16
+        (name @ 3) as u32 << 24
+
+################################################################################
+
+struct TypeInfo plain
+    typeid : u32
+    name : string
+    dedup? : bool = true
+
+struct CADAGEnvData
+    type->info-map : (Map type TypeInfo)
+    typeid->type-map : (Map u32 type)
+
+    inline __drop (self)
+        print "drop"
+
+let InstancePointerType = (viewof (mutable @CADAGEnvData) 999)
+
+spice new-env-data ()
+    let data = (malloc CADAGEnvData)
+    store (CADAGEnvData) data
+    sc_const_pointer_new voidstar data
+
+fn repr-atomic-value (ET value)
+    if (idtype? ET)
+        spice-quote
+            default-styler style-symbol
+                .. "%" (tostring value)
+    else `(repr value)
+
+fn value-typeid-repr (T value sz)
+    returning Value
+    let ST = ('storageof T)
+    switch ('kind ST)
+    pass type-kind-array
+    pass type-kind-tuple
+    do
+        if (('sizeof ST) == 0) `""
+        else
+            let value = `(storagecast value)
+            let body = (sc_expression_new)
+            let SZ = (('sizeof ST) as u32)
+            fold (str = `"") for i ET in (enumerate ('elements ST))
+                if ('unsized? ET) # last element
+                    let ET = ('element@ ET 0)
+                    let ETsz = (('sizeof ET) as u32)
+                    sc_expression_append body
+                        spice-quote
+                            let numelements = ((sz * u32_size - SZ) // ETsz)
+                            let arr = (value @ i)
+                            let str =
+                                loop (k str = 0:u32 str)
+                                    if (k == numelements)
+                                        break str
+                                    let elem = (arr @ k)
+                                    _ (k + 1)
+                                        .. str
+                                            spice-unquote
+                                                this-function ET elem 0
+                    str
+                else
+                    spice-quote
+                        let str =
+                            .. str " "
+                                spice-unquote
+                                    repr-atomic-value ET `(value @ i)
+                    sc_expression_append body str
+                    str
+            body
+    default
+        `(.. " " [(repr-atomic-value T value)])
+
+spice value-typeid-repr (value sz)
+    value-typeid-repr ('typeof value) value sz
+
+run-stage;
+
+type CADAG < Struct
+
+    inline getinstance (T)
+        let self = ('@ (T as type) 'instance)
+        # hack to turn pointer into view
+        let ptr = (sc_const_pointer_extract self)
+        let ptr = (bitcast ptr InstancePointerType)
+        let val = (alloca InstancePointerType)
+        store ptr val
+        let self = @@val
+        self
+
+    spice typeidof (cls T)
+        let self = (getinstance cls)
+        T as:= type
+        if (not ('in? self.type->info-map T))
+            error
+                .. "type " (repr T) " has no typeinfo"
+        ('getdefault self.type->info-map T (TypeInfo 0 "")) . typeid
+
+    spice typeinfo (cls T)
+        let self = (getinstance cls)
+        T as:= type
+        if (not ('in? self.type->info-map T))
+            error
+                .. "type " (repr T) " has no typeinfo"
+        'getdefault self.type->info-map T (TypeInfo 0 "")
+
+    spice typeoftypeid (cls code)
+        let self = (getinstance cls)
+        cls as:= type
+        code as:= u32
+        try ('get self.typeid->type-map code)
+        else
+            error
+                .. "no such typeid: " (repr code)
+
+    spice define-type (cls T name code ...)
+        cls as:= type
+        let self = (getinstance cls)
+        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
+        if ('in? self.type->info-map T)
+            let info =
+                try ('get self.type->info-map T)
+                else
+                    unreachable;
+            error
+                .. "type " (repr T) " already mapped to typeid " (repr info.typeid)
+        if ('in? self.typeid->type-map code)
+            let T =
+                try ('get self.typeid->type-map code)
+                else
+                    unreachable;
+            error
+                .. "typeid " (repr code) " already mapped to type " (repr T)
+
+        'set self.type->info-map T
+            TypeInfo
+                typeid = code
+                name = name
+                dedup? = dedup?
+        'set self.typeid->type-map code T
+
+        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 ptr f sz)
+                    f (@ (bitcast ptr @T)) sz
+
+        let do-dedup? = (('@ cls '_do-dedup?) as type)
+        Switcher.stage-case do-dedup? code
+            spice-quote
+                inline "#hidden" () dedup?
+        ;
+
+run-stage;
+
+let memset =
+    extern 'memset (function void (mutable @u32) u32 usize)
+let memcpy =
+    extern 'memcpy (function void (mutable @u32) @u32 usize)
+
+inline alignoffsetu (offset align)
+    """"align `offset` up to `align`, which must be a power of 2
+    (offset + align - 1) & -align
+
+type+ CADAG
+
+    inline new-type (name)
+        let T =
+            struct (do name) < this-type
+                words : (Array u32)
+
+                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
+
+        'define-type T Nothing "undefined" 0:u32
+        T
+
+    inline __typecall (cls ...)
+        static-if (cls == this-type)
+            new-type ...
+        else
+            local self =
+                super-type.__typecall cls
+            do
+                # add null element
+                let words = self.words
+                'resize words 3
+                words @ 0 = 0:u32 # typeid
+                words @ 1 = 0:u32 # size
+                words @ 2 = 0:u32 # root id
+            deref self
+
+    fn... allocate (self, typeid : u32, wordcount : u32)
+        let words = self.words
+        # replace tail index
+        let offset = (((countof words) as u32) - 1)
+        let endoffset = (offset + wordcount + 2)
+        '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
+        words @ endoffset = offset
+        _ offset dataptr
+
+    fn... rootid (self)
+        # raw u32 without type id
+        deref ('last self.words)
+
+    @@ memo
+    inline alloc-func (cls T)
+        let ET = (flexible-struct-type T)
+        typeid := ('typeidof cls T)
+        IdType := (Id T)
+        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
+            inline (self)
+                let a b = (allocate self typeid sz)
+                _ (bitcast a IdType) (bitcast b (mutable @T))
+        else
+            # flexible array
+            inline (self numelements)
+                let numelements =
+                    static-if (none? numelements) 0
+                    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))
+
+    inline... alloc (self, T : type, ...)
+        (alloc-func (typeof self) T) self ...
+
+    fn... headerof (self, offset : u32)
+        _
+            deref (self.words @ offset)
+            deref (self.words @ (offset + 1))
+
+    struct StackEntry plain
+        id : u32
+        offset : u32
+        typeid : u32
+        size : u32
+        # last reference offset
+        refoffset : u32
+        # 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 cls = (typeof self)
+        let visit =
+            va-option visit ...
+                inline (md ptr)
+                    report "done" md.id (string ('typenameof cls md.typeid))
+        let on-enter =
+            va-option on-enter ...
+                inline (id)
+        local stack : DescendStack
+        local seen : (Set u32)
+        'push stack self root
+        loop ()
+            let md = ('peek stack)
+            let ofs = ('enum-id-offset cls (copy md.typeid) (copy md.refindex))
+            let wordofs = (ofs // u32_size)
+            if (wordofs >= md.size)
+                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 + wordofs)
+                md.refoffset = (ofs as u32)
+                md.refindex += 1
+                let nextid = (copy (self.words @ ofs))
+                if (not ('in? seen nextid))
+                    'insert seen nextid
+                    on-enter nextid
+                    'push stack self nextid
+
+    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
+
+    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 ...
+                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))
+                    newid
+        local stack : TransformStack
+        on-enter root
+        'push stack self root
+        loop ()
+            let md = ('peek stack)
+            let ofs = ('enum-id-offset cls (copy md.typeid) (copy md.refindex))
+            let wordofs = (ofs // u32_size)
+            vvv bind oldid newid
+            if (wordofs >= md.size)
+                let stackptr = (& (stack.data @ md.offset))
+                capture finalize () {&newmodule &md stackptr &dedup_map}
+                    let dedup? = ('do-dedup? cls 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)
+                on-alias oldid newid
+                # clear
+                'pop stack
+                if (empty? stack)
+                    return newmodule (copy newid)
+                _ oldid newid
+            else
+                assert ((ofs % u32_size) == 0)
+                let ofs = (md.offset + wordofs)
+                md.refoffset = (ofs as u32)
+                md.refindex += 1
+                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 cls (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
+        bitcast (this-function self id) @T
+    case (self, id : u32)
+        offset := (id as u32) + 2
+        & (self.words @ offset)
+
+    fn... repr (self, id : u32)
+        let cls = (typeof self)
+        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 ('typenameof cls typeid)
+            cls.dispatch-any-type typeid ptr value-typeid-repr sz
+
+    fn dump (self)
+        descend self ('rootid self)
+            visit =
+                capture (md ptr) {&self}
+                    print ('repr self md.id)
+
+do
+    let CADAG Id RIFF
+    locals;

          
R testing/dragon.sc =>  +0 -710
@@ 1,710 0,0 @@ 
-
-#
-    Directed
-    Recursive
-    Acyclic
-    Graph
-    Object
-    Notation
-
-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
-
-################################################################################
-
-type Id
-
-    @@ memo
-    inline __imply (cls T)
-        static-if (T == u32)
-            storagecast
-        elseif (T == integer)
-            storagecast
-
-    @@ memo
-    inline __== (cls T)
-        static-if (T < this-type)
-            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
-
-type+ Id
-    inline __tobool (self)
-        (storagecast self) as bool
-
-let NoId = (nullof (Id Nothing))
-
-################################################################################
-
-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
-fn... gen-id-offset-func (QT : type)
-    returning Value usize
-    raising Error
-    let QT = ('storageof QT)
-    try
-        return (unpack (copy ('get id-offset-func-map QT)))
-    else;
-    let gen-id-offset-func = this-function
-    fn... recur (sw : Value, defaultblock : Value, index : Value, QT : type,
-                    offset : usize, nextindex)
-        returning bool
-        raising Error
-        let recur = this-function
-        let T = ('storageof QT)
-        let sz = ('sizeof T)
-        switch ('kind T)
-        case type-kind-array
-            let unsized? = ('unsized? T)
-            let ET = ('element@ T 0)
-            let ETsz = ('sizeof ET)
-            if (ETsz == 0)
-                return false
-            assert ((sz % ETsz) == 0)
-            let numelements = (sz // ETsz)
-            let startindex = (deref nextindex)
-            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
-            else
-                let totalcount = (numindices * numelements)
-                nextindex += totalcount
-                let endindex = (startindex + totalcount)
-                sc_expression_append defaultblock
-                    spice-quote
-                        if ((index >= startindex) & (index < endindex)) cond_body
-                false
-        case type-kind-tuple
-            let count = ('element-count T)
-            for i in (range count)
-                let ET = ('element@ T i)
-                let ofs = (offset + ('offsetof T i))
-                if (recur sw defaultblock index ET ofs nextindex)
-                    if ((i + 1) != count)
-                        error "unsized array must be last field"
-                    break true
-            else false
-        default
-            if (idtype? QT)
-                let idx = (deref nextindex)
-                sc_switch_append_case sw `idx `(return offset)
-                nextindex += 1
-            false
-
-    local nextindex = 0:usize
-    spice-quote
-        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?)
-                    sc_expression_append defaultblock `(return -1:usize)
-                else
-                    nextindex = -1:usize
-                sw
-    let nextindex = (deref nextindex)
-    'set id-offset-func-map QT (tupleof idoffsets nextindex)
-    _ idoffsets nextindex
-
-################################################################################
-
-spice RIFF (name)
-    name as:= string
-    if ((countof name) != 4)
-        error "RIFF code must have four characters"
-    |
-        (name @ 0) as u32
-        (name @ 1) as u32 << 8
-        (name @ 2) as u32 << 16
-        (name @ 3) as u32 << 24
-
-################################################################################
-
-struct TypeInfo plain
-    typeid : u32
-    name : string
-    dedup? : bool = true
-
-struct ModuleEnvData
-    type->info-map : (Map type TypeInfo)
-    typeid->type-map : (Map u32 type)
-
-    inline __drop (self)
-        print "drop"
-
-let InstancePointerType = (viewof (mutable @ModuleEnvData) 999)
-
-spice new-env-data ()
-    let data = (malloc ModuleEnvData)
-    store (ModuleEnvData) data
-    sc_const_pointer_new voidstar data
-
-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;
-
-type Module < Struct
-
-    inline getinstance (T)
-        let self = ('@ (T as type) 'instance)
-        # hack to turn pointer into view
-        let ptr = (sc_const_pointer_extract self)
-        let ptr = (bitcast ptr InstancePointerType)
-        let val = (alloca InstancePointerType)
-        store ptr val
-        let self = @@val
-        self
-
-    spice typeidof (cls T)
-        let self = (getinstance cls)
-        T as:= type
-        if (not ('in? self.type->info-map T))
-            error
-                .. "type " (repr T) " has no typeinfo"
-        ('getdefault self.type->info-map T (TypeInfo 0 "")) . typeid
-
-    spice typeinfo (cls T)
-        let self = (getinstance cls)
-        T as:= type
-        if (not ('in? self.type->info-map T))
-            error
-                .. "type " (repr T) " has no typeinfo"
-        'getdefault self.type->info-map T (TypeInfo 0 "")
-
-    spice typeoftypeid (cls code)
-        let self = (getinstance cls)
-        cls as:= type
-        code as:= u32
-        try ('get self.typeid->type-map code)
-        else
-            error
-                .. "no such typeid: " (repr code)
-
-    spice define-type (cls T name code ...)
-        cls as:= type
-        let self = (getinstance cls)
-        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
-        if ('in? self.type->info-map T)
-            let info =
-                try ('get self.type->info-map T)
-                else
-                    unreachable;
-            error
-                .. "type " (repr T) " already mapped to typeid " (repr info.typeid)
-        if ('in? self.typeid->type-map code)
-            let T =
-                try ('get self.typeid->type-map code)
-                else
-                    unreachable;
-            error
-                .. "typeid " (repr code) " already mapped to type " (repr T)
-
-        'set self.type->info-map T
-            TypeInfo
-                typeid = code
-                name = name
-                dedup? = dedup?
-        'set self.typeid->type-map code T
-        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 ptr f)
-                    f (@ (bitcast ptr @T))
-
-        let do-dedup? = (('@ cls '_do-dedup?) as type)
-        Switcher.stage-case do-dedup? code
-            spice-quote
-                inline "#hidden" () dedup?
-        ;
-
-run-stage;
-
-let memset =
-    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)
-    """"align `offset` up to `align`, which must be a power of 2
-    (offset + align - 1) & -align
-
-type+ Module
-
-    inline new-type (name)
-        let T =
-            struct (do name) < this-type
-                words : (Array u32)
-
-                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
-
-        'define-type T Nothing "undefined" 0:u32
-        T
-
-    inline __typecall (cls ...)
-        static-if (cls == this-type)
-            new-type ...
-        else
-            local self =
-                super-type.__typecall cls
-            do
-                # add null element
-                let words = self.words
-                'resize words 3
-                words @ 0 = 0:u32 # typeid
-                words @ 1 = 0:u32 # size
-                words @ 2 = 0:u32 # root id
-            deref self
-
-    fn... allocate (self, typeid : u32, wordcount : u32)
-        let words = self.words
-        # replace tail index
-        let offset = (((countof words) as u32) - 1)
-        let endoffset = (offset + wordcount + 2)
-        '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
-        words @ endoffset = offset
-        _ offset dataptr
-
-    fn... rootid (self)
-        # raw u32 without type id
-        deref ('last self.words)
-
-    @@ memo
-    inline alloc-func (cls T)
-        sz := (((sizeof T) + (u32_size - 1)) // u32_size) as u32
-        typeid := ('typeidof cls T)
-        static-assert (constant? typeid)
-        IdType := (Id T)
-        static-assert ((alignof T) <= 4)
-            .. "type " (tostring T) " must have alignment <= 4, but has "
-                tostring (alignof T)
-        inline (self)
-            let a b = (allocate self typeid sz)
-            _ (bitcast a IdType) (bitcast b (mutable @T))
-
-    inline... alloc (self, T : type)
-        (alloc-func (typeof self) T) self
-
-    fn... headerof (self, offset : u32)
-        _
-            deref (self.words @ offset)
-            deref (self.words @ (offset + 1))
-
-    struct StackEntry plain
-        id : u32
-        offset : u32
-        typeid : u32
-        size : u32
-        # last reference offset
-        refoffset : u32
-        # 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 cls = (typeof self)
-        let visit =
-            va-option visit ...
-                inline (md ptr)
-                    report "done" md.id (string ('typenameof cls md.typeid))
-        let on-enter =
-            va-option on-enter ...
-                inline (id)
-        local stack : DescendStack
-        local seen : (Set u32)
-        'push stack self root
-        loop ()
-            let md = ('peek stack)
-            let ofs = ('enum-id-offset cls (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
-                    on-enter nextid
-                    'push stack self nextid
-
-    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
-
-    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 ...
-                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))
-                    newid
-        local stack : TransformStack
-        on-enter root
-        'push stack self root
-        loop ()
-            let md = ('peek stack)
-            let ofs = ('enum-id-offset cls (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? cls 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)
-                on-alias oldid newid
-                # clear
-                'pop stack
-                if (empty? stack)
-                    return newmodule (copy 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 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 cls (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
-        bitcast (this-function self id) @T
-    case (self, id : u32)
-        offset := (id as u32) + 2
-        & (self.words @ offset)
-
-    fn... repr (self, id : u32)
-        let cls = (typeof self)
-        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 ('typenameof cls typeid)
-            " "
-            cls.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)
-
-run-stage;
-
-#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
-            array (tuple u32 (Id u32)) 4
-            array u32 4
-            u32
-            Id u32
-            u32
-            Id u32
-            u32
-            array (tuple u32 (Id u32))
-    dragon-type T "testT" 10:u32
-    print-offsets T
-    print "done."
-
-
-do
-    # generate a new DAG module type
-    let TestDAG = (Module "TestDAG")
-    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")
-        dedup = false
-
-    let u32x3 = (array (Id u32) 3)
-    define-type u32x3 "vec3" (RIFF "VEC3")
-
-    # instantiate a module
-    local module : TestDAG
-
-
-    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 k k m
-
-    'dump module
-
-    # perform an identity transform and swap out the new module
-        all transformations are immutable.
-    let newmodule newid = (transform (rootid))
-    module = newmodule
-    # perform a topological transform where we increment the constant values
-    let newmodule newid =
-        transform newid
-            visit =
-                capture (finalize md ptr) {}
-                    switch md.typeid
-                    case ('typeidof TestDAG u32)
-                        (@ ptr) += 1
-                    default;
-                    finalize;
-    module = newmodule
-    assert (newid == (rootid))
-    descend newid
-    'dump module
-
-    ;
-;
  No newline at end of file