88008fa30779 — Leonard Ritter 9 days ago
* support for graphviz visualization
4 files changed, 1068 insertions(+), 2 deletions(-)

A => lib/tukan/CADAG/dot.sc
A => lib/tukan/CADAG/init.sc
M testing/test_cadag.sc
M testing/tukdag.sc
A => lib/tukan/CADAG/dot.sc +100 -0
@@ 0,0 1,100 @@ 
+using import String
+using import Capture
+
+using import .init
+using import ..File
+
+let system = (extern 'system (function i32 rawstring))
+
+fn translate-color (v)
+    let h s v = (unpack v)
+    .. "\""
+        tostring h
+        " "
+        tostring s
+        " "
+        tostring v
+        "\""
+
+# graphviz support for CADAG
+type+ CADAG
+    """"generates dot output by calling function fstream with String values
+    fn dot (self root fstream)
+        let cls = (typeof self)
+        local tmp : String
+        inline commit ()
+            fstream tmp
+            'clear tmp
+        'append tmp
+            """"digraph "CADAG" {
+                    ranksep=0.2 rankdir="TB";
+                    node [shape=box height=0.01 fontsize=8 fontname="sans"];
+                    edge [arrowsize=0.3 fontsize=7 fontname="sans"];
+        commit tmp
+
+        'descend self root
+            visit =
+                capture (module id) {&tmp fstream}
+                    inline commit ()
+                        fstream tmp
+                        'clear tmp
+                    idstr := (tostring id)
+                    'append tmp "    "
+                    'append tmp idstr
+                    'append tmp " ["
+                    inline writeattr (key value)
+                        'append tmp key
+                        'append tmp "="
+                        'append tmp value
+                        'append tmp " "
+                    let handle = ('handleof module id)
+                    writeattr "label"
+                        tostring
+                            .. "%" idstr " = " (string handle.name)
+                    let typeid = (unpack handle)
+                    cls.dispatch-any-type typeid
+                        inline (T typeid)
+                            let info = ('typeinfo cls typeid)
+                            writeattr "fillcolor"
+                                translate-color info.fillcolor
+                            writeattr "textcolor"
+                                translate-color info.textcolor
+                            writeattr "style" "filled"
+                    'append tmp "];\n"
+                    commit;
+                    for k srcid in (enumerate ('sources handle))
+                        srcidstr := (tostring srcid)
+                        'append tmp "    "
+                        'append tmp srcidstr
+                        'append tmp " -> "
+                        'append tmp idstr
+                        'append tmp " ["
+                        writeattr "label" (tostring k)
+                        'append tmp "]"
+                        'append tmp ";\n"
+                        commit;
+                    true
+
+        'append tmp "}\n"
+        commit tmp
+
+    fn showdot (self root basepath)
+        let dotpath = (.. basepath ".dot")
+        let pngpath = (.. basepath ".png")
+        let f =
+            try (File.open dotpath "wb")
+            else
+                print "failed to open dot file for writing"
+                return 255
+        'dot self ('rootid self)
+            capture (s) {(view f)}
+                'write f (& (s @ 0)) (countof s)
+        drop f
+        let err = (system (.. "dot -Tpng " dotpath " > " pngpath))
+        if (err != 0)
+            return err
+        system (.. "eog " pngpath)
+
+
+do
+    locals;

          
A => lib/tukan/CADAG/init.sc +940 -0
@@ 0,0 1,940 @@ 
+
+# 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 String
+using import glm
+
+using import ..SHA256
+
+let u32_size = (sizeof u32)
+
+################################################################################
+
+type Id
+
+    @@ memo
+    inline __== (cls T)
+        static-if (T < this-type)
+            inline (a b)
+                (storagecast a) == (storagecast b)
+
+'define-symbol Id '__copy integer.__copy
+'define-symbol Id '__hash integer.__hash
+
+type+ Id
+    inline __tobool (self)
+        (storagecast self) as bool
+
+    @@ memo
+    inline __imply (cls T)
+        let AnyId = cls.CADAGType.AnyId
+        static-if (T == u32)
+            storagecast
+        elseif (T == integer)
+            storagecast
+        elseif (T == AnyId)
+            inline (self) (bitcast self AnyId)
+
+################################################################################
+
+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) (count - 1)
+    _ Nothing -1
+
+spice flexible-struct-type (T)
+    T as:= type
+    _flexible-struct-type T
+
+################################################################################
+
+fn riff->string (code)
+    local str : String
+    'resize str 4
+    str @ 0 = (code & 0xff:u32) as char
+    str @ 1 = ((code >> 8) & 0xff:u32) as char
+    str @ 2 = ((code >> 16) & 0xff:u32) as char
+    str @ 3 = ((code >> 24) & 0xff:u32) as char
+    str
+
+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
+    T : type
+    name : string
+    dedup? : bool = true
+    userattrs : type = Nothing
+    textcolor : vec3 = (vec3 0)
+    fillcolor : vec3 = (vec3 0 0 0.9)
+
+struct CADAGEnvData
+    typeid->info-map : (Map u32 TypeInfo)
+    name->typeid-map : (Map string u32)
+
+    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
+    try
+        let func = ('@ T '__CADAG_repr)
+        return
+            spice-quote
+                .. " " (func value sz)
+    else;
+    let ST = ('storageof T)
+    switch ('kind ST)
+    pass type-kind-array
+    pass type-kind-tuple
+    do
+        let value = `(storagecast value)
+        let body = (sc_expression_new)
+        let SZ = (('sizeof ST) as u32)
+        vvv bind str
+        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)
+                if (ET == char)
+                    sc_expression_append body
+                        spice-quote
+                            let numelements = ((sz * u32_size - SZ) // ETsz)
+                            let arr = (value @ i)
+                            let str =
+                                .. str " "
+                                    repr
+                                        string (& (arr @ 0)) numelements
+                    str
+                else
+                    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)
+                                    let elemrepr =
+                                        spice-unquote
+                                            this-function ET elem 0
+                                    _ (k + 1) (.. str elemrepr)
+                    str
+            else
+                spice-quote
+                    let str =
+                        .. str " "
+                            spice-unquote
+                                repr-atomic-value ET `(value @ i)
+                sc_expression_append body str
+                str
+        sc_expression_append body 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.typeid->info-map T))
+            error
+                .. "type " (repr T) " has no typeinfo"
+        ('getdefault self.type->info-map T (TypeInfo 0 "")) . typeid
+
+    spice typeinfo (cls code)
+        let self = (getinstance cls)
+        cls as:= type
+        let TypeIdType = (('@ cls 'TypeId) as type)
+        if (('typeof code) != TypeIdType)
+            error
+                .. "typeid must be of type " (repr TypeIdType) ", not "
+                    repr ('typeof code)
+        if (not ('constant? code))
+            error "argument must be constant"
+        let code = ((sc_const_int_extract code) as u32)
+        if (not ('in? self.typeid->info-map code))
+            error
+                .. "typeid " (repr code) " has no typeinfo"
+        'getdefault self.typeid->info-map code (TypeInfo Nothing "")
+
+    #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 dispatch-type (cls typeid ptr ...)
+        let self = (getinstance cls)
+        let sw = ('tag (sc_switch_new typeid) ('anchor args))
+        let mutable? = ('writable? ('typeof ptr))
+        for arg in ('args ...)
+            let k v = ('dekey arg)
+            if (k == unnamed)
+                sc_switch_append_default sw `(v)
+            else
+                name := (k as string)
+                let code =
+                    try (copy ('get self.name->typeid-map name))
+                    else
+                        error
+                            .. "cannot dispatch unbound type name: " name
+                let T =
+                    try (deref (('get self.typeid->info-map code) . T))
+                    else Nothing
+                let PT = (pointer.type T)
+                let PT =
+                    if mutable? ('mutable PT)
+                    else PT
+                sc_switch_append_case sw code `(v (@ (ptr as PT)))
+        sw
+
+    spice define-type (cls name code T ...)
+        cls as:= type
+        let self = (getinstance cls)
+        T as:= type
+        code as:= u32
+        name as:= string
+        local ti =
+            TypeInfo
+                T = T
+                name = name
+        for arg in ('args ...)
+            let k v = ('dekey arg)
+            switch k
+            case 'dedup
+                ti.dedup? = (v as bool)
+            case 'userattrs
+                ti.userattrs = (v as type)
+            case 'textcolor
+                ti.textcolor = (v as vec3)
+            case 'fillcolor
+                ti.fillcolor = (v as vec3)
+            default;
+        let name =
+            if (name == "") (tostring T)
+            else name
+        if ('in? self.typeid->info-map code)
+            let info =
+                try ('get self.typeid->info-map code)
+                else
+                    unreachable;
+            error
+                .. "typeid " (repr code) " already mapped to type " (repr info.T)
+
+        'set self.typeid->info-map code (deref ti)
+
+        'set self.name->typeid-map name code
+
+        #let IdType = (('@ cls 'Id) as type)
+        let TypeIdType = (('@ cls 'TypeId) as type)
+        let enumval = (sc_const_int_new TypeIdType code)
+
+        let namesym = (Symbol name)
+        '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?
+
+        let builder = (('@ cls 'BuilderType) as type)
+        'set-symbol builder namesym
+            spice-quote
+                inline (self ...)
+                    'store (bitcast self cls) enumval ...
+
+        spice-quote
+            '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 =
+    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 TypeId < CEnum
+
+type Handle
+    let __dispatch =
+        inline "#hidden" (self ...)
+            let cls = (typeof self)
+            let typeid sz ptr = (unpack (storagecast self))
+            'dispatch-type cls.CADAGType typeid ptr ...
+
+    inline __unpack (self)
+        unpack (storagecast self)
+
+    fn vacount (self)
+        let cls = (typeof self)
+        let typeid sz = (unpack (storagecast self))
+        'vacount cls.CADAGType 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 (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)
+
+    let name =
+        Accessor
+            inline (self key)
+                let cls = (typeof self)
+                let typeid sz ptr = (unpack (storagecast self))
+                'typenameof cls.CADAGType typeid
+
+type CADAGBuilder
+
+type+ CADAG
+    let builder =
+        Accessor
+            inline (value key)
+                let cls = (typeof value)
+                bitcast (view value) cls.BuilderType
+
+    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
+
+        let BuilderType =
+            type (.. name "Builder") < CADAGBuilder :: (storageof T)
+                let CADAGType = T
+
+        let TypeIdType =
+            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
+
+        let MutableHandleType =
+            type (.. name "MutableHandle") < Handle : (tuple TypeIdType u32 (mutable @u32))
+                let CADAGType = T
+
+        let IdType =
+            type (.. name "Id") < Id
+                let CADAGType = T
+
+                @@ memo
+                inline __typecall (cls typeid)
+                    let info = ('typeinfo typeid)
+                    let T =
+                        type (.. "(" (tostring cls) " " info.name ")") < cls : u32
+                            let Type = info.T
+                            let TypeId = typeid
+                            let Name = info.name
+                    'define-symbol T '__typecall integer.__typecall
+                    T
+
+        type+ T
+            let BuilderType
+            let HandleType
+            let MutableHandleType
+            let Id = IdType
+            let TypeId = TypeIdType
+
+        'define-type T "none" 0:u32 Nothing
+
+        type+ T
+            let AnyId = T.Id-none
+            let NoId = (nullof AnyId)
+
+        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 typeid)
+        let T = (('typeinfo typeid) . T)
+        let ET = (flexible-struct-type T)
+        IdType := (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))
+        else
+            # flexible array
+            fn (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, typeid : TypeId, ...)
+        (alloc-func (typeof self) typeid) self ...
+
+    fn... handleof (self, offset : u32)
+        let cls = (typeof self)
+        let typeid sz = ('headerof self offset)
+        let ptr = ('load self offset)
+        bitcast
+            ((storageof cls.HandleType) typeid sz ptr)
+            cls.HandleType
+
+    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 (module id)
+                    let handle = ('handleof module id)
+                    report "done" id handle.name
+        let on-enter =
+            va-option on-enter ...
+                inline (module id) true
+        local stack : DescendStack
+        local seen : (Set u32)
+        if (on-enter (view self) 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)
+            if (wordofs >= md.size)
+                let oldid = (copy md.id)
+                visit (view self) oldid
+                # 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
+                    if (on-enter (view self) 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)
+            if (sz != 0)
+                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 (module handle finalize)
+                    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 =
+                    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)
+                    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)
+                let newid = (visit (view newmodule) handle finalize)
+                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
+
+    @@ memo
+    inline store-func (typeid)
+        let T = (('typeinfo typeid) . T)
+        static-if ((storageof T) < aggregate)
+            let ET idx = (flexible-struct-type T)
+            let ET... =
+                static-if ((storageof T) < aggregate)
+                    elementsof T
+                else T
+            let ETcount = (va-countof ET...)
+            static-if (ET == Nothing) # not variadic
+                inline (self ...)
+                    let id ptr = (alloc self typeid)
+                    let ptr = (@ ptr)
+                    va-map
+                        inline (i)
+                            (extractvalue ptr i) = (va@ i ...)
+                        va-range ETcount
+                    id
+            else
+                let string? = (ET == char)
+                let ETcount = (ETcount - 1)
+                inline (self ...)
+                    let argcount = (va-countof ...)
+                    let extra =
+                        static-if string?
+                            + 1
+                                va-map
+                                    inline (i)
+                                        let arg = (va@ i ...)
+                                        static-if ((typeof arg) == string)
+                                            (countof arg) as i32
+                                        else 1
+                                    va-range ETcount argcount
+                        else (argcount - ETcount)
+                    let id ptr = (alloc self typeid extra)
+                    let ptr = (@ ptr)
+                    va-map
+                        inline (i)
+                            (extractvalue ptr i) = (va@ i ...)
+                        va-range ETcount
+                    let tail = (extractvalue ptr idx)
+                    static-if string?
+                        va-lfold 0
+                            inline (k i idx)
+                                let arg = (va@ i ...)
+                                let dest = (extractvalue tail idx)
+                                static-if ((typeof arg) == string)
+                                    let count = (countof arg)
+                                    memcpy ((& dest) as (mutable @u32))
+                                        \ (arg as rawstring as @u32) count
+                                    idx + count
+                                else
+                                    dest = arg
+                                    idx + 1
+                            va-range ETcount argcount
+                    else
+                        va-map
+                            inline (i)
+                                (extractvalue tail i) = (va@ (i + ETcount) ...)
+                            va-range extra
+                    id
+        else
+            inline (self value)
+                let id ptr = (alloc self typeid)
+                let ptr = (@ ptr)
+                ptr = value
+                id
+
+    inline... store (self, typeid : TypeId, ...)
+        (store-func typeid) self ...
+
+    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
+                inline (T)
+                    value-typeid-repr (@ (bitcast ptr @T)) sz
+
+    fn dump (self)
+        descend self ('rootid self)
+            visit =
+                capture (module id) {}
+                    print ('repr module id)
+
+do
+    let CADAG RIFF riff->string
+    locals;

          
M testing/test_cadag.sc +3 -0
@@ 3,6 3,7 @@ using import Capture
 
 import ..lib.tukan.use
 using import tukan.CADAG
+using import tukan.CADAG.dot
 
 inline print-offsets (cls typeid)
     report "typeid" typeid "offsets:"

          
@@ 120,5 121,7 @@ do
     #assert (newid == (rootid))
     #descend newid
     'dump module
+    'showdot module ('rootid module)
+        module-dir .. "/test_cadag_dot"
 
     ;
  No newline at end of file

          
M testing/tukdag.sc +25 -2
@@ 4,9 4,11 @@ using import struct
 using import Capture
 using import Map
 using import Array
+using import glm
 
 import ..lib.tukan.use
 using import tukan.CADAG
+using import tukan.CADAG.dot
 
 let SYSKEY_START = 0x80000000:u32
 

          
@@ 64,28 66,47 @@ let FIR = (CADAG "FIR")
 from FIR let AnyId NoId Id
 from (methodsof FIR) let define-type
 
+let typecolor = (vec3 0.15 0.5 1.0)
+let constcolor = (vec3 0.07 0.5 1.0)
+let stringcolor = (vec3 0.22 0.4 1.0)
+let purecolor = (vec3 0.6 0.3 1.0)
+let instrcolor = (vec3 0.98 0.3 1.0)
+
 define-type "ILSymbol"          (RIFF "ISYM") (tuple (size = u32) (str = (array char)))
+    fillcolor = constcolor
 define-type "ILString"          (RIFF "ISTR") (tuple (size = u32) (str = (array char)))
+    fillcolor = stringcolor
 define-type "ILConstInt"        (RIFF "ICIN") (tuple (type = AnyId) (value = u32))
+    fillcolor = constcolor
 define-type "ILParams"          (RIFF "IPMS") (tuple (level = i32) (count = i32))
     dedup = false
 define-type "ILVAGet"           (RIFF "IGET") (tuple (index = i32) (args = AnyId))
 define-type "ILVA"              (RIFF "ILVA") (tuple (args = (array AnyId)))
 define-type "ILTemplate"        (RIFF "ITMP") (tuple (params = AnyId) (body = AnyId))
     dedup = false
+    fillcolor = purecolor
 define-type "ILDo"              (RIFF "IRDO") (tuple (scoped? = bool) (body = (array AnyId)))
     dedup = false
+    fillcolor = instrcolor
 define-type "ILCall"            (RIFF "ICAL") (tuple (callee = AnyId) (args = (array AnyId)))
     dedup = false
+    fillcolor = instrcolor
 define-type "ILNoReturnType"    (RIFF "INRT") (tuple)
+    fillcolor = typecolor
 define-type "ILIntegerType"     (RIFF "IINT") (tuple (width = i32) (signed? = bool))
+    fillcolor = typecolor
 define-type "ILArgumentsType"   (RIFF "IATY") (tuple (types = (array AnyId)))
+    fillcolor = typecolor
 define-type "ILStringType"      (RIFF "ISTY") (tuple)
+    fillcolor = typecolor
 define-type "ILFunctionType"    (RIFF "IFTY") (tuple (return = AnyId) (raise = AnyId) (params = (array AnyId)))
+    fillcolor = typecolor
 define-type "ILGlobal"          (RIFF "IGLO")
     tuple (name = AnyId) (type = AnyId) (flags = u32) (storage = AnyId) (attrs = (array AnyId))
+    fillcolor = purecolor
 define-type "ILIf"              (RIFF "ILIF") (tuple (cond = AnyId) (then = AnyId) (else = AnyId))
     dedup = false
+    fillcolor = instrcolor
 define-type "ILXValue"          (RIFF "ILXV")
     type ILXValueType <: (tuple u32 u32 u32 u32)
         @@ memo

          
@@ 375,7 396,8 @@ do
         \ ILValue ILXValue
 
     let sc_write =
-        ILXValue `sc_write
+        #ILXValue `sc_write
+        ILValue sc_write
     ILTemplate
         let params = (ILParams 0 1)
         ILEmbed

          
@@ 471,7 493,8 @@ module = newmodule
 #assert (newid == (rootid))
 #descend newid
 'dump module
-
+'showdot module ('rootid module)
+    module-dir .. "/tukdag"
 let f =
     generate-IL module