e3de8e73a348 — Leonard Ritter 2 months ago
* initial check-in FIR module
4 files changed, 1163 insertions(+), 1986 deletions(-)

M lib/tukan/CADAG/init.sc
A => lib/tukan/FIR.sc
M testing/test_cadag.sc
M testing/tukdag.sc
M lib/tukan/CADAG/init.sc +33 -19
@@ 44,6 44,10 @@ type+ Id
         elseif (T == integer)
             storagecast
 
+    fn repr (self)
+        default-styler style-symbol
+            .. "%" (tostring self)
+
 ################################################################################
 
 global id-offset-func-map : (Map type (tuple Value usize))

          
@@ 549,22 553,26 @@ type Handle
     let __dispatch =
         inline "#hidden" (self ...)
             let cls = (typeof self)
-            let typeid sz ptr = (unpack (storagecast self))
+            let typeid sz ptr = (unpack self)
             'dispatch-type cls.CADAGType typeid ptr ...
 
     inline __unpack (self)
-        unpack (storagecast self)
+        let typeid sz ptr = (unpack (storagecast self))
+        let ptr = (& (ptr @ 2))
+        _ typeid sz ptr
 
     fn vacount (self)
         let typeid sz = (unpack (storagecast self))
         'vacount typeid sz
 
     inline sources (self)
-        let typeid sz ptr = (unpack (storagecast self))
+        let cls = ((typeof self) . CADAGType)
+        let AnyId = cls.AnyId
+        let typeid sz ptr = (unpack self)
         Generator
             inline () (_ 0:u32 (('enum-id-offset typeid 0:u32) // u32_size))
             inline (i wordofs) (wordofs < sz)
-            inline (i wordofs) (copy (ptr @ wordofs))
+            inline (i wordofs) (bitcast (copy (ptr @ wordofs)) AnyId)
             inline (i wordofs)
                 i := i + 1
                 _ i (('enum-id-offset typeid i) // u32_size)

          
@@ 573,7 581,17 @@ type Handle
         Accessor
             inline (self key)
                 let cls = (typeof self)
-                ((storagecast self) @ 0) as TypeId
+                ((storagecast self) @ 0) as cls.CADAGType.TypeId
+
+    let size =
+        Accessor
+            inline (self key)
+                ((storagecast self) @ 1)
+
+    let data =
+        Accessor
+            inline (self key)
+                & ((storagecast self) @ 2 @ 2)
 
 type CADAGBuilder
 

          
@@ 705,11 723,14 @@ type+ CADAG
         else
             _commit-raw self ptr size
 
-    fn commit (self)
+    fn... commit (self)
         let temp = self.temp
         let id = (commit-from self (& (temp @ 0)))
         'clear temp
         id
+    case (self, handle : Handle)
+        let typeid sz ptr = (unpack (storagecast handle))
+        commit-from self ptr
 
     fn... rootid (self)
         let cls = (typeof self)

          
@@ 744,7 765,7 @@ type+ CADAG
     fn... handleof (self, offset : u32)
         let cls = (typeof self)
         let typeid sz = ('headerof self offset)
-        let ptr = ('load self offset)
+        let ptr = (& (self.words @ offset))
         bitcast
             ((storageof cls.HandleType) typeid sz ptr)
             cls.HandleType

          
@@ 879,8 900,8 @@ type+ CADAG
                     'set aliases oldparamid newparamid
         let on-leave =
             va-option on-leave ...
-                inline (self oldmodule oldid handle finalize)
-                    let newid = (finalize)
+                inline (self handle oldmodule oldid)
+                    let newid = ('commit self handle)
                     #report "done" md.id "->" newid (string (get-typename md.typeid))
                     newid
         local stack : TransformStack

          
@@ 892,18 913,11 @@ type+ CADAG
             let wordofs = (ofs // u32_size)
             vvv bind oldid newid
             if (wordofs >= md.size)
-                # includes header
-                let stackptr = (& (stack.data @ md.offset))
-                capture finalize () {&self stackptr}
-                    'commit-from self stackptr
-                # skip header
-                let stackptr =
-                    if md.size (& (stackptr @ 2))
-                    else (null as (mutable @u32))
                 let handle = (bitcast
-                    ((storageof cls.MutableHandleType) md.typeid md.size stackptr)
+                    ((storageof cls.MutableHandleType) md.typeid md.size
+                        (& (stack.data @ md.offset)))
                     cls.MutableHandleType)
-                let newid = (on-leave self oldmodule (copy md.id) handle finalize)
+                let newid = (on-leave self handle oldmodule (copy md.id))
                 let oldid = (copy md.id)
                 # clear
                 'pop stack

          
A => lib/tukan/FIR.sc +1029 -0
@@ 0,0 1,1029 @@ 
+
+using import enum
+using import struct
+using import Capture
+using import Map
+using import Array
+using import glm
+
+using import .CADAG
+using import .gl
+using import .vm
+
+let SYSKEY_START = 0x80000000:u32
+
+enum SystemKey : u32
+    #   inputs
+        ======
+
+    # u32[0]
+    Setup = SYSKEY_START
+    # u32x2
+    ScreenSize
+    # u32
+    Iteration
+    # u32[?]
+    IState
+    # u32[0]
+    Break
+    # u32[0]
+    Close
+    # zterm u32[?]
+    Readline
+    # u32
+    SampleRate
+    # u32
+    SampleCount
+
+    #   outputs
+        =======
+
+    # u32[?]
+    OState
+    # zterm u32[?]
+    Stdout
+    # u32[0]
+    BlockBreak
+    # u32[0]
+    BlockClose
+    # 2D texture
+    Screen
+    # zterm u32[?]
+    Title
+    # u32[4 * ?]
+    Program
+    # zterm u32[?]
+    Prompt
+    # i32
+    Exit
+    # f32[samplecount * 2]
+    Sound
+
+fn syskey->flag (key)
+    switch key
+    case SystemKey.Setup InputFlags.Setup
+    case SystemKey.ScreenSize InputFlags.ScreenSize
+    case SystemKey.Iteration InputFlags.Iteration
+    case SystemKey.IState InputFlags.State
+    case SystemKey.Break InputFlags.Break
+    case SystemKey.Close InputFlags.Close
+    case SystemKey.Readline InputFlags.Readline
+    case SystemKey.SampleRate InputFlags.SampleRate
+    case SystemKey.SampleCount InputFlags.SampleCount
+    default
+        error
+            .. "unsupported input key: " (repr key)
+
+################################################################################
+
+enum ImageDim : u32
+    1D
+    2D
+    3D
+    Cube
+    Rect
+    Buffer
+
+enum ImageFormat : u32
+    # R|RG|RGBA .. 8|16|32 .. UNORM|SNORM|U|S|F
+
+    let UNORM SNORM U S F = 0 1 2 3 4
+
+    do
+        let comp-sym... = "R" "RG" "RGBA"
+        let fmt-sym... = "UNORM" "SNORM" "U" "S" "F"
+
+        va-map
+            inline (c)
+                let cname = (va@ c comp-sym...)
+                va-map
+                    inline (b)
+                        w := (1 << b)
+                        va-map
+                            inline (f)
+                                let fmtname = (va@ f fmt-sym...)
+                                static-if ((w == 32) & (f <= 1))
+                                    # no unorm/snorm for 32 bit
+                                else
+                                    let lit =
+                                        | c
+                                            (b - 3) << 2
+                                            f << 4
+                                    let sym =
+                                        Symbol
+                                            ..
+                                                cname
+                                                (tostring w)
+                                                fmtname
+                                    tag sym Nothing lit
+                            va-range (va-countof fmt-sym...)
+                    va-range 3 6
+            va-range (va-countof comp-sym...)
+
+    fn setcomponents (self count)
+        let bits =
+            switch count
+            case 1 0:u32
+            case 2 1:u32
+            case 3 2:u32
+            case 4 2:u32
+            default
+                assert false
+                unreachable;
+        bitcast ((self & (~ 3:u32)) | bits) this-type
+
+    inline components (self)
+        1:u32 << (self & 3:u32)
+    inline bitwidth (self)
+        1:u32 << (((self >> 2:u32) & 3:u32) + 3:u32)
+    inline format (self)
+        (self >> 4:u32) & 7:u32
+
+################################################################################
+
+# generate a new DAG module type
+let FIR = (CADAG "FIR")
+from FIR let AnyId NoId Id TypeId
+from (methodsof FIR) let define-type
+
+let
+    typecolor... = (_ (dot.fontcolor = "#f0c674") (dot.color = "#f0c674"))
+    constcolor... = (_ (dot.fontcolor = "#de935f") (dot.color = "#de935f"))
+    stringcolor... = (_ (dot.fontcolor = "#b5bd68") (dot.color = "#b5bd68"))
+    funccolor... = (_ (dot.fontcolor = "#81a2be") (dot.color = "#81a2be"))
+    kwcolor... = (_ (dot.fontcolor = "#b294bb") (dot.color = "#b294bb"))
+    instrcolor... = (_ (dot.fontcolor = "#de5f84") (dot.color = "#de5f84"))
+    commentcolor... = (_ (dot.fontcolor = "#969896") (dot.color = "#969896"))
+
+# FIR Level 2
+################################################################################
+
+define-type "range"     (RIFF "RANG") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
+    stringcolor...
+
+# FIR Level 1
+################################################################################
+
+define-type "uniform"       (RIFF "UNIF") (tuple (type = AnyId) (location = u32))
+enum ImageFlags : u32
+    none = 0:u32
+    arrayed = 1:u32
+    multisampled = 2:u32
+    arrayed-multisampled = 3:u32
+define-type "image"         (RIFF "IMGT")
+    struct ImageType plain
+        dim : ImageDim
+        format : ImageFormat
+        flags : ImageFlags
+
+        let array? = (Accessor (inline (self key) ((self.flags & ImageFlags.arrayed) != 0)))
+        let ms? = (Accessor (inline (self key) ((self.flags & ImageFlags.multisampled) != 0)))
+define-type "wimage"        (RIFF "WIMG") (tuple (type = AnyId) (binding = u32))
+define-type "load"          (RIFF "LOAD") (tuple (pointer = AnyId))
+define-type "getelementptr" (RIFF "GELP") (tuple (value = AnyId) (indices = (array AnyId)))
+define-type "globalid"      (RIFF "GLID") (tuple)
+define-type "imagewrite"    (RIFF "IMGW") (tuple (element = AnyId) (offset = AnyId) (target = AnyId))
+define-type "computefn"     (RIFF "CMFN") (tuple (x = u32) (y = u32) (z = u32) (body = AnyId))
+define-type "bindings"      (RIFF "BIND") (tuple (entries = (array (tuple AnyId AnyId))))
+define-type "imagestorage"  (RIFF "IMST") (tuple (type = AnyId) (x = u32) (y = u32) (z = u32) (levels = u32) (samples = u32))
+define-type "dispatch"      (RIFF "DISP") (tuple (func = AnyId) (x = AnyId) (y = AnyId) (z = AnyId) (sources = AnyId) (sinks = AnyId))
+define-type "rimage"        (RIFF "RIMG") (tuple (type = AnyId) (binding = u32))
+define-type "mimage"        (RIFF "MIMG") (tuple (type = AnyId) (binding = u32))
+define-type "rssbo"         (RIFF "RSBO") (tuple (type = AnyId) (binding = u32))
+define-type "wssbo"         (RIFF "WSBO") (tuple (type = AnyId) (binding = u32))
+define-type "mssbo"         (RIFF "MSBO") (tuple (type = AnyId) (binding = u32)) # mutable SSBO
+define-type "store"         (RIFF "STOR") (tuple (value = AnyId) (pointer = AnyId))
+define-type "bufferstorage" (RIFF "BFST") (tuple (size = u32))
+define-type "idispatch"     (RIFF "IDSP") (tuple (callee = AnyId) (size = AnyId) (sources = AnyId) (sinks = AnyId))
+define-type "sample"        (RIFF "SAMP") (tuple (source = AnyId) (uv = AnyId))
+
+# FIR Level 0
+################################################################################
+
+define-type "fvec"      (RIFF "FVEC") (tuple (count = u32))
+    typecolor...
+define-type "uvec"      (RIFF "UVEC") (tuple (count = u32))
+    typecolor...
+define-type "fvec2"     (RIFF "FVC2") (tuple (x = AnyId) (y = AnyId))
+define-type "fvec3"     (RIFF "FVC3") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
+define-type "fvec4"     (RIFF "FVC4") (tuple (x = AnyId) (y = AnyId) (z = AnyId) (w = AnyId))
+define-type "uvec2"     (RIFF "UVC2") (tuple (x = AnyId) (y = AnyId))
+define-type "uvec3"     (RIFF "UVC3") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
+define-type "uvec4"     (RIFF "UVC4") (tuple (x = AnyId) (y = AnyId) (z = AnyId) (w = AnyId))
+define-type "input"     (RIFF "INPT") (tuple (source = SystemKey))
+    instrcolor...
+define-type "output"    (RIFF "OUTP") (tuple (sink = SystemKey) (value = AnyId))
+    instrcolor...
+define-type "outputs"   (RIFF "OUPS") (tuple (outputs = (array AnyId)))
+    instrcolor...
+define-type "uconst"    (RIFF "U32C") (tuple (value = u32))
+    constcolor...
+define-type "fconst"    (RIFF "F32C") (tuple (value = f32))
+    constcolor...
+define-type "comp"      (RIFF "COMP") (tuple (index = u32) (value = AnyId))
+let Operator1Type = (tuple (value = AnyId))
+let Operator2Type = (tuple (lhs = AnyId) (rhs = AnyId))
+inline define-op1 (name riff)
+    define-type name (RIFF riff) Operator1Type
+        funccolor...
+inline define-op2 (name riff)
+    define-type name (RIFF riff) Operator2Type
+        funccolor...
+
+define-op2 "add"    "IADD"
+define-op2 "sub"    "ISUB"
+define-op2 "mul"    "IMUL"
+define-op2 "udiv"   "UDIV"
+define-op2 "sdiv"   "SDIV"
+define-op2 "urem"   "UREM"
+define-op2 "srem"   "SREM"
+
+define-op2 "eq"   "IEQ_"
+define-op2 "ne"   "INE_"
+define-op2 "ugt"   "UGT_"
+define-op2 "uge"   "UGE_"
+define-op2 "ult"   "ULT_"
+define-op2 "ule"   "ULE_"
+define-op2 "sgt"   "SGT_"
+define-op2 "sge"   "SGE_"
+define-op2 "slt"   "SLT_"
+define-op2 "sle"   "SLE_"
+
+define-op2 "shl"    "ISHL"
+define-op2 "ushr"   "USHR"
+define-op2 "sshr"   "SSHR"
+define-op2 "and"    "IAND"
+define-op2 "or"     "IOR_"
+define-op2 "xor"    "IXOR"
+
+define-op1 "findmsb"    "CTLZ"
+define-op1 "findlsb"    "CTTZ"
+define-op1 "bitcount"   "POPC"
+
+define-op1 "utof"   "UTOF"
+define-op1 "stof"   "STOF"
+define-op1 "ftou"   "FTOU"
+define-op1 "ftos"   "FTOS"
+
+define-op2 "fadd"   "FADD"
+define-op2 "fsub"   "FSUB"
+define-op2 "fmul"   "FMUL"
+define-op2 "fdiv"   "FDIV"
+define-op2 "frem"   "FREM"
+
+define-op1 "fneg"   "FNEG"
+
+define-op2 "foeq"   "FOEQ"
+define-op2 "fone"   "FONE"
+define-op2 "fogt"   "FOGT"
+define-op2 "foge"   "FOGE"
+define-op2 "folt"   "FOLT"
+define-op2 "fole"   "FOLE"
+define-op2 "fo"     "FO__"
+
+define-op2 "fueq"   "FUEQ"
+define-op2 "fune"   "FUNE"
+define-op2 "fugt"   "FUGT"
+define-op2 "fuge"   "FUGE"
+define-op2 "fult"   "FULT"
+define-op2 "fule"   "FULE"
+define-op2 "fu"     "FU__"
+
+define-op1 "sqrt"   "SQRT"
+define-op1 "sin"    "FSIN"
+define-op1 "cos"    "FCOS"
+
+################################################################################
+
+spice setoption-impl (member value)
+    let TT = ('typeof member)
+    let ST = ('typeof value)
+    spice-quote
+        member = value
+        ;
+
+################################################################################
+
+fn generate-IL (module)
+    using import glm
+    using import glsl
+    using import tukan.gl
+
+    struct Context
+        values : (Map AnyId Value)
+        ctx-size : usize
+        setup-ctx : Value
+        setup-body : Value
+        drive-ctx : Value
+        ins : Value
+        outs : Value
+        drive-body : Value
+        drop-ctx : Value
+        drop-body : Value
+
+        fn alloc-program (self main)
+            let PT = GL.Program
+            let UT = (mutable @GL.uint)
+            let T = (mutable @GL.Program)
+            inline gethandle (src offset)
+                bitcast (& (src @ offset)) T
+            inline gethandleT (src offset T)
+                bitcast (& (src @ offset)) T
+
+            let offset = (deref self.ctx-size)
+            self.ctx-size += (sizeof GL.uint)
+            sc_expression_append self.setup-body
+                spice-quote
+                    let ptr = (gethandle [(copy self.setup-ctx)] offset)
+                    let pg = (PT)
+                    call
+                        attach-shaders pg
+                            compute = main
+                            debug = true
+                    store pg ptr
+                    lose ptr
+            sc_expression_append self.drop-body
+                spice-quote
+                    let ptr = (@ (gethandle [(copy self.drop-ctx)] offset))
+                    __drop (view ptr)
+                    lose ptr
+            let ptr = `(@ (gethandleT [(copy self.drive-ctx)] offset UT))
+            sc_expression_append self.drive-body ptr
+            ptr
+
+        fn alloc-texture (self target)
+            let T = (mutable @GL.uint)
+            inline gethandle (src offset)
+                bitcast (& (src @ offset)) T
+
+            let offset = (deref self.ctx-size)
+            self.ctx-size += (sizeof GL.uint)
+            sc_expression_append self.setup-body
+                spice-quote
+                    let ptr = (gethandle [(copy self.setup-ctx)] offset)
+                    GL.CreateTextures target 1 ptr
+            let setup-ptr = `(load ptr)
+            sc_expression_append self.drop-body
+                spice-quote
+                    let ptr = (gethandle [(copy self.drop-ctx)] offset)
+                    GL.DeleteTextures 1 ptr
+            let drive-ptr = `(load (gethandle [(copy self.drive-ctx)] offset))
+            sc_expression_append self.drive-body drive-ptr
+            _ setup-ptr drive-ptr
+
+        fn alloc-buffer (self)
+            let T = (mutable @GL.uint)
+            inline gethandle (src offset)
+                bitcast (& (src @ offset)) T
+
+            let offset = (deref self.ctx-size)
+            self.ctx-size += (sizeof GL.uint)
+            sc_expression_append self.setup-body
+                spice-quote
+                    let ptr = (gethandle [(copy self.setup-ctx)] offset)
+                    GL.CreateBuffers 1 ptr
+            let setup-ptr = `(load ptr)
+            sc_expression_append self.drop-body
+                spice-quote
+                    let ptr = (gethandle [(copy self.drop-ctx)] offset)
+                    GL.DeleteBuffers 1 ptr
+            let drive-ptr = `(load (gethandle [(copy self.drive-ctx)] offset))
+            sc_expression_append self.drive-body drive-ptr
+            _ setup-ptr drive-ptr
+
+    #fn visit-join-const-clause (module id)
+        local values : (Array Value)
+        fn join (module id values)
+            returning void
+            raising Error
+            let recur = this-function
+            expr := (module.exprs @ id)
+            let op a1 a2 a3 = (unpack expr)
+            op := op as Op
+            switch op
+            case Op.CONST32
+                'append values
+                    sc_const_int_new u32 a1
+            case Op.CONST64
+                'append values
+                    sc_const_int_new u32 a1
+                'append values
+                    sc_const_int_new u32 a2
+            case Op.JOIN
+                recur module a1 values
+                recur module a2 values
+            default
+                error
+                    .. (repr op) " operation not permitted in a JOIN clause"
+            ;
+        join module id values
+        let sz = ((countof values) as u32)
+        let T = (sc_vector_type u32 sz)
+        sc_const_aggregate_new T (sz as i32) (& (values @ 0))
+
+    fn syskey->flag (key)
+        switch key
+        case SystemKey.Setup InputFlags.Setup
+        case SystemKey.ScreenSize InputFlags.ScreenSize
+        case SystemKey.Iteration InputFlags.Iteration
+        case SystemKey.IState InputFlags.State
+        case SystemKey.Break InputFlags.Break
+        case SystemKey.Close InputFlags.Close
+        case SystemKey.Readline InputFlags.Readline
+        case SystemKey.SampleRate InputFlags.SampleRate
+        case SystemKey.SampleCount InputFlags.SampleCount
+        default
+            error
+                .. "unsupported input key: " (repr key)
+
+    fn read-input (module ctx key)
+        let ins = (copy ctx.ins)
+        let flag = (syskey->flag key)
+        inline readfield (fieldname)
+            spice-quote
+                assert ((ins.flags & flag) == flag)
+                copy (getattr ins fieldname)
+        switch key
+        pass SystemKey.Setup InputFlags.Setup
+        pass SystemKey.Break InputFlags.Break
+        pass SystemKey.Close InputFlags.Close
+        do `1:u32
+        case SystemKey.ScreenSize
+            readfield 'screen-size
+        case SystemKey.Iteration
+            readfield 'iteration
+        case SystemKey.IState
+            readfield 'state
+        case SystemKey.Readline
+            readfield 'readline
+        case SystemKey.SampleRate
+            readfield 'samplerate
+        case SystemKey.SampleCount
+            readfield 'samplecount
+        default
+            error
+                .. "unsupported input key: " (repr key)
+
+    fn write-output (module ctx key value)
+        let outs = (copy ctx.outs)
+        let body = ctx.drive-body
+        #dump module body key value
+        key as:= SystemKey
+
+        inline writefield (flagsym fieldname)
+            let flag = (getattr OutputFlags flagsym)
+            sc_expression_append body `(outs.flags |= flag)
+            sc_expression_append body
+                `(setoption-impl (getattr outs fieldname) value)
+        switch key
+        # u32[?]
+        case SystemKey.OState
+            writefield 'State 'state
+        # zterm u32[?]
+        case SystemKey.Stdout
+            writefield 'Stdout 'stdout
+        # u32[0]
+        case SystemKey.BlockBreak
+            writefield 'BlockBreak
+        # u32[0]
+        case SystemKey.BlockClose
+            writefield 'BlockClose
+        # f32[width * height * 4]
+        case SystemKey.Screen
+            writefield 'Screen 'screen
+        # zterm u32[?]
+        case SystemKey.Title
+            writefield 'Title 'title
+        # u32[4 * ?]
+        #case SystemKey.Program
+            writefield 'Program 'program
+        # zterm u32[?]
+        case SystemKey.Prompt
+            writefield 'Prompt 'prompt
+        # i32
+        case SystemKey.Exit
+            writefield 'Exit 'exit
+        # f32[samplecount * 2]
+        case SystemKey.Sound
+            writefield 'Sound 'sound
+        default
+            error
+                .. "unsupported output key: " (repr key)
+
+    fn... imagedim->symbol (fmt : ImageDim)
+        switch fmt
+        case ImageDim.1D '1D
+        case ImageDim.2D '2D
+        case ImageDim.3D '3D
+        case ImageDim.Cube 'Cube
+        case ImageDim.Rect 'Rect
+        case ImageDim.Buffer 'Buffer
+        default
+            error
+                .. "unsupported image dimensionality: " (repr fmt)
+
+    fn... imageformat->symbol (fmt : ImageFormat)
+        switch fmt
+        case ImageFormat.RGBA8UNORM 'Rgba8
+        default
+            error
+                .. "unsupported image format: " (repr fmt)
+
+    fn... imageformat->GL (fmt : ImageFormat)
+        # https://www.khronos.org/registry/OpenGL-Refpages/gl4/html/glBindImageTexture.xhtml
+        switch fmt
+        case ImageFormat.RGBA8UNORM GL.RGBA8
+        default
+            error
+                .. "unsupported image format: " (repr fmt)
+
+    inline simplequote (x) `x
+
+    fn genbufstorage (module id ctx)
+        # BUFSTORAGE size
+        from (methodsof module) let opof argsof iterexprlist
+        let rtype = ('typeof module id)
+        let a1 = ((argsof id 0) * (sizeof u32))
+        let setup-ptr drive-ptr = ('alloc-buffer ctx)
+        from GL let NamedBufferStorage
+        let flags = 0:u32
+            #| GL.DYNAMIC_STORAGE_BIT
+                GL.MAP_READ_BIT
+                GL.MAP_WRITE_BIT
+                GL.MAP_PERSISTENT_BIT
+                GL.MAP_COHERENT_BIT
+        sc_expression_append ctx.setup-body
+            `(NamedBufferStorage setup-ptr a1 null flags)
+        drive-ptr
+
+    fn gentexstorage (module imgstorage ctx)
+        from imgstorage let x y z levels samples
+        let rtype = imgstorage.type
+
+        let dim format arrayed? ms? =
+            dispatch ('handleof module rtype)
+            case image (self)
+                from self let dim format array? ms?
+            default
+                error "image type expected"
+        let fmt = (imageformat->GL format)
+        let target =
+            switch dim
+            case ImageDim.1D
+                if arrayed?
+                    GL.TEXTURE_1D_ARRAY
+                else
+                    GL.TEXTURE_1D
+            case ImageDim.2D
+                if arrayed?
+                    if ms?
+                        GL.TEXTURE_2D_MULTISAMPLE_ARRAY
+                    else
+                        GL.TEXTURE_2D_ARRAY
+                elseif ms?
+                    GL.TEXTURE_2D_MULTISAMPLE
+                else
+                    GL.TEXTURE_2D
+            case ImageDim.3D
+                GL.TEXTURE_3D
+            case ImageDim.Cube
+                if arrayed?
+                    GL.TEXTURE_CUBE_MAP_ARRAY
+                else
+                    GL.TEXTURE_CUBE_MAP
+            case ImageDim.Rect
+                GL.TEXTURE_RECTANGLE
+            #case ImageDim.Buffer
+                GL.TEXTURE_BUFFER
+            default
+                error "unsupported image dimensionality"
+        let fixedsamplelocations = GL.TRUE
+        let setup-ptr drive-ptr = ('alloc-texture ctx target)
+        from GL let TextureStorage1D TextureStorage2D TextureStorage3D \
+            TextureStorage2DMultisample TextureStorage3DMultisample
+        sc_expression_append ctx.setup-body
+            switch target
+            case GL.TEXTURE_1D
+                `(TextureStorage1D setup-ptr levels fmt x)
+            pass GL.TEXTURE_1D_ARRAY
+            pass GL.TEXTURE_2D
+            pass GL.TEXTURE_RECTANGLE
+            pass GL.TEXTURE_CUBE_MAP
+            do
+                `(TextureStorage2D setup-ptr levels fmt x y)
+            pass GL.TEXTURE_2D_ARRAY
+            pass GL.TEXTURE_3D
+            pass GL.TEXTURE_CUBE_MAP_ARRAY
+            do
+                `(TextureStorage3D setup-ptr levels fmt x y z)
+            case GL.TEXTURE_2D_MULTISAMPLE_ARRAY
+                `(TextureStorage3DMultisample setup-ptr samples fmt x y z fixedsamplelocations)
+            case GL.TEXTURE_2D_MULTISAMPLE
+                `(TextureStorage2DMultisample setup-ptr samples fmt x y fixedsamplelocations)
+            #case GL.TEXTURE_BUFFER
+                TextureBuffer
+            default
+                unreachable;
+        drive-ptr
+
+    fn visit (module id ctx)
+        if ('in? ctx.values id)
+            return;
+        # prevent cyclic references
+        'set ctx.values id `none
+        inline get (id...)
+            va-map
+                inline (id)
+                    try (copy ('get ctx.values id))
+                    else
+                        error "could not resolve cached value"
+                        #trap;
+                id...
+        inline vecop1 (self op)
+            `(op [(get self.value)])
+        inline castvecop1 (self op T)
+            `(op [(get self.value)] T)
+        inline vecop2 (self op)
+            `(op [(get self.lhs)] [(get self.rhs)])
+        inline veccmpop2 (self op)
+            `(op [(get self.lhs)] [(get self.rhs)])
+        let handle = ('handleof module id)
+        let vacount = ('vacount handle)
+        vvv bind value
+        dispatch handle
+        case uconst (self) `[self.value]
+        case fconst (self) `[self.value]
+        case add (self) (vecop2 self add)
+        case sub (self) (vecop2 self sub)
+        case mul (self) (vecop2 self mul)
+        case udiv (self) (vecop2 self udiv)
+        case sdiv (self) (vecop2 self sdiv)
+        case urem (self) (vecop2 self urem)
+        case srem (self) (vecop2 self srem)
+
+        case shl (self) (vecop2 self shl)
+        case ushr (self) (vecop2 self lshr)
+        case sshr (self) (vecop2 self ashr)
+        case and (self) (vecop2 self band)
+        case or (self) (vecop2 self bor)
+        case xor (self) (vecop2 self bxor)
+
+        case findmsb (self) (vecop1 self findmsb)
+        case findlsb (self) (vecop1 self findlsb)
+        case bitcount (self) (vecop1 self bitcount)
+
+        case eq (self) (veccmpop2 self icmp==)
+        case ne (self) (veccmpop2 self icmp!=)
+        case ugt (self) (veccmpop2 self icmp>u)
+        case uge (self) (veccmpop2 self icmp>=u)
+        case ult (self) (veccmpop2 self icmp<u)
+        case ule (self) (veccmpop2 self icmp<=u)
+        case sgt (self) (veccmpop2 self icmp>s)
+        case sge (self) (veccmpop2 self icmp>=s)
+        case slt (self) (veccmpop2 self icmp<s)
+        case sle (self) (veccmpop2 self icmp<=s)
+
+        case fadd (self) (vecop2 self fadd)
+        case fsub (self) (vecop2 self fsub)
+        case fmul (self) (vecop2 self fmul)
+        case fdiv (self) (vecop2 self fdiv)
+        case frem (self) (vecop2 self frem)
+        case fneg (self) (vecop1 self fneg)
+
+        case sqrt (self) (vecop1 self sqrt)
+        case sin (self) (vecop1 self sin)
+        case cos (self) (vecop1 self cos)
+
+        case foeq (self) (veccmpop2 self fcmp==o)
+        case fone (self) (veccmpop2 self fcmp!=o)
+        case fogt (self) (veccmpop2 self fcmp>o)
+        case foge (self) (veccmpop2 self fcmp>=o)
+        case folt (self) (veccmpop2 self fcmp<o)
+        case fole (self) (veccmpop2 self fcmp<=o)
+
+        case fueq (self) (veccmpop2 self fcmp==u)
+        case fune (self) (veccmpop2 self fcmp!=u)
+        case fugt (self) (veccmpop2 self fcmp>u)
+        case fuge (self) (veccmpop2 self fcmp>=u)
+        case fult (self) (veccmpop2 self fcmp<u)
+        case fule (self) (veccmpop2 self fcmp<=u)
+
+        case fo (self) (veccmpop2 self fcmp-ord)
+        case fu (self) (veccmpop2 self fcmp-uno)
+
+        case utof (self) (castvecop1 self uitofp f32)
+        case stof (self) (castvecop1 self sitofp f32)
+        case ftou (self) (castvecop1 self fptoui u32)
+        case ftos (self) (castvecop1 self fptosi u32)
+
+        case comp (self)
+            `([(get self.value)] @ [self.index])
+        case fvec2 (self)
+            `(vec2 [(get self.x)] [(get self.y)])
+        case fvec3 (self)
+            `(vec3 [(get self.x)] [(get self.y)] [(get self.z)])
+        case fvec4 (self)
+            `(vec4 [(get self.x)] [(get self.y)] [(get self.z)] [(get self.w)])
+        case uvec2 (self)
+            `(uvec2 [(get self.x)] [(get self.y)])
+        case uvec3 (self)
+            `(uvec3 [(get self.x)] [(get self.y)] [(get self.z)])
+        case uvec4 (self)
+            `(uvec4 [(get self.x)] [(get self.y)] [(get self.z)] [(get self.w)])
+        case fvec (self)
+            switch self.count
+            case 1 `f32
+            case 2 `vec2
+            case 3 `vec3
+            case 4 `vec4
+            default
+                error "unsupported vector size"
+        case uvec (self)
+            switch self.count
+            case 1 `u32
+            case 2 `uvec2
+            case 3 `uvec3
+            case 4 `uvec4
+            default
+                error "unsupported vector size"
+        case globalid (self)
+            `(deref gl_GlobalInvocationID)
+        case load (self)
+            `(load [(get self.pointer)])
+        case getelementptr (self)
+            let call = (sc_call_new `getelementptr)
+            sc_call_append_argument call (get self.value)
+            let indices = self.indices
+            for i in (range vacount)
+                sc_call_append_argument call (get (indices @ i))
+            call
+        case image (self)
+            let arrayed? = self.array?
+            let multisampled? = self.ms?
+            let T =
+                switch ('format self.format)
+                case ImageFormat.UNORM vec4
+                case ImageFormat.SNORM vec4
+                case ImageFormat.U uvec4
+                case ImageFormat.S ivec4
+                case ImageFormat.F vec4
+                default
+                    error "unknown component format"
+            let dim = (imagedim->symbol self.dim)
+            let format = (imageformat->symbol self.format)
+            `[(sc_image_type T dim 0 arrayed? multisampled? 2 format unnamed)]
+        case bindings (self) `none
+        case imagestorage (self) `none
+        case uniform (self)
+            let T = ((get self.type) as type)
+            let flags = 0
+            let glob = (sc_global_new 'u T flags 'UniformConstant)
+            sc_global_set_location glob (self.location as i32)
+            `glob
+        case wimage (self)
+            let T = ((get self.type) as type)
+            let flags =
+                |
+                    global-flag-coherent
+                    global-flag-restrict
+                    global-flag-non-readable
+            let glob = (sc_global_new 'wimg T flags 'UniformConstant)
+            sc_global_set_binding glob (self.binding as i32)
+            `glob
+        #case wssbo (self)
+            # SSBOATTR key target? : type
+            let T = ((translate rtype) as type)
+            let T = (tuple.type (array.type T -1))
+            let flags =
+                |
+                    global-flag-buffer-block
+                    global-flag-coherent
+                    global-flag-restrict
+                    if (a2 == 0:u32) global-flag-non-writable
+                    else global-flag-non-readable
+            let glob = (sc_global_new 'ssboattr T flags 'Uniform)
+            a1 as:= i32
+            sc_global_set_binding glob a1
+            `glob
+        case imagewrite (self)
+            `(Image-write [(get self.target)] [(get self.offset)] [(get self.element)])
+        #case Op.WRITE
+            # IMAGEWRITE attr index value : imagetype
+            let a1 a2 a3 = (translate a1 a2 a3)
+            `(write-impl a1 a2 a3)
+        case computefn (self)
+            from self let x y z body
+            let body = (get body)
+
+            spice-quote
+                fn main ()
+                    local_size x y z
+                    body
+                    return;
+            'alloc-program ctx main
+        case dispatch (self)
+            let pg = (get self.func)
+            let x y z = (get self.x self.y self.z)
+            let sources sinks = self.sources self.sinks
+
+            from GL let DispatchCompute DispatchComputeIndirect
+                \ BindBuffer DISPATCH_INDIRECT_BUFFER UseProgram
+
+            let dispatchcmd =
+                `(DispatchCompute x y z)
+                #spice-quote
+                    BindBuffer DISPATCH_INDIRECT_BUFFER source
+                    DispatchComputeIndirect 0
+
+            let body = (sc_expression_new)
+            sc_expression_append body `(UseProgram pg)
+
+            local retargs : (Array Value)
+
+            # bind values from function body instructions
+            do
+                let handle = ('handleof module sources)
+                let numsources = ('vacount handle)
+                let sources =
+                    dispatch handle
+                    case bindings (self) self.entries
+                    default
+                        error "sources must be bindings"
+                for i in (range numsources)
+                    let v k = (unpack (sources @ i))
+                    let khandle = ('handleof module k)
+                    dispatch khandle
+                    case uniform (self)
+                        let k = (get k)
+                        let v = (get v)
+                        let loc = (sc_global_location k)
+                        if (loc >= 0)
+                            sc_expression_append body `(GL.Uniform (ptrtoref k) v)
+                        else
+                            error "uniformattr has no binding"
+                    #case Op.SSBOATTR
+                        let b = (sc_global_binding k)
+                        assert (b >= 0)
+                        from GL let BindBufferBase SHADER_STORAGE_BUFFER
+                        sc_expression_append body
+                            spice-quote
+                                BindBufferBase SHADER_STORAGE_BUFFER b v
+                    default
+                        error
+                            .. "invalid binding type: " (string khandle.typeid.name)
+            do
+                let handle = ('handleof module sinks)
+                let numsinks = ('vacount handle)
+                let sinks =
+                    dispatch handle
+                    case bindings (self) self.entries
+                    default
+                        error "sources must be bindings"
+                for i in (range numsinks)
+                    let v k = (unpack (sinks @ i))
+                    let khandle = ('handleof module k)
+                    dispatch khandle
+                    case wimage (self)
+                        let vhandle = ('handleof module v)
+                        dispatch vhandle
+                        case imagestorage (self)
+                            let v = (gentexstorage module self ctx)
+                            #define-type "imagestorage"  (RIFF "IMST") (tuple (type = AnyId) (x = u32) (y = u32) (z = u32) (levels = u32) (samples = u32))
+                            'append retargs v
+                            let imgfmt =
+                                dispatch ('handleof module self.type)
+                                case image (self)
+                                    imageformat->GL self.format
+                                default
+                                    error "invalid type for image"
+                            let b = (sc_global_binding (get k))
+                            assert (b >= 0)
+                            from GL let FALSE WRITE_ONLY BindImageTexture
+                            sc_expression_append body
+                                spice-quote
+                                    BindImageTexture b v
+                                        0 # level
+                                        FALSE # layered
+                                        0 # layer
+                                        WRITE_ONLY # access
+                                        imgfmt
+                        default
+                            error
+                                .. "invalid binding source for image: " (string vhandle.typeid.name)
+                    default
+                        error
+                            .. "invalid binding type: " (string khandle.typeid.name)
+                    #
+                        v as:= Id
+                        assert ((opof v) == Op.BUFSTORAGE)
+                        let v = (genbufstorage module v ctx)
+                        'append retargs v
+                        let b = (sc_global_binding k)
+                        assert (b >= 0)
+                        from GL let BindBufferBase SHADER_STORAGE_BUFFER
+                        sc_expression_append body
+                            spice-quote
+                                BindBufferBase SHADER_STORAGE_BUFFER b v
+
+            sc_expression_append body dispatchcmd
+            sc_expression_append body `(UseProgram 0)
+            sc_expression_append ctx.drive-body body
+            sc_argument_list_new ((countof retargs) as i32) (& (retargs @ 0))
+        case input (self)
+            read-input module ctx self.source
+        case output (self)
+            write-output module ctx self.sink (get self.value)
+            `()
+        case outputs (self) `()
+        default
+            error "unhandled node type"
+        'set ctx.values id value
+        ;
+
+    let setup-fn = (sc_template_new 'setup)
+
+    let alloc-ctx = (sc_template_new 'alloc-ctx)
+    sc_template_set_inline alloc-ctx
+    let setup-body = (sc_expression_new)
+    sc_expression_append setup-body `(raising Error)
+    let setup-ctx = (sc_call_new alloc-ctx)
+    sc_expression_append setup-body setup-ctx
+
+    let drive-ctx = (sc_parameter_new 'ctx)
+    let drive-ins = (sc_parameter_new 'ins)
+    let drive-outs = (sc_parameter_new 'outs)
+    let drive-fn = (sc_template_new 'drive)
+    sc_template_append_parameter drive-fn drive-ctx
+    sc_template_append_parameter drive-fn drive-ins
+    sc_template_append_parameter drive-fn drive-outs
+
+    let drop-ctx = (sc_parameter_new 'ctx)
+    let drop-fn = (sc_template_new 'drop)
+    sc_template_append_parameter drop-fn drop-ctx
+
+    let drive-body = (sc_expression_new)
+    let drop-body = (sc_expression_new)
+
+    let drive-ctx = `(bitcast drive-ctx @u8)
+    sc_expression_append drive-body drive-ctx
+
+    let drop-ctx = `(bitcast drop-ctx @u8)
+    sc_expression_append drop-body drop-ctx
+
+    local ctx =
+        Context
+            ctx-size = 0
+            setup-ctx = setup-ctx
+            setup-body = setup-body
+            drive-ctx = drive-ctx
+            ins = drive-ins
+            outs = drive-outs
+            drive-body = drive-body
+            drop-ctx = drop-ctx
+            drop-body = drop-body
+
+    'descend module ('rootid module)
+        on-leave =
+            capture (module id) {&ctx}
+                try
+                    visit module id ctx
+                except (err)
+                    hide-traceback;
+                    error@+ err unknown-anchor
+                        .. "while compiling " ('repr module id)
+
+    sc_expression_append ctx.setup-body `(bitcast [(copy setup-ctx)] voidstar)
+    sc_expression_append ctx.drive-body `()
+    sc_expression_append ctx.drop-body `(free [(copy ctx.drop-ctx)])
+
+    sc_template_set_body alloc-ctx `(malloc-array u8 [(copy ctx.ctx-size)])
+
+    sc_template_set_body setup-fn ctx.setup-body
+    sc_template_set_body drive-fn ctx.drive-body
+    sc_template_set_body drop-fn ctx.drop-body
+
+    spice-quote
+        fn realize-functions ()
+            return
+                setup-fn as VMSetupFunctionType
+                drive-fn as VMDriveFunctionType
+                drop-fn as VMDropFunctionType
+    let RealizeType =
+        pointer
+            function
+                Arguments VMSetupFunctionType VMDriveFunctionType \
+                    VMDropFunctionType
+
+    let func = (sc_typify_template realize-functions 0 null)
+    let fptr = (sc_compile func 0)
+    fptr := fptr as RealizeType
+    (fptr)
+
+type+ FIR
+    let gen-templates = generate-IL
+
+################################################################################
+
+do
+    let FIR NoId AnyId SystemKey ImageDim ImageFormat ImageFlags
+    locals;
  No newline at end of file

          
M testing/test_cadag.sc +8 -3
@@ 29,7 29,7 @@ do
             Id-none
             u32
             array (tuple u32 Id-none)
-    print-offsets M.TypeId.testT
+    print-offsets M.TypeId.typeid_testT
     print "done."
 
 run-stage;

          
@@ 84,7 84,7 @@ do
     let newid =
         'translate newmodule module ('rootid module)
             on-leave =
-                capture (module oldmodule oldid handle finalize) {}
+                capture (module handle oldmodule oldid) {}
                     dispatch handle
                     case const (self)
                         print self

          
@@ 112,7 112,12 @@ do
                                 string (& (ptr @ 0)) count
                     default
                         print "unhandled:" (string handle.typeid.name)
-                    finalize;
+                    report "committing..."
+                    let id =
+                        'commit module handle
+                    report
+                        'repr module id
+                    id
 
     # perform an identity transform and swap out the new module
         all transformations are immutable.

          
M testing/tukdag.sc +93 -1964
@@ 1,4 1,3 @@ 
-
 using import enum
 using import struct
 using import Capture

          
@@ 7,962 6,54 @@ using import Array
 using import glm
 
 import ..lib.tukan.use
-using import tukan.CADAG
+using import tukan.FIR
 using import tukan.CADAG.dot
 using import tukan.gl
 using import tukan.vm
 
-let SYSKEY_START = 0x80000000:u32
-
-enum SystemKey : u32
-    #   inputs
-        ======
-
-    # u32[0]
-    Setup = SYSKEY_START
-    # u32x2
-    ScreenSize
-    # u32
-    Iteration
-    # u32[?]
-    IState
-    # u32[0]
-    Break
-    # u32[0]
-    Close
-    # zterm u32[?]
-    Readline
-    # u32
-    SampleRate
-    # u32
-    SampleCount
-
-    #   outputs
-        =======
-
-    # u32[?]
-    OState
-    # zterm u32[?]
-    Stdout
-    # u32[0]
-    BlockBreak
-    # u32[0]
-    BlockClose
-    # 2D texture
-    Screen
-    # zterm u32[?]
-    Title
-    # u32[4 * ?]
-    Program
-    # zterm u32[?]
-    Prompt
-    # i32
-    Exit
-    # f32[samplecount * 2]
-    Sound
-
-fn syskey->flag (key)
-    switch key
-    case SystemKey.Setup InputFlags.Setup
-    case SystemKey.ScreenSize InputFlags.ScreenSize
-    case SystemKey.Iteration InputFlags.Iteration
-    case SystemKey.IState InputFlags.State
-    case SystemKey.Break InputFlags.Break
-    case SystemKey.Close InputFlags.Close
-    case SystemKey.Readline InputFlags.Readline
-    case SystemKey.SampleRate InputFlags.SampleRate
-    case SystemKey.SampleCount InputFlags.SampleCount
-    default
-        error
-            .. "unsupported input key: " (repr key)
-
-################################################################################
-
-enum ImageDim : u32
-    1D
-    2D
-    3D
-    Cube
-    Rect
-    Buffer
-
-enum ImageFormat : u32
-    # R|RG|RGBA .. 8|16|32 .. UNORM|SNORM|U|S|F
-
-    let UNORM SNORM U S F = 0 1 2 3 4
-
-    do
-        let comp-sym... = "R" "RG" "RGBA"
-        let fmt-sym... = "UNORM" "SNORM" "U" "S" "F"
-
-        va-map
-            inline (c)
-                let cname = (va@ c comp-sym...)
-                va-map
-                    inline (b)
-                        w := (1 << b)
-                        va-map
-                            inline (f)
-                                let fmtname = (va@ f fmt-sym...)
-                                static-if ((w == 32) & (f <= 1))
-                                    # no unorm/snorm for 32 bit
-                                else
-                                    let lit =
-                                        | c
-                                            (b - 3) << 2
-                                            f << 4
-                                    let sym =
-                                        Symbol
-                                            ..
-                                                cname
-                                                (tostring w)
-                                                fmtname
-                                    tag sym Nothing lit
-                            va-range (va-countof fmt-sym...)
-                    va-range 3 6
-            va-range (va-countof comp-sym...)
-
-    fn setcomponents (self count)
-        let bits =
-            switch count
-            case 1 0:u32
-            case 2 1:u32
-            case 3 2:u32
-            case 4 2:u32
-            default
-                assert false
-                unreachable;
-        bitcast ((self & (~ 3:u32)) | bits) this-type
-
-    inline components (self)
-        1:u32 << (self & 3:u32)
-    inline bitwidth (self)
-        1:u32 << (((self >> 2:u32) & 3:u32) + 3:u32)
-    inline format (self)
-        (self >> 4:u32) & 7:u32
-
-################################################################################
-
-# generate a new DAG module type
-let FIR = (CADAG "FIR")
-from FIR let AnyId NoId Id TypeId
-from (methodsof FIR) let define-type
-
-let
-    typecolor... = (_ (dot.fontcolor = "#f0c674") (dot.color = "#f0c674"))
-    constcolor... = (_ (dot.fontcolor = "#de935f") (dot.color = "#de935f"))
-    stringcolor... = (_ (dot.fontcolor = "#b5bd68") (dot.color = "#b5bd68"))
-    funccolor... = (_ (dot.fontcolor = "#81a2be") (dot.color = "#81a2be"))
-    kwcolor... = (_ (dot.fontcolor = "#b294bb") (dot.color = "#b294bb"))
-    instrcolor... = (_ (dot.fontcolor = "#de5f84") (dot.color = "#de5f84"))
-    commentcolor... = (_ (dot.fontcolor = "#969896") (dot.color = "#969896"))
-
-################################################################################
-
-define-type "uniform"       (RIFF "UNIF") (tuple (type = AnyId) (location = u32))
-define-type "image"         (RIFF "IMGT") (tuple (dim = ImageDim) (format = ImageFormat) (array? = bool) (ms? = bool))
-define-type "wimage"        (RIFF "WIMG") (tuple (type = AnyId) (binding = u32))
-define-type "load"          (RIFF "LOAD") (tuple (pointer = AnyId))
-define-type "getelementptr" (RIFF "GELP") (tuple (value = AnyId) (indices = (array AnyId)))
-define-type "globalid"      (RIFF "GLID") (tuple)
-define-type "imagewrite"    (RIFF "IMGW") (tuple (element = AnyId) (offset = AnyId) (target = AnyId))
-define-type "computefn"     (RIFF "CMFN") (tuple (x = u32) (y = u32) (z = u32) (body = AnyId))
-define-type "bindings"      (RIFF "BIND") (tuple (entries = (array (tuple AnyId AnyId))))
-define-type "imagestorage"  (RIFF "IMST") (tuple (type = AnyId) (x = u32) (y = u32) (z = u32) (levels = u32) (samples = u32))
-define-type "dispatch"      (RIFF "DISP") (tuple (func = AnyId) (x = AnyId) (y = AnyId) (z = AnyId) (sources = AnyId) (sinks = AnyId))
-define-type "rimage"        (RIFF "RIMG") (tuple (type = AnyId) (binding = u32))
-define-type "mimage"        (RIFF "MIMG") (tuple (type = AnyId) (binding = u32))
-define-type "rssbo"         (RIFF "RSBO") (tuple (type = AnyId) (binding = u32))
-define-type "wssbo"         (RIFF "WSBO") (tuple (type = AnyId) (binding = u32))
-define-type "mssbo"         (RIFF "MSBO") (tuple (type = AnyId) (binding = u32)) # mutable SSBO
-define-type "store"         (RIFF "STOR") (tuple (value = AnyId) (pointer = AnyId))
-define-type "bufferstorage" (RIFF "BFST") (tuple (size = u32))
-define-type "idispatch"     (RIFF "IDSP") (tuple (callee = AnyId) (size = AnyId) (sources = AnyId) (sinks = AnyId))
-
 ################################################################################
 
-define-type "fvec"      (RIFF "FVEC") (tuple (count = u32))
-    typecolor...
-define-type "uvec"      (RIFF "UVEC") (tuple (count = u32))
-    typecolor...
-define-type "fvec2"     (RIFF "FVC2") (tuple (x = AnyId) (y = AnyId))
-define-type "fvec3"     (RIFF "FVC3") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
-define-type "fvec4"     (RIFF "FVC4") (tuple (x = AnyId) (y = AnyId) (z = AnyId) (w = AnyId))
-define-type "uvec2"     (RIFF "UVC2") (tuple (x = AnyId) (y = AnyId))
-define-type "uvec3"     (RIFF "UVC3") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
-define-type "uvec4"     (RIFF "UVC4") (tuple (x = AnyId) (y = AnyId) (z = AnyId) (w = AnyId))
-define-type "input"     (RIFF "INPT") (tuple (source = SystemKey))
-    instrcolor...
-define-type "output"    (RIFF "OUTP") (tuple (sink = SystemKey) (value = AnyId))
-    instrcolor...
-define-type "outputs"   (RIFF "OUPS") (tuple (outputs = (array AnyId)))
-    instrcolor...
-define-type "uconst"    (RIFF "U32C") (tuple (value = u32))
-    constcolor...
-define-type "fconst"    (RIFF "F32C") (tuple (value = f32))
-    constcolor...
-define-type "range"     (RIFF "RANG") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
-    stringcolor...
-define-type "comp"      (RIFF "COMP") (tuple (index = u32) (value = AnyId))
-let Operator1Type = (tuple (value = AnyId))
-let Operator2Type = (tuple (lhs = AnyId) (rhs = AnyId))
-inline define-op1 (name riff)
-    define-type name (RIFF riff) Operator1Type
-        funccolor...
-inline define-op2 (name riff)
-    define-type name (RIFF riff) Operator2Type
-        funccolor...
-
-define-op2 "add"    "IADD"
-define-op2 "sub"    "ISUB"
-define-op2 "mul"    "IMUL"
-define-op2 "udiv"   "UDIV"
-define-op2 "sdiv"   "SDIV"
-define-op2 "urem"   "UREM"
-define-op2 "srem"   "SREM"
-
-define-op2 "eq"   "IEQ_"
-define-op2 "ne"   "INE_"
-define-op2 "ugt"   "UGT_"
-define-op2 "uge"   "UGE_"
-define-op2 "ult"   "ULT_"
-define-op2 "ule"   "ULE_"
-define-op2 "sgt"   "SGT_"
-define-op2 "sge"   "SGE_"
-define-op2 "slt"   "SLT_"
-define-op2 "sle"   "SLE_"
-
-define-op2 "shl"    "ISHL"
-define-op2 "ushr"   "USHR"
-define-op2 "sshr"   "SSHR"
-define-op2 "and"    "IAND"
-define-op2 "or"     "IOR_"
-define-op2 "xor"    "IXOR"
-
-define-op1 "findmsb"    "CTLZ"
-define-op1 "findlsb"    "CTTZ"
-define-op1 "bitcount"   "POPC"
-
-define-op1 "utof"   "UTOF"
-define-op1 "stof"   "STOF"
-define-op1 "ftou"   "FTOU"
-define-op1 "ftos"   "FTOS"
-
-define-op2 "fadd"   "FADD"
-define-op2 "fsub"   "FSUB"
-define-op2 "fmul"   "FMUL"
-define-op2 "fdiv"   "FDIV"
-define-op2 "frem"   "FREM"
+fn lower-FIR (self module)
+    viewing self
+    viewing module
 
-define-op1 "fneg"   "FNEG"
-
-define-op2 "foeq"   "FOEQ"
-define-op2 "fone"   "FONE"
-define-op2 "fogt"   "FOGT"
-define-op2 "foge"   "FOGE"
-define-op2 "folt"   "FOLT"
-define-op2 "fole"   "FOLE"
-define-op2 "fo"     "FO__"
-
-define-op2 "fueq"   "FUEQ"
-define-op2 "fune"   "FUNE"
-define-op2 "fugt"   "FUGT"
-define-op2 "fuge"   "FUGE"
-define-op2 "fult"   "FULT"
-define-op2 "fule"   "FULE"
-define-op2 "fu"     "FU__"
-
-define-op1 "sqrt"   "SQRT"
-define-op1 "sin"    "FSIN"
-define-op1 "cos"    "FCOS"
-
-define-type "sample"    (RIFF "SAMP") (tuple (source = AnyId) (uv = AnyId))
-    instrcolor...
-
-################################################################################
-
-type FInterval <: vec2
-    fn sort (self)
-        let a b = (unpack self)
-        this-type
-            if (a < b) (_ a b)
-            else (_ b a)
-
-    fn fadd (a b)
-        this-type (a + b)
+    struct Metadata
+        range : AnyId
+        #   count read order by propagating depth first. source nodes without any
+            reads always start at order 0.
+            read nodes increase the read order.
+            the read order of a node is the maximum read order of its inputs.
+            nodes with same range and read order may share the same shader
+        read_order : i32
+        elements : u32 = 1
 
-    fn fsub (a b)
-        this-type (a - b.yx)
-
-    fn fmul (a b)
-        let a1 a2 a3 a4 = (unpack (a.xxyy * b.xyxy))
-        this-type (min a1 a2 a3 a4) (max a1 a2 a3 a4)
-
-    fn fdiv (a b)
-        let a1 a2 = (unpack (a.x / b))
-        let a3 a4 = (unpack (a.y / b))
-        this-type (min a1 a2 a3 a4) (max a1 a2 a3 a4)
-
-    fn fabs (x)
-        let a b = (unpack x)
-        let a b =
-            if (a >= 0.0) # strictly positive
-                _ a b
-            elseif (b < 0.0) # strictly negative
-                _ -b -a
-            else # crossing zero
-                _ 0.0 (max -a b)
-        this-type a b
-
-    fn fract (x)
-        let a b = (unpack x)
-        let d = (b - a)
-        let a = (mod a 1.0)
-        let b = (a + d)
-        if (b < 1.0)
-            # is not overlapping boundary
-            this-type a b
-        else
-            # otherwise:
-                union([0 .. b%1], [a%1 .. 1]) -> [0 .. 1]
-            this-type 0 1
-
-    fn frem (a b)
-        'fmul ('fract ('fdiv a b)) b
+        fn programkey (self)
+            tupleof self.range self.read_order
 
-    fn cos (x)
-        let a b = (unpack x)
-        let d = (b - a)
-        let a = (mod a tau)
-        let a s =
-            if (a >= pi) (_ (a - pi) -1.0)
-            else (_ a 1.0)
-        let b = (a + d)
-        let u v = (cos a) (cos b)
-        let u v =
-            if (b < pi)
-                _ u v
-            elseif (b < tau)
-                _ -1.0 (max u v)
-            else
-                _ -1.0 1.0
-        let u v = (u * s) (v * s)
-        let u v =
-            if (u <= v) (_ u v)
-            else (_ v u)
-        this-type u v
-
-    fn sin (x)
-        'cos (x - (pi * 0.5))
-
-type IInterval <: uvec2
-    fn usort (self)
-        let a b = (unpack self)
-        this-type
-            if (a < b) (_ a b)
-            else (_ b a)
-
-    fn isort (self)
-        let a b = (unpack self)
-        let a b = (bitcast a i32) (bitcast b i32)
-        this-type
-            if (a < b) (_ a b)
-            else (_ b a)
-
-    inline gen_u_binop2 (f)
-        fn (a b)
-            # todo: actually do this right
-            let a b = (usort a) (usort b)
-            let a1 a2 a3 a4 =
-                f a.x b.x
-                f a.x b.y
-                f a.y b.x
-                f a.y b.y
-            this-type (min a1 a2 a3 a4) (max a1 a2 a3 a4)
-
-    let
-        and = (gen_u_binop2 &)
-        or = (gen_u_binop2 |)
-        xor = (gen_u_binop2 ^)
-        udiv = (gen_u_binop2 //)
-        urem = (gen_u_binop2 %)
-
-    fn utof (x)
-        let a b = (unpack x)
-        FInterval a b
-
-enum CompileTimeInterval
-    Undefined
-    Composite
-    F : FInterval
-    I : IInterval
-
-################################################################################
+        fn __repr (self)
+            inline fmt-eq (k v)
+                ..
+                    default-styler style-keyword k
+                    default-styler style-operator "="
+                    v
+            if (self.range != NoId)
+                ..
+                    fmt-eq "range" ('repr self.range)
+                    default-styler style-operator "@"
+                    repr self.read_order
+            else ""
 
-struct ProgramInfo
-    range : AnyId
-    read_order : i32
-    ptr : AnyId
-    body : (Array AnyId)
-    bindbody : (Array AnyId)
-    dim : i32
-    buffersize : ivec3
-    localsize : ivec3
-    next_location_index : i32
-    next_binding_index : i32
-    next_tu_index : i32
-    values : (Map AnyId AnyId)
-
-struct Metadata
-    range : AnyId
-    #   count read order by propagating depth first. source nodes without any
-        reads always start at order 0.
-        read nodes increase the read order.
-        the read order of a node is the maximum read order of its inputs.
-        nodes with same range and read order may share the same shader
-    read_order : i32
-    elements : u32 = 1
-    intervals : (array CompileTimeInterval 4) =
-        arrayof CompileTimeInterval
-            (CompileTimeInterval.Undefined)
-            (CompileTimeInterval.Undefined)
-            (CompileTimeInterval.Undefined)
-            (CompileTimeInterval.Undefined)
-
-    fn upper-limit (self)
-        dispatch (self.intervals @ 0)
-        case I (value) value.y
-        default
-            error "integer interval expected"
-
-struct BufferInfo plain
-    ptr : AnyId
-    type : type
-    wglobal : Value
-    glformat : i32
+    struct FIRContext
+        md : (Map AnyId Metadata)
 
-struct FIRContext
-    programs : (Array ProgramInfo)
-    # {range, order} -> program index
-    programkeys : (Map (tuple AnyId i32) u32)
-    buffers : (Array BufferInfo)
-    # {id, imageformat} -> buffer index
-    bufferkeys : (Map (tuple AnyId ImageFormat) u32)
-    md : (Map AnyId Metadata)
-    setup-ctx : AnyId
-    setup-body : (Array AnyId)
-    drive-ctx : AnyId
-    ins : AnyId
-    outs : AnyId
-    drive-body : (Array AnyId)
-    drop-ctx : AnyId
-    drop-body : (Array AnyId)
-    pginfostack : (Array u32) # program index stack
-
-    fn contextwords (self)
-        +
-            (countof self.programs) as u32 - 1
-            (countof self.buffers) as u32
-
-    inline __typecall (cls)
-        local self = (super-type.__typecall cls)
-        'append self.programs (ProgramInfo)
-        'append self.pginfostack 0:u32
-        deref self
-
-    fn active-pginfo (self)
-        self.programs @ ('last self.pginfostack)
-
-    fn getmd (self id)
-        try ('get self.md id)
-        else
-            assert false
-            unreachable;
-
-    fn getbuffer (self value imageformat)
-        let key = (tupleof value imageformat)
-        @ self.buffers
-            try ('get self.bufferkeys key)
+        fn getmd (self id)
+            try ('get self.md id)
             else
                 assert false
                 unreachable;
 
-    fn pop-program (self)
-        'pop self.pginfostack
 
-    fn push-program (self md)
-        let key = (tupleof (copy md.range) (copy md.read_order))
-        'append self.pginfostack
-            try ('get self.programkeys key)
-            else
-                assert false
-                unreachable;
-
-    fn read-input (self module key)
-        from (methodsof module.builder) let ILSymbol ILConstInt
-            \ ILIntegerType ILExtractValue
-        let ins = (copy self.ins)
-        let flag = (syskey->flag key)
-        inline readfield (fieldname)
-            ILExtractValue ins
-                ILSymbol (fieldname as string)
-            #spice-quote
-                assert ((ins.flags & flag) == flag)
-                copy (getattr ins fieldname)
-        switch key
-        pass SystemKey.Setup InputFlags.Setup
-        pass SystemKey.Break InputFlags.Break
-        pass SystemKey.Close InputFlags.Close
-        do
-            ILConstInt (ILIntegerType 32 false) 1
-        case SystemKey.ScreenSize
-            readfield 'screen-size
-        case SystemKey.Iteration
-            readfield 'iteration
-        case SystemKey.IState
-            readfield 'state
-        case SystemKey.Readline
-            readfield 'readline
-        case SystemKey.SampleRate
-            readfield 'samplerate
-        case SystemKey.SampleCount
-            readfield 'samplecount
-        default
-            error
-                .. "unsupported input key: " (repr key)
-
-    fn write-output (self module key value)
-        from (methodsof module.builder) let ILSymbol ILConstInt
-            \ ILIntegerType ILExtractValue ILAssign ILOr
-        let outs = self.outs
-        let body = self.drive-body
-
-        inline writefield (flagsym fieldname)
-            let flag = (getattr OutputFlags flagsym)
-
-            let flagptr =
-                ILExtractValue outs
-                    ILSymbol "flags"
-            'append body
-                ILAssign
-                    ILOr
-                        flagptr
-                        ILConstInt (ILIntegerType 64 false) (flag as u32)
-                    flagptr
-            static-if (not (none? fieldname))
-                'append body
-                    ILAssign
-                        value
-                        ILExtractValue outs
-                            ILSymbol (fieldname as string)
-        switch key
-        # u32[?]
-        case SystemKey.OState
-            writefield 'State 'state
-        # zterm u32[?]
-        case SystemKey.Stdout
-            writefield 'Stdout 'stdout
-        # u32[0]
-        case SystemKey.BlockBreak
-            writefield 'BlockBreak
-        # u32[0]
-        case SystemKey.BlockClose
-            writefield 'BlockClose
-        # f32[width * height * 4]
-        case SystemKey.Screen
-            writefield 'Screen 'screen
-        # zterm u32[?]
-        case SystemKey.Title
-            writefield 'Title 'title
-        # u32[4 * ?]
-        #case SystemKey.Program
-            writefield 'Program 'program
-        # zterm u32[?]
-        case SystemKey.Prompt
-            writefield 'Prompt 'prompt
-        # i32
-        case SystemKey.Exit
-            writefield 'Exit 'exit
-        # f32[samplecount * 2]
-        case SystemKey.Sound
-            writefield 'Sound 'sound
-        default
-            error
-                .. "unsupported output key: " (repr key)
-
-    fn alloc-buffers (self module offset)
-        from (methodsof module.builder) let ILIntegerType ILConstInt ILCall
-            \ ILLoad ILValue ILGetElementPtr
-
-        let u32id = (ILIntegerType 32 false)
-        let i32id = (ILIntegerType 32 true)
-        let offsetid = (ILConstInt u32id (offset as u32))
-
-        let numbuffersid =
-            ILConstInt i32id ((countof self.buffers) as u32)
-
-        'append self.setup-body
-            ILCall
-                ILLoad
-                    ILValue (reftoptr GLAPI.define.glCreateBuffers)
-                numbuffersid
-                ILGetElementPtr self.setup-ctx offsetid
-
-        'append self.drop-body
-            ILCall
-                ILLoad
-                    ILValue (reftoptr GLAPI.define.glDeleteBuffers)
-                numbuffersid
-                ILGetElementPtr self.drop-ctx offsetid
-
-        for i buf in (enumerate self.buffers u32)
-            report "buffer" ((offset as u32) + i)
-            let offsetid = (ILConstInt u32id ((offset as u32) + i))
-            let ptr = (ILGetElementPtr self.drive-ctx offsetid)
-            'append self.drive-body ptr
-            buf.ptr = ptr
-
-    fn alloc-program (self module pginfo offset)
-        from (methodsof module.builder) let ILValue ILCall ILLoad ILStore
-            \ ILGetElementPtr ILConstInt ILIntegerType ILBitcast ILPointerType
-
-        let u32id = (ILIntegerType 32 false)
-        let offsetid = (ILConstInt u32id (offset as u32))
-
-        'append self.setup-body
-            ILStore
-                ILCall
-                    ILLoad
-                        ILValue (reftoptr GLAPI.define.glCreateProgram)
-                ILGetElementPtr self.setup-ctx offsetid
-
-        let ptr = (ILGetElementPtr self.drive-ctx offsetid)
-        'append self.drive-body ptr
-        pginfo.ptr = ptr
-
-        'append self.drop-body
-            ILCall
-                ILLoad
-                    ILValue (reftoptr GLAPI.define.glDeleteProgram)
-                ILLoad
-                    ILGetElementPtr self.drop-ctx offsetid
-
-    #
-        let PT = GL.Program
-        let UT = (mutable @GL.uint)
-        let T = (mutable @GL.Program)
-        inline gethandle (src offset)
-            bitcast (& (src @ offset)) T
-        inline gethandleT (src offset T)
-            bitcast (& (src @ offset)) T
-
-        let offset = (deref self.ctx-size)
-        self.ctx-size += (sizeof GL.uint)
-        sc_expression_append self.setup-body
-            spice-quote
-                let ptr = (gethandle [(copy self.setup-ctx)] offset)
-                let pg = (PT)
-                call
-                    attach-shaders pg
-                        compute = main
-                        debug = true
-                store pg ptr
-                lose ptr
-        sc_expression_append self.drop-body
-            spice-quote
-                let ptr = (@ (gethandle [(copy self.drop-ctx)] offset))
-                __drop (view ptr)
-                lose ptr
-        let ptr = `(@ (gethandleT [(copy self.drive-ctx)] offset UT))
-        sc_expression_append self.drive-body ptr
-        ptr
-
-fn translate-FIR (self module)
-    viewing self
-    viewing module
     local ctx : FIRContext
-    'append ctx.pginfostack 0:u32 # append CPU program
-
-    fn genprogram (module ctx rangeid read_order)
-        assert (rangeid != NoId)
-        let key = (tupleof rangeid read_order)
-        try
-            return (copy ('get ctx.programkeys key))
-        else;
-        # reuse an existing program if possible, otherwise allocate a new one
-        let mdx mdy mdz =
-            dispatch ('handleof module rangeid)
-            case range (self)
-                _
-                    'getmd ctx self.x
-                    'getmd ctx self.y
-                    'getmd ctx self.z
-            default
-                assert false
-                unreachable;
-        let allocsize =
-            ivec3
-                'upper-limit mdx
-                'upper-limit mdy
-                'upper-limit mdz
-        # wave size
-        let dim localsize =
-            do
-                if (allocsize.z == 1)
-                    if (allocsize.y == 1)
-                        _ 1 (ivec3 64 1 1)
-                    else
-                        _ 2 (ivec3 8 8 1)
-                else
-                    _ 3 (ivec3 4 4 4)
-        let localsize = (min allocsize localsize)
-        do
-            let w h d = (va-map usize (unpack allocsize))
-            switch d
-            case 1
-                if (w > 4194304)
-                    error "range too big"
-            case 2
-                if ((max w h) > 4096)
-                    error "range too big"
-            case 3
-                if ((max w h d) > 1024)
-                    error "range too big"
-            default;
-        #let wx wy wz = (unpack localsize)
-        #from (methodsof module.builder) let ILLocalSize
-        #local body : (Array AnyId)
-        #'append body
-            ILLocalSize wx wy wz
-        #let ptr = ('alloc-program ctx module)
-        #do
-            from GL let UseProgram DispatchCompute
-
-            let pginfo = ('getcpuprogram ctx)
-            let d1 d2 d3 =
-                va-map
-                    inline (id)
-                        visit module id ctx pginfo
-                    \ d1 d2 d3
-            let wx-1 wy-1 wz-1 = (wx - 1) (wy - 1) (wz - 1)
-            sc_expression_append ctx.drive-body
-                spice-quote
-                    UseProgram ptr
-                    bindbody
-                    DispatchCompute
-                        (d1 + wx-1) // wx
-                        (d2 + wy-1) // wy
-                        (d3 + wz-1) // wz
-                    UseProgram 0
-
-        let pginfo =
-            ProgramInfo
-                range = rangeid
-                read_order = read_order
-                #ptr = ptr
-                dim = dim
-                buffersize = allocsize
-                localsize = localsize
-        let pgindex = ((countof ctx.programs) as u32)
-        'append ctx.programs pginfo
-        'set ctx.programkeys key pgindex
-        pgindex
-
-    fn... imagedim->symbol (fmt : ImageDim)
-        switch fmt
-        case ImageDim.1D '1D
-        case ImageDim.2D '2D
-        case ImageDim.3D '3D
-        case ImageDim.Cube 'Cube
-        case ImageDim.Rect 'Rect
-        case ImageDim.Buffer 'Buffer
-        default
-            error
-                .. "unsupported image dimensionality: " (repr fmt)
-
-    fn... imageformat->symbol (fmt : ImageFormat)
-        switch fmt
-        case ImageFormat.RGBA8UNORM 'Rgba8
-        case ImageFormat.R32F 'R32f
-        case ImageFormat.RG32F 'Rg32f
-        case ImageFormat.RGBA32F 'Rgba32f
-        default
-            error
-                .. "unsupported image format: " (repr fmt)
-
-    fn... imageformat->GL (fmt : ImageFormat)
-        using GLAPI.define
-        # https://www.khronos.org/registry/OpenGL-Refpages/gl4/html/glBindImageTexture.xhtml
-        switch fmt
-        case ImageFormat.RGBA8UNORM GL_RGBA8
-        case ImageFormat.R32F GL_R32F
-        case ImageFormat.RG32F GL_RG32F
-        case ImageFormat.RGBA32F GL_RGBA32F
-        default
-            error
-                .. "unsupported image format: " (repr fmt)
-
-    fn genbuffer (module ctx source imageformat)
-        assert (('components imageformat) == 1)
-        let key = (tupleof source imageformat)
-        try
-            return (copy ('get ctx.bufferkeys key))
-        else;
-        let md = ('getmd ctx source)
-        let pginfo =
-            ctx.programs @
-                genprogram module ctx (copy md.range) (copy md.read_order)
-        let elements = (copy md.elements)
-        assert (elements >= 1)
-        let arrayed? = false
-        let multisampled? = false
-        let imageformat = ('setcomponents imageformat elements)
-        using GLAPI.define
-        let imgdim target =
-            switch pginfo.dim
-            case 1 # 1D texture
-                _ '1D GL_TEXTURE_1D
-            case 2 # 2D texture
-                _ '2D GL_TEXTURE_2D
-            case 3 # 3D texture
-                _ '3D GL_TEXTURE_3D
-            default
-                assert false
-                unreachable;
-        let T =
-            switch ('format imageformat)
-            case ImageFormat.UNORM vec4
-            case ImageFormat.SNORM vec4
-            case ImageFormat.U uvec4
-            case ImageFormat.S ivec4
-            case ImageFormat.F vec4
-            default
-                error "unknown component format"
-        let format = (imageformat->symbol imageformat)
-        let glformat = (imageformat->GL imageformat)
-        let IT = (sc_image_type T imgdim 0 arrayed? multisampled? 2 format unnamed)
-        let RIT = (sc_sampled_image_type (sc_image_type T imgdim 0 arrayed? multisampled? 1 'Unknown unnamed))
-        let flags =
-            | global-flag-coherent global-flag-restrict
-        wflags := flags | global-flag-non-readable
-        let wglobal = (sc_global_new 'wbuf IT wflags 'UniformConstant)
-        let binding_index = (copy pginfo.next_binding_index)
-        pginfo.next_binding_index += 1
-        sc_global_set_binding wglobal binding_index
-
-        #let coord = `(deref gl_GlobalInvocationID)
-        #let coord =
-            switch pginfo.dim
-            case 1 `coord.x
-            case 2 `coord.xy
-            case 3 `coord
-            default
-                assert false
-                unreachable;
-        #let value =
-            switch md.elements
-            case 1 `(uvec4 (uconv value) 0 0 0)
-            case 2 `(uvec4 (uconv value) 0 0)
-            case 3 `(uvec4 (uconv value) 0)
-            case 4 value
-            default
-                assert false
-                unreachable;
-        #sc_expression_append pginfo.body `(imagewrite-impl (ptrtoref wglobal) coord value)
-
-        #let x y z = (unpack (copy pginfo.buffersize))
-        #let levels = 1
-        #let samples = 4
-        #let fixedsamplelocations = GL.TRUE
-        #let setup-ptr drive-ptr = ('alloc-texture ctx target)
-        #from GL let TextureStorage1D TextureStorage2D TextureStorage3D \
-            TextureStorage2DMultisample TextureStorage3DMultisample
-        #sc_expression_append ctx.setup-body
-            switch target
-            case GL.TEXTURE_1D
-                `(TextureStorage1D setup-ptr levels glformat x)
-            pass GL.TEXTURE_1D_ARRAY
-            pass GL.TEXTURE_2D
-            pass GL.TEXTURE_RECTANGLE
-            pass GL.TEXTURE_CUBE_MAP
-            do
-                `(TextureStorage2D setup-ptr levels glformat x y)
-            pass GL.TEXTURE_2D_ARRAY
-            pass GL.TEXTURE_3D
-            pass GL.TEXTURE_CUBE_MAP_ARRAY
-            do
-                `(TextureStorage3D setup-ptr levels glformat x y z)
-            case GL.TEXTURE_2D_MULTISAMPLE_ARRAY
-                `(TextureStorage3DMultisample setup-ptr samples glformat x y z fixedsamplelocations)
-            case GL.TEXTURE_2D_MULTISAMPLE
-                `(TextureStorage2DMultisample setup-ptr samples glformat x y fixedsamplelocations)
-            #case GL.TEXTURE_BUFFER
-                TextureBuffer
-            default
-                unreachable;
-
-        # bind to program
-        #from GL let FALSE WRITE_ONLY BindImageTexture
-        #sc_expression_append pginfo.bindbody
-            spice-quote
-                BindImageTexture binding_index drive-ptr
-                    0 # level
-                    FALSE # layered
-                    0 # layer
-                    WRITE_ONLY # access
-                    glformat
-
-        let bi =
-            BufferInfo
-                type = RIT
-                wglobal = wglobal
-                glformat = glformat
-        let bufindex = ((countof ctx.buffers) as u32)
-        'append ctx.buffers bi
-        'set ctx.bufferkeys key bufindex
-        bufindex
-
-    capture on-enter-param (module oldmodule id index paramid) {&ctx}
-        #dispatch ('handleof oldmodule id)
-        #case output (self)
-            switch self.sink
-            case SystemKey.Screen
-            default
-                error
-                    .. "unsupported output key: " (repr key)
-        #default;
-        let pginfo = ('active-pginfo ctx)
-        try
-            return (_ false (copy ('get pginfo.values paramid)))
-        else;
-        _ true NoId
-
-    capture on-leave-param (module oldmodule id index oldparamid newparamid) {&ctx}
-        print "on leave" id index
-        let pginfo = ('active-pginfo ctx)
-        'set pginfo.values oldparamid newparamid
-        ;
-
-    capture on-enter (module oldmodule id) {&ctx}
-        let handle = ('handleof oldmodule id)
-        dispatch handle
-        case output (self)
-            switch self.sink
-            case SystemKey.Screen
-                #let key = (tupleof self.source ImageFormat.R8UNORM)
-                #if ('has? ctx.buffers key)
-                #else;
-                md := ('getmd ctx self.value)
-                if (md.range == NoId)
-                    error "ranged expression expected"
-                'push-program ctx md
-            default
-                error
-                    .. "unsupported output key: " (repr key)
-        case range (self)
-            'append ctx.pginfostack 0:u32
-        default;
-        true
 
     fn merge-all-read-orders (ctx handle md)
         md.read_order =

          
@@ 981,7 72,6 @@ fn translate-FIR (self module)
                         error "operation is mixing different ranges"
 
     fn compute-metadata (ctx module handle vacount id)
-        from CompileTimeInterval let Undefined Composite F I
         local md : Metadata
         inline get (id)
             'getmd ctx id

          
@@ 995,48 85,12 @@ fn translate-FIR (self module)
 
         inline ibinop (self iaf)
             merge-all;
-            md.intervals @ 0 =
-                I
-                    iaf
-                        dispatch ((get self.lhs) . intervals @ 0)
-                        case I (lhs) lhs
-                        default
-                            error "integer interval expected"
-                        dispatch ((get self.rhs) . intervals @ 0)
-                        case I (rhs) rhs
-                        default
-                            error "integer interval expected"
         inline fbinop (self iaf)
             merge-all;
-            md.intervals @ 0 =
-                F
-                    iaf
-                        dispatch ((get self.lhs) . intervals @ 0)
-                        case F (lhs) lhs
-                        default
-                            error "float interval expected"
-                        dispatch ((get self.rhs) . intervals @ 0)
-                        case F (rhs) rhs
-                        default
-                            error "float interval expected"
         inline ifunop (self iaf)
             merge-all;
-            md.intervals @ 0 =
-                F
-                    iaf
-                        dispatch ((get self.value) . intervals @ 0)
-                        case I (value) value
-                        default
-                            error "integer interval expected"
         inline funop (self iaf)
             merge-all;
-            md.intervals @ 0 =
-                F
-                    iaf
-                        dispatch ((get self.value) . intervals @ 0)
-                        case F (value) value
-                        default
-                            error "float interval expected"
 
         dispatch handle
         case outputs (self)

          
@@ 1050,23 104,16 @@ fn translate-FIR (self module)
                 md := ('getmd ctx self.value)
                 if (md.range == NoId)
                     error "ranged expression expected"
-                genbuffer module ctx self.value ImageFormat.R8UNORM
             default
                 error
                     .. "unsupported output key: " (repr key)
         case uconst (self)
-            md.intervals @ 0 = (I (IInterval self.value))
         case fconst (self)
-            md.intervals @ 0 = (F (FInterval self.value))
         case input (self)
             switch self.source
             case SystemKey.ScreenSize
                 md.elements = 2
-                let ival = (IInterval 1 4096)
-                md.intervals @ 0 = (I ival)
-                md.intervals @ 1 = (I ival)
             case SystemKey.Iteration
-                md.intervals @ 0 = (I (IInterval 0:u32 0xffffffff:u32))
             default
                 error
                     .. "invalid input source: " (repr key)

          
@@ 1074,22 121,15 @@ fn translate-FIR (self module)
             md.range = id
             md.elements = 3
             merge-all-read-orders;
-            inline compute-interval (id)
-                dispatch ((get id) . intervals @ 0)
-                case I (value)
-                    I (IInterval 0:u32 ((max 1:u32 (unpack value)) - 1:u32))
-                default
-                    error "integer interval expected"
-            md.intervals @ 0 = (compute-interval self.x)
-            md.intervals @ 1 = (compute-interval self.y)
-            md.intervals @ 2 = (compute-interval self.z)
         case comp (self)
             merge-all-read-orders;
             merge-all-ranges;
             let srcmd = (get self.value)
             if (self.index > srcmd.elements)
                 error "component out of range"
-            md.intervals @ 0 = (copy (srcmd.intervals @ self.index))
+        case add (self) (ibinop self 'add)
+        case sub (self) (ibinop self 'sub)
+        case mul (self) (ibinop self 'mul)
         case fadd (self) (fbinop self 'fadd)
         case fmul (self) (fbinop self 'fmul)
         case fdiv (self) (fbinop self 'fdiv)

          
@@ 1103,947 143,43 @@ fn translate-FIR (self module)
         case fvec2 (self)
             md.elements = 2
             merge-all;
-            md.intervals @ 0 = (copy ((get self.x) . intervals @ 0))
-            md.intervals @ 1 = (copy ((get self.y) . intervals @ 0))
         case fvec4 (self)
             md.elements = 4
             merge-all;
-            md.intervals @ 0 = (copy ((get self.x) . intervals @ 0))
-            md.intervals @ 1 = (copy ((get self.y) . intervals @ 0))
-            md.intervals @ 2 = (copy ((get self.z) . intervals @ 0))
-            md.intervals @ 3 = (copy ((get self.w) . intervals @ 0))
         case sample (self)
             merge-all-read-orders;
             let srcmd = (get self.source)
             if (srcmd.range == NoId)
                 error "ranged expression expected"
-            genbuffer module ctx self.source ImageFormat.R32F
             md.range = (get self.uv) . range
             md.read_order += 1
             md.elements = srcmd.elements
-            for i in (range 4)
-                md.intervals @ i = (copy (srcmd.intervals @ i))
         default
             error@ unknown-anchor
                 .. "while checking " (string handle.typeid.name)
                 "invalid node type"
         md
 
-    fn compute-ilvalue (ctx module handle finalize vacount oldmodule oldid)
-        from (methodsof module.builder) let ILConstInt ILIntegerType
-            \ ILConstReal ILRealType ILGlobal ILSymbol ILVectorType ILLoad
-            \ ILBuiltin ILCall ILKeyed ILUndef ILInsertElement ILExtractElement
-            \ ILAnd ILOr ILXor ILFAdd ILFMul ILFDiv ILSin ILCos ILUIToFP
-            \ ILSample ILFetch
-        vvv bind op1
-        inline "#hidden" (self op)
-            return
-                op self.value
-        vvv bind op2
-        inline "#hidden" (self op)
-            return
-                op self.lhs self.rhs
-        inline constint (value)
-            ILConstInt (ILIntegerType 32 true) (bitcast value u32)
-        inline constfloat (value)
-            ILConstReal (ILRealType 32) value
-        dispatch handle
-        case outputs (self)
-        case output (self)
-            switch self.sink
-            case SystemKey.Screen
-                let pginfo = ('last ctx.pginfostack)
-                dispatch ('handleof oldmodule oldid)
-                case output (self)
-                    let bufinfo = ('getbuffer ctx self.value ImageFormat.R8UNORM)
-                    # generate actual code here
-                    'write-output ctx module self.sink bufinfo.ptr
-                default
-                    assert false
-                'pop ctx.pginfostack
-            default
-                error
-                    .. "unsupported output key: " (repr key)
-            return NoId
-        case uconst (self)
-            return
-                ILConstInt (ILIntegerType 32 false) self.value
-        case fconst (self)
-            return
-                ILConstReal (ILRealType 32) self.value
-        case range (self)
-            'pop ctx.pginfostack
-            return
-                ILLoad
-                    ILGlobal (ILSymbol "spirv.GlobalInvocationId")
-                        ILVectorType (ILIntegerType 32 false) 3
-                        global-flag-non-writable
-                        ILSymbol "Input"
-        case comp (self)
-            return
-                ILExtractElement self.value (constint self.index)
-        case and (self) (op2 self ILAnd)
-        case xor (self) (op2 self ILOr)
-        case fadd (self) (op2 self ILFAdd)
-        case fmul (self) (op2 self ILFMul)
-        case fdiv (self) (op2 self ILFDiv)
-        case sin (self) (op1 self ILSin)
-        case cos (self) (op1 self ILCos)
-        case utof (self)
-            return (ILUIToFP self.value (ILRealType 32))
-        case uvec (self)
-            #ILVectorType (ILIntegerType 32 false) self.count
-        case fvec (self)
-            #ILVectorType (ILRealType 32) self.count
-        case fvec2 (self)
-            let id = (ILUndef (ILVectorType (ILRealType 32) 2))
-            let id = (ILInsertElement id self.x (constint 0))
-            let id = (ILInsertElement id self.y (constint 1))
-            return id
-        case fvec3 (self)
-            let id = (ILUndef (ILVectorType (ILRealType 32) 3))
-            let id = (ILInsertElement id self.x (constint 0))
-            let id = (ILInsertElement id self.y (constint 1))
-            let id = (ILInsertElement id self.z (constint 2))
-            return id
-        case fvec4 (self)
-            let id = (ILUndef (ILVectorType (ILRealType 32) 4))
-            let id = (ILInsertElement id self.x (constint 0))
-            let id = (ILInsertElement id self.y (constint 1))
-            let id = (ILInsertElement id self.z (constint 2))
-            let id = (ILInsertElement id self.w (constint 3))
-            return id
-        case input (self)
-            return ('read-input ctx module self.source)
-        case sample (self)
-            return
-                ILSample self.source self.uv (constfloat 0.0)
-        default
-            error@ unknown-anchor
-                .. "while translating " (string handle.typeid.name)
-                "invalid node type"
-        finalize;
-
     'descend module ('rootid module)
         on-leave =
             capture (module id) {&ctx}
                 let handle = ('handleof module id)
                 let vacount = ('vacount handle)
                 let md = (compute-metadata ctx module handle vacount id)
+                print ('repr module id) (repr md)
                 'set ctx.md id md
 
-    capture on-leave (module oldmodule oldid handle finalize) {&ctx}
-        let vacount = ('vacount handle)
-        compute-ilvalue ctx module handle finalize vacount oldmodule oldid
-
-    from (methodsof self.builder) let ILParams ILVAGet ILTemplate ILVA ILDo
-        \ ILMallocArray ILFree ILIntegerType ILConstInt ILBitcast ILPointerType
-
-    let setup-params = (ILParams 0 0)
-    let u32id = (ILIntegerType 32 false)
-    let pu32id = (ILPointerType u32id)
-    let setup-ctx = (ILMallocArray u32id (ILConstInt u32id ('contextwords ctx)))
-    ctx.setup-ctx = setup-ctx
-    'append ctx.setup-body setup-ctx
-    # ctx, ins, outs
-    let drive-params = (ILParams 0 3)
-    let drive-ctx =
-        ILBitcast
-            ILVAGet 0 drive-params
-            pu32id
-    ctx.drive-ctx = drive-ctx
-    'append ctx.drive-body drive-ctx
-    ctx.ins = (ILVAGet 1 drive-params)
-    ctx.outs = (ILVAGet 2 drive-params)
-    # ctx
-    let drop-params = (ILParams 0 1)
-    let drop-ctx =
-        ILBitcast
-            ILVAGet 0 drop-params
-            pu32id
-    'append ctx.drop-body drop-ctx
-    ctx.drop-ctx = drop-ctx
-
-    local offset = 0:u32
-    for i in (range 1:u32 ((countof ctx.programs) as u32))
-        'alloc-program ctx self (ctx.programs @ i) (deref offset)
-        offset += 1
-    'alloc-buffers ctx self (deref offset)
-    offset += (countof ctx.buffers) as u32
-
-    'translate self module ('rootid module)
-        on-enter = on-enter
-        on-leave = on-leave
-        on-enter-param = on-enter-param
-        on-leave-param = on-leave-param
-
-    'append ctx.setup-body ctx.setup-ctx
-    'append ctx.drop-body
-        ILFree ctx.drop-ctx
-
-    inline make-function (params body)
-        let ptr = ('alloc self TypeId.ILDo ((countof body) as u32))
-        ptr.scoped? = false
-        for i value in (enumerate body)
-            ptr.body @ i = value
-        let body = ('commit self)
-        ILTemplate params body
-
-    let fsetup = (make-function setup-params ctx.setup-body)
-    let fdrive = (make-function drive-params ctx.drive-body)
-    let fdrop = (make-function drop-params ctx.drop-body)
-    ILVA fsetup fdrive fdrop
-
-################################################################################
-
-spice setoption-impl (member value)
-    let TT = ('typeof member)
-    let ST = ('typeof value)
-    spice-quote
-        member = value
-        ;
-
-################################################################################
-
-fn generate-IL (module)
-    using import glm
-    using import glsl
-    using import tukan.gl
-
-    struct Context
-        values : (Map AnyId Value)
-        ctx-size : usize
-        setup-ctx : Value
-        setup-body : Value
-        drive-ctx : Value
-        ins : Value
-        outs : Value
-        drive-body : Value
-        drop-ctx : Value
-        drop-body : Value
-
-        fn alloc-program (self main)
-            let PT = GL.Program
-            let UT = (mutable @GL.uint)
-            let T = (mutable @GL.Program)
-            inline gethandle (src offset)
-                bitcast (& (src @ offset)) T
-            inline gethandleT (src offset T)
-                bitcast (& (src @ offset)) T
-
-            let offset = (deref self.ctx-size)
-            self.ctx-size += (sizeof GL.uint)
-            sc_expression_append self.setup-body
-                spice-quote
-                    let ptr = (gethandle [(copy self.setup-ctx)] offset)
-                    let pg = (PT)
-                    call
-                        attach-shaders pg
-                            compute = main
-                            debug = true
-                    store pg ptr
-                    lose ptr
-            sc_expression_append self.drop-body
-                spice-quote
-                    let ptr = (@ (gethandle [(copy self.drop-ctx)] offset))
-                    __drop (view ptr)
-                    lose ptr
-            let ptr = `(@ (gethandleT [(copy self.drive-ctx)] offset UT))
-            sc_expression_append self.drive-body ptr
-            ptr
-
-        fn alloc-texture (self target)
-            let T = (mutable @GL.uint)
-            inline gethandle (src offset)
-                bitcast (& (src @ offset)) T
-
-            let offset = (deref self.ctx-size)
-            self.ctx-size += (sizeof GL.uint)
-            sc_expression_append self.setup-body
-                spice-quote
-                    let ptr = (gethandle [(copy self.setup-ctx)] offset)
-                    GL.CreateTextures target 1 ptr
-            let setup-ptr = `(load ptr)
-            sc_expression_append self.drop-body
-                spice-quote
-                    let ptr = (gethandle [(copy self.drop-ctx)] offset)
-                    GL.DeleteTextures 1 ptr
-            let drive-ptr = `(load (gethandle [(copy self.drive-ctx)] offset))
-            sc_expression_append self.drive-body drive-ptr
-            _ setup-ptr drive-ptr
-
-        fn alloc-buffer (self)
-            let T = (mutable @GL.uint)
-            inline gethandle (src offset)
-                bitcast (& (src @ offset)) T
-
-            let offset = (deref self.ctx-size)
-            self.ctx-size += (sizeof GL.uint)
-            sc_expression_append self.setup-body
-                spice-quote
-                    let ptr = (gethandle [(copy self.setup-ctx)] offset)
-                    GL.CreateBuffers 1 ptr
-            let setup-ptr = `(load ptr)
-            sc_expression_append self.drop-body
-                spice-quote
-                    let ptr = (gethandle [(copy self.drop-ctx)] offset)
-                    GL.DeleteBuffers 1 ptr
-            let drive-ptr = `(load (gethandle [(copy self.drive-ctx)] offset))
-            sc_expression_append self.drive-body drive-ptr
-            _ setup-ptr drive-ptr
-
-    #fn visit-join-const-clause (module id)
-        local values : (Array Value)
-        fn join (module id values)
-            returning void
-            raising Error
-            let recur = this-function
-            expr := (module.exprs @ id)
-            let op a1 a2 a3 = (unpack expr)
-            op := op as Op
-            switch op
-            case Op.CONST32
-                'append values
-                    sc_const_int_new u32 a1
-            case Op.CONST64
-                'append values
-                    sc_const_int_new u32 a1
-                'append values
-                    sc_const_int_new u32 a2
-            case Op.JOIN
-                recur module a1 values
-                recur module a2 values
-            default
-                error
-                    .. (repr op) " operation not permitted in a JOIN clause"
-            ;
-        join module id values
-        let sz = ((countof values) as u32)
-        let T = (sc_vector_type u32 sz)
-        sc_const_aggregate_new T (sz as i32) (& (values @ 0))
-
-    fn syskey->flag (key)
-        switch key
-        case SystemKey.Setup InputFlags.Setup
-        case SystemKey.ScreenSize InputFlags.ScreenSize
-        case SystemKey.Iteration InputFlags.Iteration
-        case SystemKey.IState InputFlags.State
-        case SystemKey.Break InputFlags.Break
-        case SystemKey.Close InputFlags.Close
-        case SystemKey.Readline InputFlags.Readline
-        case SystemKey.SampleRate InputFlags.SampleRate
-        case SystemKey.SampleCount InputFlags.SampleCount
-        default
-            error
-                .. "unsupported input key: " (repr key)
-
-    fn read-input (module ctx key)
-        let ins = (copy ctx.ins)
-        let flag = (syskey->flag key)
-        inline readfield (fieldname)
-            spice-quote
-                assert ((ins.flags & flag) == flag)
-                copy (getattr ins fieldname)
-        switch key
-        pass SystemKey.Setup InputFlags.Setup
-        pass SystemKey.Break InputFlags.Break
-        pass SystemKey.Close InputFlags.Close
-        do `1:u32
-        case SystemKey.ScreenSize
-            readfield 'screen-size
-        case SystemKey.Iteration
-            readfield 'iteration
-        case SystemKey.IState
-            readfield 'state
-        case SystemKey.Readline
-            readfield 'readline
-        case SystemKey.SampleRate
-            readfield 'samplerate
-        case SystemKey.SampleCount
-            readfield 'samplecount
-        default
-            error
-                .. "unsupported input key: " (repr key)
-
-    fn write-output (module ctx key value)
-        let outs = (copy ctx.outs)
-        let body = ctx.drive-body
-        #dump module body key value
-        key as:= SystemKey
-
-        inline writefield (flagsym fieldname)
-            let flag = (getattr OutputFlags flagsym)
-            sc_expression_append body `(outs.flags |= flag)
-            sc_expression_append body
-                `(setoption-impl (getattr outs fieldname) value)
-        switch key
-        # u32[?]
-        case SystemKey.OState
-            writefield 'State 'state
-        # zterm u32[?]
-        case SystemKey.Stdout
-            writefield 'Stdout 'stdout
-        # u32[0]
-        case SystemKey.BlockBreak
-            writefield 'BlockBreak
-        # u32[0]
-        case SystemKey.BlockClose
-            writefield 'BlockClose
-        # f32[width * height * 4]
-        case SystemKey.Screen
-            writefield 'Screen 'screen
-        # zterm u32[?]
-        case SystemKey.Title
-            writefield 'Title 'title
-        # u32[4 * ?]
-        #case SystemKey.Program
-            writefield 'Program 'program
-        # zterm u32[?]
-        case SystemKey.Prompt
-            writefield 'Prompt 'prompt
-        # i32
-        case SystemKey.Exit
-            writefield 'Exit 'exit
-        # f32[samplecount * 2]
-        case SystemKey.Sound
-            writefield 'Sound 'sound
-        default
-            error
-                .. "unsupported output key: " (repr key)
-
-    fn... imagedim->symbol (fmt : ImageDim)
-        switch fmt
-        case ImageDim.1D '1D
-        case ImageDim.2D '2D
-        case ImageDim.3D '3D
-        case ImageDim.Cube 'Cube
-        case ImageDim.Rect 'Rect
-        case ImageDim.Buffer 'Buffer
-        default
-            error
-                .. "unsupported image dimensionality: " (repr fmt)
-
-    fn... imageformat->symbol (fmt : ImageFormat)
-        switch fmt
-        case ImageFormat.RGBA8UNORM 'Rgba8
-        default
-            error
-                .. "unsupported image format: " (repr fmt)
-
-    fn... imageformat->GL (fmt : ImageFormat)
-        # https://www.khronos.org/registry/OpenGL-Refpages/gl4/html/glBindImageTexture.xhtml
-        switch fmt
-        case ImageFormat.RGBA8UNORM GL.RGBA8
-        default
-            error
-                .. "unsupported image format: " (repr fmt)
-
-    inline simplequote (x) `x
-
-    fn genbufstorage (module id ctx)
-        # BUFSTORAGE size
-        from (methodsof module) let opof argsof iterexprlist
-        let rtype = ('typeof module id)
-        let a1 = ((argsof id 0) * (sizeof u32))
-        let setup-ptr drive-ptr = ('alloc-buffer ctx)
-        from GL let NamedBufferStorage
-        let flags = 0:u32
-            #| GL.DYNAMIC_STORAGE_BIT
-                GL.MAP_READ_BIT
-                GL.MAP_WRITE_BIT
-                GL.MAP_PERSISTENT_BIT
-                GL.MAP_COHERENT_BIT
-        sc_expression_append ctx.setup-body
-            `(NamedBufferStorage setup-ptr a1 null flags)
-        drive-ptr
-
-    fn gentexstorage (module imgstorage ctx)
-        from imgstorage let x y z levels samples
-        let rtype = imgstorage.type
-
-        let dim format arrayed? ms? =
-            dispatch ('handleof module rtype)
-            case image (self)
-                from self let dim format array? ms?
-            default
-                error "image type expected"
-        let fmt = (imageformat->GL format)
-        let target =
-            switch dim
-            case ImageDim.1D
-                if arrayed?
-                    GL.TEXTURE_1D_ARRAY
-                else
-                    GL.TEXTURE_1D
-            case ImageDim.2D
-                if arrayed?
-                    if ms?
-                        GL.TEXTURE_2D_MULTISAMPLE_ARRAY
-                    else
-                        GL.TEXTURE_2D_ARRAY
-                elseif ms?
-                    GL.TEXTURE_2D_MULTISAMPLE
-                else
-                    GL.TEXTURE_2D
-            case ImageDim.3D
-                GL.TEXTURE_3D
-            case ImageDim.Cube
-                if arrayed?
-                    GL.TEXTURE_CUBE_MAP_ARRAY
-                else
-                    GL.TEXTURE_CUBE_MAP
-            case ImageDim.Rect
-                GL.TEXTURE_RECTANGLE
-            #case ImageDim.Buffer
-                GL.TEXTURE_BUFFER
-            default
-                error "unsupported image dimensionality"
-        let fixedsamplelocations = GL.TRUE
-        let setup-ptr drive-ptr = ('alloc-texture ctx target)
-        from GL let TextureStorage1D TextureStorage2D TextureStorage3D \
-            TextureStorage2DMultisample TextureStorage3DMultisample
-        sc_expression_append ctx.setup-body
-            switch target
-            case GL.TEXTURE_1D
-                `(TextureStorage1D setup-ptr levels fmt x)
-            pass GL.TEXTURE_1D_ARRAY
-            pass GL.TEXTURE_2D
-            pass GL.TEXTURE_RECTANGLE
-            pass GL.TEXTURE_CUBE_MAP
-            do
-                `(TextureStorage2D setup-ptr levels fmt x y)
-            pass GL.TEXTURE_2D_ARRAY
-            pass GL.TEXTURE_3D
-            pass GL.TEXTURE_CUBE_MAP_ARRAY
-            do
-                `(TextureStorage3D setup-ptr levels fmt x y z)
-            case GL.TEXTURE_2D_MULTISAMPLE_ARRAY
-                `(TextureStorage3DMultisample setup-ptr samples fmt x y z fixedsamplelocations)
-            case GL.TEXTURE_2D_MULTISAMPLE
-                `(TextureStorage2DMultisample setup-ptr samples fmt x y fixedsamplelocations)
-            #case GL.TEXTURE_BUFFER
-                TextureBuffer
-            default
-                unreachable;
-        drive-ptr
-
-    fn visit (module id ctx)
-        if ('in? ctx.values id)
-            return;
-        # prevent cyclic references
-        'set ctx.values id `none
-        inline get (id...)
-            va-map
-                inline (id)
-                    try (copy ('get ctx.values id))
-                    else
-                        error "could not resolve cached value"
-                        #trap;
-                id...
-        inline vecop1 (self op)
-            `(op [(get self.value)])
-        inline castvecop1 (self op T)
-            `(op [(get self.value)] T)
-        inline vecop2 (self op)
-            `(op [(get self.lhs)] [(get self.rhs)])
-        inline veccmpop2 (self op)
-            `(op [(get self.lhs)] [(get self.rhs)])
-        let handle = ('handleof module id)
-        let vacount = ('vacount handle)
-        vvv bind value
-        dispatch handle
-        case uconst (self) `[self.value]
-        case fconst (self) `[self.value]
-        case add (self) (vecop2 self add)
-        case sub (self) (vecop2 self sub)
-        case mul (self) (vecop2 self mul)
-        case udiv (self) (vecop2 self udiv)
-        case sdiv (self) (vecop2 self sdiv)
-        case urem (self) (vecop2 self urem)
-        case srem (self) (vecop2 self srem)
-
-        case shl (self) (vecop2 self shl)
-        case ushr (self) (vecop2 self lshr)
-        case sshr (self) (vecop2 self ashr)
-        case and (self) (vecop2 self band)
-        case or (self) (vecop2 self bor)
-        case xor (self) (vecop2 self bxor)
-
-        case findmsb (self) (vecop1 self findmsb)
-        case findlsb (self) (vecop1 self findlsb)
-        case bitcount (self) (vecop1 self bitcount)
-
-        case eq (self) (veccmpop2 self icmp==)
-        case ne (self) (veccmpop2 self icmp!=)
-        case ugt (self) (veccmpop2 self icmp>u)
-        case uge (self) (veccmpop2 self icmp>=u)
-        case ult (self) (veccmpop2 self icmp<u)
-        case ule (self) (veccmpop2 self icmp<=u)
-        case sgt (self) (veccmpop2 self icmp>s)
-        case sge (self) (veccmpop2 self icmp>=s)
-        case slt (self) (veccmpop2 self icmp<s)
-        case sle (self) (veccmpop2 self icmp<=s)
-
-        case fadd (self) (vecop2 self fadd)
-        case fsub (self) (vecop2 self fsub)
-        case fmul (self) (vecop2 self fmul)
-        case fdiv (self) (vecop2 self fdiv)
-        case frem (self) (vecop2 self frem)
-        case fneg (self) (vecop1 self fneg)
-
-        case sqrt (self) (vecop1 self sqrt)
-        case sin (self) (vecop1 self sin)
-        case cos (self) (vecop1 self cos)
-
-        case foeq (self) (veccmpop2 self fcmp==o)
-        case fone (self) (veccmpop2 self fcmp!=o)
-        case fogt (self) (veccmpop2 self fcmp>o)
-        case foge (self) (veccmpop2 self fcmp>=o)
-        case folt (self) (veccmpop2 self fcmp<o)
-        case fole (self) (veccmpop2 self fcmp<=o)
-
-        case fueq (self) (veccmpop2 self fcmp==u)
-        case fune (self) (veccmpop2 self fcmp!=u)
-        case fugt (self) (veccmpop2 self fcmp>u)
-        case fuge (self) (veccmpop2 self fcmp>=u)
-        case fult (self) (veccmpop2 self fcmp<u)
-        case fule (self) (veccmpop2 self fcmp<=u)
-
-        case fo (self) (veccmpop2 self fcmp-ord)
-        case fu (self) (veccmpop2 self fcmp-uno)
-
-        case utof (self) (castvecop1 self uitofp f32)
-        case stof (self) (castvecop1 self sitofp f32)
-        case ftou (self) (castvecop1 self fptoui u32)
-        case ftos (self) (castvecop1 self fptosi u32)
-
-        case comp (self)
-            `([(get self.value)] @ [self.index])
-        case fvec2 (self)
-            `(vec2 [(get self.x)] [(get self.y)])
-        case fvec3 (self)
-            `(vec3 [(get self.x)] [(get self.y)] [(get self.z)])
-        case fvec4 (self)
-            `(vec4 [(get self.x)] [(get self.y)] [(get self.z)] [(get self.w)])
-        case uvec2 (self)
-            `(uvec2 [(get self.x)] [(get self.y)])
-        case uvec3 (self)
-            `(uvec3 [(get self.x)] [(get self.y)] [(get self.z)])
-        case uvec4 (self)
-            `(uvec4 [(get self.x)] [(get self.y)] [(get self.z)] [(get self.w)])
-        case fvec (self)
-            switch self.count
-            case 1 `f32
-            case 2 `vec2
-            case 3 `vec3
-            case 4 `vec4
-            default
-                error "unsupported vector size"
-        case uvec (self)
-            switch self.count
-            case 1 `u32
-            case 2 `uvec2
-            case 3 `uvec3
-            case 4 `uvec4
-            default
-                error "unsupported vector size"
-        case globalid (self)
-            `(deref gl_GlobalInvocationID)
-        case load (self)
-            `(load [(get self.pointer)])
-        case getelementptr (self)
-            let call = (sc_call_new `getelementptr)
-            sc_call_append_argument call (get self.value)
-            let indices = self.indices
-            for i in (range vacount)
-                sc_call_append_argument call (get (indices @ i))
-            call
-        case image (self)
-            let arrayed? = (self.array? as i32)
-            let multisampled? = (self.ms? as i32)
-            let T =
-                switch ('format self.format)
-                case ImageFormat.UNORM vec4
-                case ImageFormat.SNORM vec4
-                case ImageFormat.U uvec4
-                case ImageFormat.S ivec4
-                case ImageFormat.F vec4
-                default
-                    error "unknown component format"
-            let dim = (imagedim->symbol self.dim)
-            let format = (imageformat->symbol self.format)
-            `[(sc_image_type T dim 0 arrayed? multisampled? 2 format unnamed)]
-        case bindings (self) `none
-        case imagestorage (self) `none
-        case uniform (self)
-            let T = ((get self.type) as type)
-            let flags = 0
-            let glob = (sc_global_new 'u T flags 'UniformConstant)
-            sc_global_set_location glob (self.location as i32)
-            `glob
-        case wimage (self)
-            let T = ((get self.type) as type)
-            let flags =
-                |
-                    global-flag-coherent
-                    global-flag-restrict
-                    global-flag-non-readable
-            let glob = (sc_global_new 'wimg T flags 'UniformConstant)
-            sc_global_set_binding glob (self.binding as i32)
-            `glob
-        #case wssbo (self)
-            # SSBOATTR key target? : type
-            let T = ((translate rtype) as type)
-            let T = (tuple.type (array.type T -1))
-            let flags =
-                |
-                    global-flag-buffer-block
-                    global-flag-coherent
-                    global-flag-restrict
-                    if (a2 == 0:u32) global-flag-non-writable
-                    else global-flag-non-readable
-            let glob = (sc_global_new 'ssboattr T flags 'Uniform)
-            a1 as:= i32
-            sc_global_set_binding glob a1
-            `glob
-        case imagewrite (self)
-            `(Image-write [(get self.target)] [(get self.offset)] [(get self.element)])
-        #case Op.WRITE
-            # IMAGEWRITE attr index value : imagetype
-            let a1 a2 a3 = (translate a1 a2 a3)
-            `(write-impl a1 a2 a3)
-        case computefn (self)
-            from self let x y z body
-            let body = (get body)
-
-            spice-quote
-                fn main ()
-                    local_size x y z
-                    body
-                    return;
-            'alloc-program ctx main
-        case dispatch (self)
-            let pg = (get self.func)
-            let x y z = (get self.x self.y self.z)
-            let sources sinks = self.sources self.sinks
-
-            from GL let DispatchCompute DispatchComputeIndirect
-                \ BindBuffer DISPATCH_INDIRECT_BUFFER UseProgram
-
-            let dispatchcmd =
-                `(DispatchCompute x y z)
-                #spice-quote
-                    BindBuffer DISPATCH_INDIRECT_BUFFER source
-                    DispatchComputeIndirect 0
-
-            let body = (sc_expression_new)
-            sc_expression_append body `(UseProgram pg)
-
-            local retargs : (Array Value)
-
-            # bind values from function body instructions
-            do
-                let handle = ('handleof module sources)
-                let numsources = ('vacount handle)
-                let sources =
-                    dispatch handle
-                    case bindings (self) self.entries
-                    default
-                        error "sources must be bindings"
-                for i in (range numsources)
-                    let v k = (unpack (sources @ i))
-                    let khandle = ('handleof module k)
-                    dispatch khandle
-                    case uniform (self)
-                        let k = (get k)
-                        let v = (get v)
-                        let loc = (sc_global_location k)
-                        if (loc >= 0)
-                            sc_expression_append body `(GL.Uniform (ptrtoref k) v)
-                        else
-                            error "uniformattr has no binding"
-                    #case Op.SSBOATTR
-                        let b = (sc_global_binding k)
-                        assert (b >= 0)
-                        from GL let BindBufferBase SHADER_STORAGE_BUFFER
-                        sc_expression_append body
-                            spice-quote
-                                BindBufferBase SHADER_STORAGE_BUFFER b v
-                    default
-                        error
-                            .. "invalid binding type: " (string khandle.typeid.name)
-            do
-                let handle = ('handleof module sinks)
-                let numsinks = ('vacount handle)
-                let sinks =
-                    dispatch handle
-                    case bindings (self) self.entries
-                    default
-                        error "sources must be bindings"
-                for i in (range numsinks)
-                    let v k = (unpack (sinks @ i))
-                    let khandle = ('handleof module k)
-                    dispatch khandle
-                    case wimage (self)
-                        let vhandle = ('handleof module v)
-                        dispatch vhandle
-                        case imagestorage (self)
-                            let v = (gentexstorage module self ctx)
-                            #define-type "imagestorage"  (RIFF "IMST") (tuple (type = AnyId) (x = u32) (y = u32) (z = u32) (levels = u32) (samples = u32))
-                            'append retargs v
-                            let imgfmt =
-                                dispatch ('handleof module self.type)
-                                case image (self)
-                                    imageformat->GL self.format
-                                default
-                                    error "invalid type for image"
-                            let b = (sc_global_binding (get k))
-                            assert (b >= 0)
-                            from GL let FALSE WRITE_ONLY BindImageTexture
-                            sc_expression_append body
-                                spice-quote
-                                    BindImageTexture b v
-                                        0 # level
-                                        FALSE # layered
-                                        0 # layer
-                                        WRITE_ONLY # access
-                                        imgfmt
-                        default
-                            error
-                                .. "invalid binding source for image: " (string vhandle.typeid.name)
-                    default
-                        error
-                            .. "invalid binding type: " (string khandle.typeid.name)
-                    #
-                        v as:= Id
-                        assert ((opof v) == Op.BUFSTORAGE)
-                        let v = (genbufstorage module v ctx)
-                        'append retargs v
-                        let b = (sc_global_binding k)
-                        assert (b >= 0)
-                        from GL let BindBufferBase SHADER_STORAGE_BUFFER
-                        sc_expression_append body
-                            spice-quote
-                                BindBufferBase SHADER_STORAGE_BUFFER b v
-
-            sc_expression_append body dispatchcmd
-            sc_expression_append body `(UseProgram 0)
-            sc_expression_append ctx.drive-body body
-            sc_argument_list_new ((countof retargs) as i32) (& (retargs @ 0))
-        case input (self)
-            read-input module ctx self.source
-        case output (self)
-            write-output module ctx self.sink (get self.value)
-            `()
-        case outputs (self) `()
-        default
-            error "unhandled node type"
-        'set ctx.values id value
-        ;
-
-    let setup-fn = (sc_template_new 'setup)
-
-    let alloc-ctx = (sc_template_new 'alloc-ctx)
-    sc_template_set_inline alloc-ctx
-    let setup-body = (sc_expression_new)
-    sc_expression_append setup-body `(raising Error)
-    let setup-ctx = (sc_call_new alloc-ctx)
-    sc_expression_append setup-body setup-ctx
-
-    let drive-ctx = (sc_parameter_new 'ctx)
-    let drive-ins = (sc_parameter_new 'ins)
-    let drive-outs = (sc_parameter_new 'outs)
-    let drive-fn = (sc_template_new 'drive)
-    sc_template_append_parameter drive-fn drive-ctx
-    sc_template_append_parameter drive-fn drive-ins
-    sc_template_append_parameter drive-fn drive-outs
-
-    let drop-ctx = (sc_parameter_new 'ctx)
-    let drop-fn = (sc_template_new 'drop)
-    sc_template_append_parameter drop-fn drop-ctx
-
-    let drive-body = (sc_expression_new)
-    let drop-body = (sc_expression_new)
-
-    let drive-ctx = `(bitcast drive-ctx @u8)
-    sc_expression_append drive-body drive-ctx
-
-    let drop-ctx = `(bitcast drop-ctx @u8)
-    sc_expression_append drop-body drop-ctx
-
-    local ctx =
-        Context
-            ctx-size = 0
-            setup-ctx = setup-ctx
-            setup-body = setup-body
-            drive-ctx = drive-ctx
-            ins = drive-ins
-            outs = drive-outs
-            drive-body = drive-body
-            drop-ctx = drop-ctx
-            drop-body = drop-body
-
-    'descend module ('rootid module)
+    'translate module module ('rootid module)
         on-leave =
-            capture (module id) {&ctx}
-                try
-                    visit module id ctx
-                except (err)
-                    hide-traceback;
-                    error@+ err unknown-anchor
-                        .. "while compiling " ('repr module id)
-
-    sc_expression_append ctx.setup-body `(bitcast [(copy setup-ctx)] voidstar)
-    sc_expression_append ctx.drive-body `()
-    sc_expression_append ctx.drop-body `(free [(copy ctx.drop-ctx)])
-
-    sc_template_set_body alloc-ctx `(malloc-array u8 [(copy ctx.ctx-size)])
-
-    sc_template_set_body setup-fn ctx.setup-body
-    sc_template_set_body drive-fn ctx.drive-body
-    sc_template_set_body drop-fn ctx.drop-body
-
-    spice-quote
-        fn realize-functions ()
-            return
-                setup-fn as VMSetupFunctionType
-                drive-fn as VMDriveFunctionType
-                drop-fn as VMDropFunctionType
-    let RealizeType =
-        pointer
-            function
-                Arguments VMSetupFunctionType VMDriveFunctionType \
-                    VMDropFunctionType
-
-    let func = (sc_typify_template realize-functions 0 null)
-    let fptr = (sc_compile func 0)
-    fptr := fptr as RealizeType
-    (fptr)
+            capture (module handle oldmodule id) {&ctx}
+                'commit module handle
 
 ################################################################################
 
 # instantiate a module
 local module : FIR
 
-#do
-    from (methodsof module.builder) let ILGlobal ILSymbol ILFunctionType
-        \ ILArgumentsType ILNoReturnType ILStringType ILSymbol ILTemplate ILParams
-        \ ILCall ILString ILDo ILIf ILConstInt ILInteger ILVAGet ILVA ILEmbed
-        \ ILValue ILXValue
-
-    let sc_write =
-        #ILXValue `sc_write
-        ILValue sc_write
-    ILTemplate
-        let params = (ILParams 0 1)
-        ILEmbed
-            ILIf
-                let param0 = (ILVAGet 0 params)
-                ILCall sc_write (ILString "hello world\n")
-                ILCall sc_write (ILString "hello me\n")
-            ILVA param0 param0
-
-do
+inline gen-level1-test ()
     let _uvec3 = uvec3
     from (methodsof module.builder) let input uniform uvec wimage dispatch
         \ bindings computefn imagestorage imagewrite globalid load fdiv

          
@@ 2055,7 191,7 @@ do
 
     let ss = (uniform (uvec 2) 0)
     let u_it = (uniform (uvec 1) 1)
-    let imgtype = (image ImageDim.2D ImageFormat.RGBA8UNORM false false)
+    let imgtype = (image ImageDim.2D ImageFormat.RGBA8UNORM ImageFlags.none)
     let img = (wimage imgtype 1)
     let func =
         computefn 8 8 1

          
@@ 2092,68 228,51 @@ do
                         imagestorage imgtype 4096 4096 1 1 0
                         img
 
-#do
+inline gen-level2-test ()
     from (methodsof module.builder) let uvec fvec2 fvec3 fvec4 input output uconst
         \ fconst range comp and xor utof sin cos fadd fmul fdiv sample
-        \ nativefn symbol outputs
+        \ nativefn symbol outputs sub
+
+    let inpss = (input SystemKey.ScreenSize)
+    let inpit = (input SystemKey.Iteration)
 
-        outputs
-            output SystemKey.Screen
-                do
-                    # frame time
-                    let it = (fdiv (utof inpit) (fconst 60.0))
-                    # screen size
-                    let w h =
-                        comp 0 inpss
-                        comp 1 inpss
-                    let pos = (range w h (uconst 1))
-                    let x y =
-                        comp 0 pos
-                        comp 1 pos
-                    let u = (fdiv (utof x) (utof w))
-                    let v = (fdiv (utof y) (utof h))
-                    #let q = (sample checkers_texture (fvec2 u v))
-                    let q = (fconst 1.0)
-                    let u = (fmul q u)
-                    let v = (fmul q v)
-                    let z = (fmul q (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5)))
-                    fvec4 u v z (fconst 1)
+    let TS = (uconst 32)
+    #let checkers_texture =
+        do
+            let pos = (range TS TS (uconst 1))
+            let x y =
+                comp 0 pos
+                comp 1 pos
+            utof (xor (and x (uconst 1)) (and y (uconst 1)))
 
-    do
-        let inpss = (input SystemKey.ScreenSize)
-        let inpit = (input SystemKey.Iteration)
-
-        let TS = (uconst 32)
-        #let checkers_texture =
+    outputs
+        output SystemKey.Screen
             do
-                let pos = (range TS TS (uconst 1))
+                # frame time
+                let it = (fdiv (utof inpit) (fconst 60.0))
+                # screen size
+                let w h =
+                    comp 0 inpss
+                    comp 1 inpss
+                let pos = (range w h (uconst 1))
                 let x y =
                     comp 0 pos
                     comp 1 pos
-                utof (xor (and x (uconst 1)) (and y (uconst 1)))
+                let u = (fdiv (utof x) (utof w))
+                let v = (fdiv (utof y) (utof h))
+                #let q = (sample checkers_texture (fvec2 u v))
+                let q = (fconst 1.0)
+                let u = (fmul q u)
+                let v = (fmul q v)
+                let z = (fmul q (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5)))
+                fvec4 u v z (fconst 1)
 
-        outputs
-            output SystemKey.Screen
-                do
-                    # frame time
-                    let it = (fdiv (utof inpit) (fconst 60.0))
-                    # screen size
-                    let w h =
-                        comp 0 inpss
-                        comp 1 inpss
-                    let pos = (range w h (uconst 1))
-                    let x y =
-                        comp 0 pos
-                        comp 1 pos
-                    let u = (fdiv (utof x) (utof w))
-                    let v = (fdiv (utof y) (utof h))
-                    #let q = (sample checkers_texture (fvec2 u v))
-                    let q = (fconst 1.0)
-                    let u = (fmul q u)
-                    let v = (fmul q v)
-                    let z = (fmul q (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5)))
-                    fvec4 u v z (fconst 1)
-
+# lower range based expressions to compute functions and dispatches
+inline lower ()
+    do
+        local newmodule : FIR
+        let newid = (lower-FIR newmodule module)
+        module = newmodule
 # perform an identity transform and swap out the new module
     all transformations are immutable.
 inline cleanup ()

          
@@ 2161,15 280,25 @@ inline cleanup ()
         local newmodule : FIR
         let newid = ('translate newmodule module ('rootid module))
         module = newmodule
+inline run ()
+    do
+        let fsetup fdrive fdrop = ('gen-templates module)
+
+        local opts : VMOptions
+        runvm fsetup fdrive fdrop opts
+inline graphviz ()
+    do
+        'showdot module ('rootid module)
+            module-dir .. "/tukdag"
+
+gen-level1-test;
+#do
+    gen-level2-test;
+    lower;
+print;
 cleanup;
 'dump module
-#'showdot module ('rootid module)
-    module-dir .. "/tukdag"
-do
-    let fsetup fdrive fdrop = (generate-IL module)
-
-    local opts : VMOptions
-    runvm fsetup fdrive fdrop opts
+run;
 
 drop module
 unlet module