b4b030ee3a2a — Leonard Ritter a month ago
support for `clear`
3 files changed, 585 insertions(+), 410 deletions(-)

M lib/tukan/CADAG/init.sc
M lib/tukan/FIR.sc
M testing/tukdag.sc
M lib/tukan/CADAG/init.sc +16 -13
@@ 477,7 477,8 @@ type CADAG < Struct
                 let code =
                     try (copy ('get self.name->typeid-map name))
                     else
-                        error
+                        error@ ('anchor arg)
+                            "while generating dispatcher"
                             .. "cannot dispatch unbound type name: " name
                 let T =
                     try (deref (('get self.typeid->info-map code) . T))

          
@@ 913,7 914,7 @@ type+ CADAG
                 let nextid = (copy (self.words @ ofs))
                 if (not ('in? seen nextid))
                     'insert seen nextid
-                    if (on-enter (view self) nextid)
+                    if (on-enter (view self) (bitcast nextid cls.AnyId))
                         'push stack self nextid
 
     struct TransformStack

          
@@ 1177,20 1178,22 @@ type+ CADAG
         offset := (id as u32) + 2
         & (self.words @ offset)
 
-    fn... repr (self, id : u32, options...)
+    fn... repr
+    case (self, handle : Handle)
+        let cls = (typeof self)
+        let typeid sz ptr = (unpack handle)
+        ..
+            default-styler style-keyword
+                string typeid.name
+            'dispatch typeid
+                inline "#hidden" (code cls)
+                    T := ('typeinfo cls code) . T
+                    value-typeid-repr (@ (bitcast ptr @T)) sz
+    case (self, id : Id, options...)
         let assign? =
             va-option assign options... true
         let cls = (typeof self)
-        let typeid sz = ('headerof self id)
-        let ptr = ('load self id)
-        let body =
-            ..
-                default-styler style-keyword
-                    string typeid.name
-                'dispatch typeid
-                    inline "#hidden" (code cls)
-                        T := ('typeinfo cls code) . T
-                        value-typeid-repr (@ (bitcast ptr @T)) sz
+        let body = (this-function self ('handleof self id))
         if assign?
             ..
                 default-styler style-symbol

          
M lib/tukan/FIR.sc +525 -370
@@ 154,6 154,7 @@ let
     funccolor... = (_ (dot.fontcolor = "#81a2be") (dot.color = "#81a2be"))
     kwcolor... = (_ (dot.fontcolor = "#b294bb") (dot.color = "#b294bb"))
     instrcolor... = (_ (dot.fontcolor = "#de5f84") (dot.color = "#de5f84"))
+    mutinstrcolor... = (_ (dot.fontcolor = "#ff4040") (dot.color = "#ff4040"))
     commentcolor... = (_ (dot.fontcolor = "#969896") (dot.color = "#969896"))
 
 # FIR Level 2

          
@@ 187,9 188,13 @@ enum DepthTestType : u32
     LessThan
     LessEqual
 define-type "depthtest" (RIFF "ZTST") (tuple (depthfunc = DepthTestType) (value = AnyId) (default = AnyId))
+    stringcolor...
 define-type "overlay"  (RIFF "NOZT") (tuple (value = AnyId))
+    stringcolor...
 define-type "selectfragment" (RIFF "SLFR") (tuple (test = AnyId) (value = AnyId) (default = AnyId))
     stringcolor...
+define-type "clear" (RIFF "CLRI") (tuple (range = AnyId) (value = AnyId))
+    stringcolor...
 
 # FIR Level 1
 ################################################################################

          
@@ 220,14 225,16 @@ define-type "getelementptr" (RIFF "GELP"
 define-type "globalid"      (RIFF "GLID") (tuple)
     funccolor...
 define-type "imagewrite"    (RIFF "IMGW") (tuple (element = AnyId) (offset = AnyId) (target = AnyId))
-    instrcolor...
+    mutinstrcolor...
 define-type "computefn"     (RIFF "CMFN") (tuple (x = u32) (y = u32) (z = u32) (body = AnyId))
     funccolor...
 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))
-    funccolor...
+    typecolor...
+define-type "undef"         (RIFF "UNDF") (tuple (type = AnyId))
+    instrcolor...
 define-type "dispatch"      (RIFF "DISP") (tuple (func = AnyId) (x = AnyId) (y = AnyId) (z = AnyId) (sources = AnyId) (sinks = AnyId))
-    instrcolor...
+    mutinstrcolor...
 define-type "rimage"        (RIFF "RIMG") (tuple (type = AnyId) (binding = u32))
     funccolor...
 define-type "mimage"        (RIFF "MIMG") (tuple (type = AnyId) (binding = u32))

          
@@ 239,16 246,27 @@ define-type "wssbo"         (RIFF "WSBO"
 define-type "mssbo"         (RIFF "MSBO") (tuple (type = AnyId) (binding = u32)) # mutable SSBO
     funccolor...
 define-type "store"         (RIFF "STOR") (tuple (value = AnyId) (pointer = AnyId))
-    instrcolor...
+    mutinstrcolor...
 define-type "bufferstorage" (RIFF "BFST") (tuple (size = u32))
     funccolor...
 define-type "idispatch"     (RIFF "IDSP") (tuple (func = AnyId) (size = AnyId) (sources = AnyId) (sinks = AnyId))
+    mutinstrcolor...
+define-type "clearimage"    (RIFF "CLRS")
+    tuple
+        value = AnyId
+        level = AnyId
+        xoffset = AnyId; yoffset = AnyId; zoffset = AnyId
+        width = AnyId; height = AnyId; depth = AnyId
+        target = AnyId
+    mutinstrcolor...
+define-type "copy"          (RIFF "COPY") (tuple (value = AnyId))
     instrcolor...
-define-type "clear"         (RIFF "CLRS") (tuple (value = AnyId) (storage = AnyId))
 define-type "vertexid"      (RIFF "VXID") (tuple)
     funccolor...
 define-type "instanceid"    (RIFF "ISID") (tuple)
     funccolor...
+define-type "primitiveid"   (RIFF "PRID") (tuple)
+    funccolor...
 define-type "rattr"         (RIFF "RATR") (tuple (type = AnyId) (location = u32) (kind = FragmentType))
     funccolor...
 define-type "wattr"         (RIFF "WATR") (tuple (type = AnyId) (location = u32))

          
@@ 269,7 287,7 @@ define-type "draw"          (RIFF "DRAI"
         instancecount : AnyId
         sources : AnyId
         sinks : AnyId
-    instrcolor...
+    mutinstrcolor...
 
 # FIR Level 0
 ################################################################################

          
@@ 280,6 298,8 @@ define-type "fvec"      (RIFF "FVEC") (t
     typecolor...
 define-type "uvec"      (RIFF "UVEC") (tuple (count = u32))
     typecolor...
+define-type "mrv"       (RIFF "VART") (tuple (types = (array AnyId)))
+    typecolor...
 define-type "fvec2"     (RIFF "FVC2") (tuple (x = AnyId) (y = AnyId))
     instrcolor...
 define-type "fvec3"     (RIFF "FVC3") (tuple (x = AnyId) (y = AnyId) (z = AnyId))

          
@@ 380,6 400,172 @@ define-op1 "cos"    "FCOS"
 
 ################################################################################
 
+struct FIRTyper
+    types : (Map AnyId AnyId)
+
+    fn setup (self module)
+        # insert common types early, so we don't interfere with late insertions
+        from (methodsof module.builder) let uvec fvec
+        uvec 1
+        uvec 2
+        uvec 3
+        uvec 4
+        fvec 1
+        fvec 2
+        fvec 3
+        fvec 4
+        ;
+
+    fn imagetypeof (self module id)
+        let tid = ('typeof self module id)
+        dispatch ('handleof module tid)
+        case image (self) self
+        case imagestorage (self)
+            dispatch ('handleof module self.type)
+            case image (self) self
+            default
+                error "image type expected"
+        default
+            error
+                .. "image or imagestorage type expected, but "
+                    'repr module id
+                    " has type "
+                    'repr module tid
+
+    fn... typeof (ctx, module : FIR, id : AnyId)
+        try
+            return (copy ('get ctx.types id))
+        else;
+
+        fn type-value (ctx module id)
+            from (methodsof module.builder) let uvec fvec
+            report "typing" ('repr module id)
+            inline get (id)
+                try (copy ('get ctx.types id))
+                else
+                    error
+                        .. "type missing for: " ('repr module id)
+
+            let handle = ('handleof module id)
+            vvv bind type
+            dispatch handle
+            case input (self)
+                switch self.source
+                case SystemKey.ScreenSize (uvec 2)
+                case SystemKey.Iteration (uvec 1)
+                default
+                    error
+                        .. "don't know how to type source: " (repr self.source)
+            case load (self)
+                get self.pointer
+            case sample (self)
+                get self.source
+            case clearimage (self)
+                get self.target
+            case dispatch (self)
+                let sinkhandle = ('handleof module self.sinks)
+                let vacount = ('vacount sinkhandle)
+                dispatch sinkhandle
+                case bindings (sinks)
+                    if (vacount == 1)
+                        let entries = sinks.entries
+                        get (entries @ 0 @ 0)
+                    else
+                        let mrv =
+                            'alloc module TypeId.typeid_mrv vacount
+                        let entries = sinks.entries
+                        let args = mrv.types
+                        for i in (range vacount)
+                            args @ i = (get (entries @ i @ 0))
+                        'commit module
+                default
+                    trap;
+            default
+                switch ('typeidof module id)
+                #case TypeId.typeid_range (uvec 3)
+                case TypeId.typeid_globalid (uvec 3)
+
+                pass TypeId.typeid_fconst
+                pass TypeId.typeid_utof
+                pass TypeId.typeid_fadd
+                pass TypeId.typeid_fmul
+                pass TypeId.typeid_fdiv
+                pass TypeId.typeid_sin
+                do (fvec 1)
+
+                pass TypeId.typeid_uconst
+                pass TypeId.typeid_add
+                pass TypeId.typeid_sub
+                pass TypeId.typeid_mul
+                pass TypeId.typeid_udiv
+                pass TypeId.typeid_sdiv
+                pass TypeId.typeid_and
+                pass TypeId.typeid_or
+                pass TypeId.typeid_xor
+                do (uvec 1)
+
+                pass TypeId.typeid_outputs
+                pass TypeId.typeid_output
+                pass TypeId.typeid_imagewrite
+                pass TypeId.typeid_computefn
+                pass TypeId.typeid_bindings
+                do NoId
+
+                case TypeId.typeid_uvec2 (uvec 2)
+                case TypeId.typeid_uvec3 (uvec 3)
+                case TypeId.typeid_uvec4 (uvec 4)
+                case TypeId.typeid_fvec2 (fvec 2)
+                case TypeId.typeid_fvec3 (fvec 3)
+                case TypeId.typeid_fvec4 (fvec 4)
+
+                # types have no type
+                pass TypeId.typeid_image
+                pass TypeId.typeid_sampler
+                pass TypeId.typeid_mrv
+                pass TypeId.typeid_fvec
+                pass TypeId.typeid_uvec
+                pass TypeId.typeid_imagestorage
+                do NoId
+
+                # first value is type
+                pass TypeId.typeid_undef
+                pass TypeId.typeid_wimage
+                pass TypeId.typeid_uniform
+                do
+                    for srcid in ('sources handle)
+                        if true
+                            break (copy srcid)
+                    else NoId
+
+                # type of first value
+                pass TypeId.typeid_comp
+                do
+                    for srcid in ('sources handle)
+                        if true
+                            break (get srcid)
+                    else NoId
+                default
+                    error "failed to deduce type"
+            report "typed to" type
+            'set ctx.types id type
+            ;
+
+        'descend module id
+            on-enter =
+                capture (module id) {&ctx}
+                    not ('in? ctx.types id)
+            on-leave =
+                capture on-leave (module id) {&ctx}
+                    try
+                        type-value ctx module id
+                    except (err)
+                        error@+ err unknown-anchor
+                            .. "while typing " ('repr module id)
+
+        return (copy ('getdefault ctx.types id NoId))
+
+################################################################################
+
 spice setoption-impl (member value)
     let TT = ('typeof member)
     let ST = ('typeof value)

          
@@ 389,6 575,21 @@ spice setoption-impl (member value)
 
 ################################################################################
 
+fn... getgluint (ctx : Value, offset : Value)
+    from GL let uint
+    spice-quote
+        assert ((typeof offset) == usize) # remove me later
+        bitcast (ptrtoref (getelementptr ctx offset)) uint
+
+fn... getglprogram (ctx : Value, offset : Value)
+    from GL let Program
+    spice-quote
+        assert ((typeof offset) == usize) # remove me later
+        bitcast (ptrtoref (getelementptr ctx offset)) Program
+
+static-assert ((sizeof GL.uint) == (sizeof u32))
+static-assert ((sizeof GL.Program) == (sizeof u32))
+
 fn generate-IL (module)
     using import glm
     using import glsl

          
@@ 405,158 606,95 @@ fn generate-IL (module)
         drive-body : Value
         drop-ctx : Value
         drop-body : Value
-        has-nop-vao? : bool = false
-        nop-vao : (tuple Value Value)
+        nop-vao : (Option Value)
+        typer : FIRTyper
 
         fn alloc-compute (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
+            from GL let Program
 
-            let offset = (deref self.ctx-size)
-            self.ctx-size += (sizeof GL.uint)
+            let offset = `[(deref self.ctx-size)]
+            self.ctx-size += 1
             sc_expression_append self.setup-body
                 spice-quote
-                    let ptr = (gethandle [(copy self.setup-ctx)] offset)
-                    let pg = (PT)
+                    let ptr = [(getglprogram self.setup-ctx offset)]
+                    let pg = (Program)
                     call
                         attach-shaders pg
                             compute = main
                             debug = true
-                    store pg ptr
+                    assign pg ptr
                     lose ptr
             sc_expression_append self.drop-body
                 spice-quote
-                    let ptr = (@ (gethandle [(copy self.drop-ctx)] offset))
+                    let ptr = [(getglprogram 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
+            offset
 
         fn alloc-shader (self vertex-main fragment-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
+            from GL let Program
 
-            let offset = (deref self.ctx-size)
-            self.ctx-size += (sizeof GL.uint)
+            let offset = `[(deref self.ctx-size)]
+            self.ctx-size += 1
             sc_expression_append self.setup-body
                 spice-quote
-                    let ptr = (gethandle [(copy self.setup-ctx)] offset)
-                    let pg = (PT)
+                    let ptr = [(getglprogram self.setup-ctx offset)]
+                    let pg = (Program)
                     call
                         attach-shaders pg
                             vertex = vertex-main
                             fragment = fragment-main
                             debug = true
-                    store pg ptr
+                    assign pg ptr
                     lose ptr
             sc_expression_append self.drop-body
                 spice-quote
-                    let ptr = (@ (gethandle [(copy self.drop-ctx)] offset))
+                    let ptr = [(getglprogram 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
+            offset
 
-        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)
+        inline alloc-glresource (self glcreate gldelete)
+            let offset = `[(deref self.ctx-size)]
+            self.ctx-size += 1
             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)
+                    let ptr = [(getgluint self.setup-ctx offset)]
+                    glcreate 1 &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
+                    let ptr = [(getgluint self.drop-ctx offset)]
+                    gldelete 1 &ptr
+            offset
+
+        fn alloc-texture (self target)
+            from GL let CreateTextures DeleteTextures
+            let offset = `[(deref self.ctx-size)]
+            self.ctx-size += 1
+            sc_expression_append self.setup-body
+                spice-quote
+                    let ptr = [(getgluint self.setup-ctx offset)]
+                    CreateTextures target 1 &ptr
+            sc_expression_append self.drop-body
+                spice-quote
+                    let ptr = [(getgluint self.drop-ctx offset)]
+                    DeleteTextures 1 &ptr
+            offset
 
         fn alloc-framebuffer (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.CreateFramebuffers 1 ptr
-            let setup-ptr = `(load ptr)
-            sc_expression_append self.drop-body
-                spice-quote
-                    let ptr = (gethandle [(copy self.drop-ctx)] offset)
-                    GL.DeleteFramebuffers 1 ptr
-            let drive-ptr = `(load (gethandle [(copy self.drive-ctx)] offset))
-            sc_expression_append self.drive-body drive-ptr
-            _ setup-ptr drive-ptr
+            alloc-glresource self GL.CreateFramebuffers GL.DeleteFramebuffers
 
         fn get-nop-vao (self)
-            if (not self.has-nop-vao?)
-                self.has-nop-vao? = true
-                self.nop-vao = (tupleof ('alloc-vao self))
-            let a b = (unpack self.nop-vao)
-            return (copy a) (copy b)
+            try (copy ('unwrap self.nop-vao))
+            else
+                self.nop-vao = ('alloc-vao self)
+                copy ('force-unwrap self.nop-vao)
 
         fn alloc-vao (self)
-            let T = (mutable @GL.uint)
-            inline gethandle (src offset)
-                bitcast (& (src @ offset)) T
-
-            from GL let CreateVertexArrays DeleteVertexArrays
-
-            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)
-                    CreateVertexArrays 1 ptr
-            let setup-ptr = `(load ptr)
-            sc_expression_append self.drop-body
-                spice-quote
-                    let ptr = (gethandle [(copy self.drop-ctx)] offset)
-                    DeleteVertexArrays 1 ptr
-            let drive-ptr = `(load (gethandle [(copy self.drive-ctx)] offset))
-            sc_expression_append self.drive-body drive-ptr
-            _ setup-ptr drive-ptr
+            alloc-glresource self GL.CreateVertexArrays GL.DeleteVertexArrays
 
         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
+            alloc-glresource self GL.CreateBuffers GL.DeleteBuffers
 
     #fn visit-join-const-clause (module id)
         local values : (Array Value)

          
@@ 637,18 775,19 @@ fn generate-IL (module)
         #dump module body key value
         key as:= SystemKey
 
-        inline writefield (flagsym fieldname)
+        inline writefield (flagsym fieldname value)
             let flag = (getattr OutputFlags flagsym)
             sc_expression_append body `(outs.flags |= flag)
-            sc_expression_append body
-                `(setoption-impl (getattr outs fieldname) value)
+            static-if (not (none? fieldname))
+                sc_expression_append body
+                    `(setoption-impl (getattr outs fieldname) value)
         switch key
         # u32[?]
         case SystemKey.OState
-            writefield 'State 'state
+            writefield 'State 'state value
         # zterm u32[?]
         case SystemKey.Stdout
-            writefield 'Stdout 'stdout
+            writefield 'Stdout 'stdout value
         # u32[0]
         case SystemKey.BlockBreak
             writefield 'BlockBreak

          
@@ 657,22 796,22 @@ fn generate-IL (module)
             writefield 'BlockClose
         # f32[width * height * 4]
         case SystemKey.Screen
-            writefield 'Screen 'screen
+            writefield 'Screen 'screen (getgluint ctx.drive-ctx value)
         # zterm u32[?]
         case SystemKey.Title
-            writefield 'Title 'title
+            writefield 'Title 'title value
         # u32[4 * ?]
         #case SystemKey.Program
             writefield 'Program 'program
         # zterm u32[?]
         case SystemKey.Prompt
-            writefield 'Prompt 'prompt
+            writefield 'Prompt 'prompt value
         # i32
         case SystemKey.Exit
-            writefield 'Exit 'exit
+            writefield 'Exit 'exit value
         # f32[samplecount * 2]
         case SystemKey.Sound
-            writefield 'Sound 'sound
+            writefield 'Sound 'sound value
         default
             error
                 .. "unsupported output key: " (repr key)

          
@@ 727,6 866,43 @@ fn generate-IL (module)
             error
                 .. "unsupported image format: " (repr fmt)
 
+    fn... imageformat->GL-format-type (fmt : ImageFormat)
+        # https://www.khronos.org/registry/OpenGL-Refpages/gl4/html/glTexImage3D.xhtml
+        let subfmt = ('format fmt)
+        switch subfmt
+        pass ImageFormat.UNORM
+        pass ImageFormat.SNORM
+        pass ImageFormat.F
+        do
+            _
+                switch ('components fmt)
+                case 1 GL.RED
+                case 2 GL.RG
+                case 3 GL.RGB
+                case 4 GL.RGBA
+                default
+                    trap;
+                GL.FLOAT
+        pass ImageFormat.U
+        pass ImageFormat.S
+        do
+            _
+                switch ('components fmt)
+                case 1 GL.RED_INTEGER
+                case 2 GL.RG_INTEGER
+                case 3 GL.RGB_INTEGER
+                case 4 GL.RGBA_INTEGER
+                default
+                    trap;
+                switch subfmt
+                case ImageFormat.U GL.UNSIGNED_INT
+                case ImageFormat.S GL.INT
+                default
+                    trap;
+        default
+            error
+                .. "unsupported image format: " (repr fmt)
+
     inline simplequote (x) `x
 
     fn genbufstorage (module id ctx)

          
@@ 734,7 910,8 @@ fn generate-IL (module)
         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)
+        let bufoffset = ('alloc-buffer ctx)
+        let setup-ptr = (getgluint ctx.setup-ctx bufoffset)
         from GL let NamedBufferStorage
         let flags = 0:u32
             #| GL.DYNAMIC_STORAGE_BIT

          
@@ 744,7 921,7 @@ fn generate-IL (module)
                 GL.MAP_COHERENT_BIT
         sc_expression_append ctx.setup-body
             `(NamedBufferStorage setup-ptr a1 null flags)
-        drive-ptr
+        bufoffset
 
     fn gentexstorage (module imgstorage ctx)
         from imgstorage let x y z levels samples

          
@@ 788,7 965,8 @@ fn generate-IL (module)
             default
                 error "unsupported image dimensionality"
         let fixedsamplelocations = GL.TRUE
-        let setup-ptr drive-ptr = ('alloc-texture ctx target)
+        let imgoffset = ('alloc-texture ctx target)
+        let setup-ptr = (getgluint ctx.setup-ctx imgoffset)
         from GL let TextureStorage1D TextureStorage2D TextureStorage3D \
             TextureStorage2DMultisample TextureStorage3DMultisample
         sc_expression_append ctx.setup-body

          
@@ 814,7 992,7 @@ fn generate-IL (module)
                 TextureBuffer
             default
                 unreachable;
-        _ drive-ptr setup-ptr
+        imgoffset
 
     fn assign-bindings (ctx module body retargs sources sinks)
         inline get (id...)

          
@@ 842,21 1020,23 @@ fn generate-IL (module)
                 dispatch khandle
                 case uniform (self)
                     let k = (get k)
-                    let v = (get v)
                     let loc = (sc_global_location k)
                     if (loc < 0)
                         error "uniformattr has no binding"
                     dispatch ('handleof module self.type)
                     case sampler (smpty)
-                        from GL let BindTextureUnit Uniform1i
+                        from GL let BindTextureUnit Uniform1i IsTexture
                         let tu = (deref next_texture_unit)
                         next_texture_unit += 1
+                        let voffset = (get v)
+                        let vptr = (getgluint ctx.drive-ctx voffset)
                         sc_expression_append body
                             spice-quote
-                                BindTextureUnit tu v
+                                BindTextureUnit tu vptr
                                 Uniform1i loc tu
                     default
                         from GL let Uniform
+                        let v = (get v)
                         sc_expression_append body `(Uniform (ptrtoref k) v)
                 #case Op.SSBOATTR
                     let b = (sc_global_binding k)

          
@@ 877,7 1057,7 @@ fn generate-IL (module)
                 default
                     error "sources must be bindings"
 
-            local fbo : (Option (tuple Value Value))
+            local fbo : (Option Value)
             local drawbuffers : (Array i32)
             local next_attachment_index = 0
 

          
@@ 886,71 1066,24 @@ fn generate-IL (module)
                 let khandle = ('handleof module k)
                 dispatch khandle
                 case wattr (self)
-                    let vhandle = ('handleof module v)
-                    let imgstor clearval =
-                        dispatch vhandle
-                        case imagestorage (self)
-                            _ self NoId
-                        case clear (self)
-                            let value = self.value
-                            let vhandle = ('handleof module self.storage)
-                            dispatch vhandle
-                            case imagestorage (self)
-                                _ self (copy value)
-                            default
-                                error
-                                    .. "invalid binding source for image: " (string vhandle.typeid.name)
-                        default
-                            error
-                                .. "invalid binding source for image: " (string vhandle.typeid.name)
-                    let imgtype =
-                        dispatch ('handleof module imgstor.type)
-                        case image (self) self
-                        default
-                            error "invalid type for image"
                     let loc = (sc_global_location (get k))
                     from GL let NamedFramebufferTexture BindFramebuffer
                         \ FRAMEBUFFER COLOR_ATTACHMENT0 ClearNamedFramebufferiv
                         \ ClearNamedFramebufferfv ClearNamedFramebufferuiv
                         \ COLOR
                     if (not fbo)
-                        let setup-ptr drive-ptr = ('alloc-framebuffer ctx)
+                        let fbo-offset = ('alloc-framebuffer ctx)
+                        let fboptr = (getgluint ctx.drive-ctx fbo-offset)
                         sc_expression_append body
                             spice-quote
-                                BindFramebuffer FRAMEBUFFER drive-ptr
-                        fbo = (tupleof setup-ptr drive-ptr)
+                                BindFramebuffer FRAMEBUFFER fboptr
+                        fbo = fbo-offset
                         ;
-                    let setup-ptr drive-ptr = ('force-unwrap fbo)
-                    if clearval
-                        report "clearval!"
-                        let value = (get clearval)
-                        let value =
-                            spice-quote
-                                local value = value
-                        switch ('format imgtype.format)
-                        case ImageFormat.U
-                            sc_expression_append body
-                                spice-quote
-                                    ClearNamedFramebufferuiv drive-ptr COLOR
-                                        \ loc (bitcast (& value) @u32)
-                        case ImageFormat.S
-                            sc_expression_append body
-                                spice-quote
-                                    ClearNamedFramebufferiv drive-ptr COLOR
-                                        \ loc (bitcast (& value) @i32)
-                        pass ImageFormat.UNORM
-                        pass ImageFormat.SNORM
-                        pass ImageFormat.F
-                        do
-                            sc_expression_append body
-                                spice-quote
-                                    ClearNamedFramebufferfv drive-ptr COLOR
-                                        \ loc (bitcast (& value) @f32)
-                        default
-                            error "unsupported clear format"
-
-                    let vptr svptr = (gentexstorage module imgstor ctx)
-                    'append retargs vptr
+                    let fbo-offset = ('force-unwrap fbo)
+                    let fbosetupptr = (getgluint ctx.setup-ctx fbo-offset)
+                    let imageoffset = (get v)
+                    let svptr = (getgluint ctx.setup-ctx imageoffset)
+                    'append retargs imageoffset
                     let attachment = (COLOR_ATTACHMENT0 + next_attachment_index)
                     next_attachment_index += 1
                     while ((countof drawbuffers) <= loc)

          
@@ 959,42 1092,32 @@ fn generate-IL (module)
                     drawbuffers @ loc = attachment
                     sc_expression_append ctx.setup-body
                         spice-quote
-                            NamedFramebufferTexture setup-ptr attachment svptr 0
-
-
+                            NamedFramebufferTexture fbosetupptr attachment svptr 0
                 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)
+                    let imgtype =
+                        'imagetypeof ctx.typer module v
+                    let imageoffset = (get v)
+                    let vptr = (getgluint ctx.drive-ctx imageoffset)
+                    'append retargs imageoffset
+                    let imgfmt = (imageformat->GL imgtype.format)
+                    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 vptr
+                                0 # level
+                                FALSE # layered
+                                0 # layer
+                                WRITE_ONLY # access
+                                imgfmt
                 default
                     error
                         .. "invalid binding type: " (string khandle.typeid.name)
 
             if fbo
-                let setup-ptr drive-ptr = ('force-unwrap fbo)
+                let fbo-offset = ('force-unwrap fbo)
+                let fbosetupptr = (getgluint ctx.setup-ctx fbo-offset)
                 from GL let NamedFramebufferDrawBuffers CheckNamedFramebufferStatus
                     \ FRAMEBUFFER FRAMEBUFFER_COMPLETE
                 let GLenum = GL.enum

          
@@ 1006,27 1129,15 @@ fn generate-IL (module)
                 sc_expression_append ctx.setup-body
                     spice-quote
                         NamedFramebufferDrawBuffers
-                            \ setup-ptr drawbuffercount buffertargets
+                            \ fbosetupptr drawbuffercount buffertargets
 
                 sc_expression_append ctx.setup-body
                     spice-quote
                         let status = (CheckNamedFramebufferStatus
-                            setup-ptr FRAMEBUFFER)
+                            fbosetupptr FRAMEBUFFER)
                         assert (status == FRAMEBUFFER_COMPLETE)
                             .. "Framebuffer incomplete: " (framebuffer-status status)
 
-                #
-                    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
-
     fn visit (module id ctx)
         if ('in? ctx.values id)
             return;

          
@@ 1040,6 1151,8 @@ fn generate-IL (module)
                         error "could not resolve cached value"
                         #trap;
                 id...
+        inline append-body (value)
+            sc_expression_append ctx.drive-body value
         inline vecop1 (self op)
             `(op [(get self.value)])
         inline castvecop1 (self op T)

          
@@ 1156,6 1269,8 @@ fn generate-IL (module)
             `((deref gl_VertexID) as u32)
         case instanceid (self)
             `((deref gl_InstanceID) as u32)
+        case primitiveid (self)
+            `((deref gl_PrimitiveID) as u32)
         case position (self)
             `(reftoptr gl_Position)
         case load (self)

          
@@ 1192,7 1307,32 @@ fn generate-IL (module)
                 (sc_image_type T dim 0 arrayed? multisampled? 1 'Unknown unnamed))]
         case bindings (self) `none
         case imagestorage (self) `none
-        case clear (self) `none
+        case undef (self)
+            dispatch ('handleof module self.type)
+            case imagestorage (self)
+                gentexstorage module self ctx
+            default
+                error "invalid type for undef"
+        case clearimage (self)
+            let imgoffset = (get self.target)
+            let imgptr = (getgluint ctx.drive-ctx imgoffset)
+            let imgtype = ('imagetypeof ctx.typer module self.target)
+            let glformat gltype = (imageformat->GL-format-type imgtype.format)
+            from GL let ClearTexSubImage
+            append-body
+                spice-quote
+                    local tmp = [(get self.value)]
+                    ClearTexSubImage imgptr
+                        [(get self.level)] as i32
+                        [(get self.xoffset)] as i32
+                        [(get self.yoffset)] as i32
+                        [(get self.zoffset)] as i32
+                        [(get self.width)] as i32
+                        [(get self.height)] as i32
+                        [(get self.depth)] as i32
+                        \ glformat gltype
+                        bitcast &tmp voidstar
+            imgoffset
         case uniform (self)
             let T = ((get self.type) as type)
             let flags = 0

          
@@ 1252,7 1392,6 @@ fn generate-IL (module)
         case computefn (self)
             from self let x y z body
             let body = (get body)
-
             spice-quote
                 fn main ()
                     local_size x y z

          
@@ 1273,7 1412,8 @@ fn generate-IL (module)
                     return;
             'alloc-shader ctx vertex-main fragment-main
         case draw (self)
-            let pg = (get self.func)
+            let pgoffset = (get self.func)
+            let pg = (getgluint ctx.drive-ctx pgoffset)
             let x y = (get self.x self.y)
             let count instancecount = (get self.count self.instancecount)
             let sources sinks = self.sources self.sinks

          
@@ 1299,7 1439,8 @@ fn generate-IL (module)
             let body = (sc_expression_new)
             sc_expression_append body `(UseProgram pg)
 
-            let vao-setup-ptr vao-drive-ptr = ('get-nop-vao ctx)
+            let vao-offset = ('get-nop-vao ctx)
+            let vao-drive-ptr = (getgluint ctx.drive-ctx vao-offset)
             sc_expression_append body `(BindVertexArray vao-drive-ptr)
 
             local retargs : (Array Value)

          
@@ 1311,12 1452,13 @@ fn generate-IL (module)
             sc_expression_append body drawcmd
             sc_expression_append body `(UseProgram 0)
             sc_expression_append body `(BindVertexArray 0)
-            sc_expression_append ctx.drive-body body
+            append-body body
             if (empty? retargs) `()
             else
                 sc_argument_list_new ((countof retargs) as i32) (& (retargs @ 0))
         case dispatch (self)
-            let pg = (get self.func)
+            let pgoffset = (get self.func)
+            let pg = (getgluint ctx.drive-ctx pgoffset)
             let x y z = (get self.x self.y self.z)
             let sources sinks = self.sources self.sinks
 

          
@@ 1338,7 1480,7 @@ fn generate-IL (module)
 
             sc_expression_append body dispatchcmd
             sc_expression_append body `(UseProgram 0)
-            sc_expression_append ctx.drive-body body
+            append-body body
             if (empty? retargs) `()
             else
                 sc_argument_list_new ((countof retargs) as i32) (& (retargs @ 0))

          
@@ 1378,10 1520,10 @@ fn generate-IL (module)
     let drive-body = (sc_expression_new)
     let drop-body = (sc_expression_new)
 
-    let drive-ctx = `(bitcast drive-ctx @u8)
+    let drive-ctx = `(bitcast drive-ctx @u32)
     sc_expression_append drive-body drive-ctx
 
-    let drop-ctx = `(bitcast drop-ctx @u8)
+    let drop-ctx = `(bitcast drop-ctx @u32)
     sc_expression_append drop-body drop-ctx
 
     local ctx =

          
@@ 1396,7 1538,10 @@ fn generate-IL (module)
             drop-ctx = drop-ctx
             drop-body = drop-body
 
-    'descend module ('rootid module)
+    let rootid = ('rootid module)
+    'setup ctx.typer module
+
+    'descend module rootid
         on-leave =
             capture (module id) {&ctx}
                 try

          
@@ 1410,7 1555,7 @@ fn generate-IL (module)
     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 alloc-ctx `(malloc-array u32 [(copy ctx.ctx-size)])
 
     sc_template_set_body setup-fn ctx.setup-body
     sc_template_set_body drive-fn ctx.drive-body

          
@@ 1466,7 1611,25 @@ fn fold-constant-expression (self handle
             'handleof self expr.lhs
             'handleof self expr.rhs
     let cls = (typeof self)
+    let module = self
     dispatch handle
+    case comp (self)
+        let typeid sz ptr = (unpack ('handleof module self.value))
+        switch typeid
+        pass TypeId.typeid_fconst
+        pass TypeId.typeid_fvec2
+        pass TypeId.typeid_fvec3
+        pass TypeId.typeid_fvec4
+        pass TypeId.typeid_uconst
+        pass TypeId.typeid_uvec2
+        pass TypeId.typeid_uvec3
+        pass TypeId.typeid_uvec4
+        do
+            if (self.index < sz)
+                return (bitcast (copy (ptr @ self.index)) AnyId)
+            else
+                report "index out of scope"
+        default;
     case uconst (self)
     case fconst (self)
     case add (self)

          
@@ 1581,6 1744,8 @@ fn lower-FIR (module)
             .. "cannot derive capacity from " ('repr module id)
 
     struct GPUJob
+        dim : u32
+        originalsize : (tuple AnyId AnyId AnyId)
         size : (tuple AnyId AnyId AnyId)
         localsize : uvec3
         capacity : uvec3

          
@@ 1589,6 1754,8 @@ fn lower-FIR (module)
 
         fn __copy (self)
             this-type
+                dim = self.dim
+                originalsize = self.originalsize
                 size = self.size
                 localsize = self.localsize
                 capacity = self.capacity

          
@@ 1598,12 1765,22 @@ fn lower-FIR (module)
     struct Context
         gpujobs : (Array GPUJob)
         gpujobmap : (Map AnyId u32)
-        types : (Map AnyId AnyId)
+        typer : FIRTyper
 
         fn getuniform (ctx gpujob module id)
             try (copy ('get gpujob.uniforms id))
             else
-                let ty = ('getdefault ctx.types id NoId)
+                let ty = ('typeof ctx.typer module id)
+                let ty =
+                    dispatch ('handleof module ty)
+                    case imagestorage (self)
+                        dispatch ('handleof module self.type)
+                        case image (self)
+                            let sampler = ('alloc module TypeId.typeid_sampler)
+                            @sampler = self
+                            'commit module
+                        default (copy self.type)
+                    default ty
                 from (methodsof module.builder) let uniform
                 let uniid = (uniform ty gpujob.next_uniform_id)
                 gpujob.next_uniform_id += 1

          
@@ 1611,34 1788,72 @@ fn lower-FIR (module)
                 uniid
     local ctx : Context
 
-    fn gendispatch (ctx module source)
-        let source_idx =
-            try (copy ('get ctx.gpujobmap source))
+    fn remapvector (ctx module source numcomp)
+        dispatch ('handleof module ('typeof ctx.typer module source))
+        case fvec (self)
+            let sourcecomp = (copy self.count)
+            if (sourcecomp == numcomp)
+                source
             else
-                error "source must be range"
-        let tid = ('getdefault ctx.types source NoId)
-        let imgformat count =
+                from (methodsof module.builder) let fvec2 fvec3 fvec4 fconst comp
+                inline get (i)
+                    if (i >= sourcecomp) (fconst 0)
+                    else (comp i source)
+                switch numcomp
+                case 1 (get 0)
+                case 2 (fvec2 (get 0) (get 1))
+                case 3 (fvec3 (get 0) (get 1) (get 2))
+                case 4 (fvec4 (get 0) (get 1) (get 2) (get 3))
+                default
+                    trap;
+        case uvec (self)
+            let sourcecomp = (copy self.count)
+            if (sourcecomp == numcomp)
+                source
+            else
+                from (methodsof module.builder) let uvec2 uvec3 uvec4 uconst comp
+                inline get (i)
+                    if (i >= sourcecomp) (uconst 0)
+                    else (comp i source)
+                switch numcomp
+                case 1 (get 0)
+                case 2 (uvec2 (get 0) (get 1))
+                case 3 (uvec3 (get 0) (get 1) (get 2))
+                case 4 (uvec4 (get 0) (get 1) (get 2) (get 3))
+                default
+                    trap;
+        default
+            error "source must be float or integer"
+
+    fn genimagestorage (ctx module source_idx source)
+        let tid = ('typeof ctx.typer module source)
+        let imgformat =
             dispatch ('handleof module tid)
             case fvec (self)
                 'setcomponents ImageFormat.R32F self.count
             case uvec (self)
                 'setcomponents ImageFormat.R32U self.count
             default
-                error "sample source must be float or integer"
+                error "source must be float or integer"
         let gpujob = (ctx.gpujobs @ source_idx)
-        from (methodsof module.builder) let uvec2 globalid comp
-        let pos = (globalid)
-        let x y =
-            comp 0 pos
-            comp 1 pos
-        let uv = (uvec2 x y)
+        from (methodsof module.builder) let image imagestorage
+        let cx cy cz = (unpack gpujob.capacity)
+        let imgtype = (image ImageDim.2D imgformat ImageFlags.none)
+        _ (imagestorage imgtype cx cy cz 1 0) imgtype imgformat
+
+    fn gendispatch (ctx module source)
+        let source_idx =
+            try (copy ('get ctx.gpujobmap source))
+            else
+                error "source must be range"
+        let storagetype imgtype imgformat =
+            genimagestorage ctx module source_idx source
+        let gpujob = (ctx.gpujobs @ source_idx)
         from (methodsof module.builder) let dispatch computefn
-            \ bindings image wimage imagewrite imagestorage
-            \ load sampler uvec4 fvec4 uconst fconst
+            \ bindings wimage imagewrite load undef uvec2 globalid comp
+            \ unpack-comp
         let sx sy sz = (unpack gpujob.size)
         let lx ly lz = (unpack gpujob.localsize)
-        let cx cy cz = (unpack gpujob.capacity)
-        let imgtype = (image ImageDim.2D imgformat ImageFlags.none)
         let img = (wimage imgtype 0)
         let numsources = (countof gpujob.uniforms)
         let sources =

          
@@ 1650,40 1865,9 @@ fn lower-FIR (module)
                 tupleof k v
             ofs += 1
         let sources = ('commit module)
-        let numcomp = ('components imgformat)
-        let src = (copy source)
-        let writevalue =
-            if (numcomp == 4) src
-            else
-                let fmt = ('format imgformat)
-                let z =
-                    switch fmt
-                    pass ImageFormat.U
-                    pass ImageFormat.S
-                    do (uconst 0)
-                    pass ImageFormat.F
-                    pass ImageFormat.UNORM
-                    pass ImageFormat.SNORM
-                    do (fconst 0)
-                    default
-                        error "unsupported component type"
-                let x y z w =
-                    switch numcomp
-                    case 1 (_ src z z z)
-                    case 2 (_ (comp 0 src) (comp 1 src) z z)
-                    case 3 (_ (comp 0 src) (comp 1 src) (comp 2 src) z)
-                    default
-                        error "invalid number of components"
-                switch fmt
-                pass ImageFormat.U
-                pass ImageFormat.S
-                do (uvec4 x y z w)
-                pass ImageFormat.F
-                pass ImageFormat.UNORM
-                pass ImageFormat.SNORM
-                do (fvec4 x y z w)
-                default
-                    trap;
+        let writevalue = (remapvector ctx module (copy source) 4:u32)
+        let pos = (globalid)
+        let uv = (uvec2 (unpack-comp pos 2))
         let source =
             dispatch
                 computefn lx ly lz

          
@@ 1691,10 1875,7 @@ fn lower-FIR (module)
                 \ sx sy sz
                 sources
                 bindings
-                    tupleof
-                        imagestorage imgtype cx cy cz 1 0
-                        img
-        'set ctx.types source (sampler ImageDim.2D imgformat ImageFlags.none)
+                    tupleof (undef storagetype) img
         _ source imgformat
 
     fn translate-value (ctx module handle oldmodule id)

          
@@ 1745,37 1926,60 @@ fn lower-FIR (module)
                     trap;
             from (methodsof module.builder) let add udiv globalid uconst uvec
             let dims = self.dims
-            let x cx =
+            let ox x cx =
+                copy (dims @ 0)
                 udiv (add (dims @ 0) (uconst (lx - 1))) (uconst lx)
                 max lx (get-capacity module (copy (dims @ 0)))
-            let y cy =
+            let oy y cy =
                 if (ly == 1)
-                    _ (uconst 1) 1:u32
+                    _ (uconst 1) (uconst 1) 1:u32
                 else
                     _
+                        copy (dims @ 1)
                         udiv (add (dims @ 1) (uconst (lx - 1))) (uconst ly)
                         max ly (get-capacity module (copy (dims @ 1)))
-            let z cz =
+            let oz z cz =
                 if (lz == 1)
-                    _ (uconst 1) 1:u32
+                    _ (uconst 1) (uconst 1) 1:u32
                 else
                     _
+                        copy (dims @ 2)
                         udiv (add (dims @ 2) (uconst (lx - 1))) (uconst lz)
                         max lz (get-capacity module (copy (dims @ 2)))
             let newid = (globalid)
             'set ctx.gpujobmap newid ((countof ctx.gpujobs) as u32)
             'append ctx.gpujobs
                 GPUJob
+                    dim = dim
+                    originalsize = (tupleof ox oy oz)
                     size = (tupleof x y z)
                     localsize = (uvec3 lx ly lz)
                     capacity = (uvec3 cx cy cz)
             newid
+        case clear (self)
+            let idx =
+                try (copy ('get ctx.gpujobmap self.range))
+                else
+                    error "coordinate must source range"
+            let gpujob = (ctx.gpujobs @ idx)
+            let storagetype imgtype imgformat =
+                genimagestorage ctx module idx self.value
+            from (methodsof module.builder) let clearimage uconst undef
+            let ox oy oz = (unpack gpujob.originalsize)
+            let z = (uconst 0)
+            let value = (remapvector ctx module
+                (copy self.value) ('components imgformat))
+            clearimage value
+                z
+                \ z z z
+                \ ox oy oz
+                undef storagetype
+
         case sample (self)
             let uv_idx =
                 try (copy ('get ctx.gpujobmap self.uv))
                 else
                     error "coordinate must source range"
-            let tid = ('getdefault ctx.types self.source NoId)
             let source imgformat =
                 gendispatch ctx module self.source
             let gpujob = (ctx.gpujobs @ uv_idx)

          
@@ 1814,78 2018,29 @@ fn lower-FIR (module)
                     default
                         trap;
             'set ctx.gpujobmap newid uv_idx
-            'set ctx.types newid tid
             return newid
         case output (self)
             switch self.sink
             case SystemKey.Screen
-                let source =
-                    gendispatch ctx module self.value
-                self.value = source
+                let tid = ('typeof ctx.typer module self.value)
+                let typeid = ('headerof module tid)
+                switch typeid
+                case TypeId.typeid_imagestorage
+                    # all fine
+                default
+                    # execute dispatch
+                    self.value =
+                        (_ (gendispatch ctx module self.value) ())
                 'commit module handle
             default
                 error "unhandled output type"
         default
             merge-gpujobs;
-        from (methodsof module.builder) let uvec fvec
-        let newhandle = ('handleof module newid)
-        'set ctx.types newid
-            dispatch newhandle
-            case input (self)
-                switch self.source
-                case SystemKey.ScreenSize (uvec 2)
-                case SystemKey.Iteration (uvec 1)
-                default
-                    error
-                        .. "still need to type: " (repr self.source)
-            default
-                switch ('typeidof module newid)
-                #case TypeId.typeid_range (uvec 3)
-                case TypeId.typeid_globalid (uvec 3)
-
-                pass TypeId.typeid_fconst
-                pass TypeId.typeid_utof
-                pass TypeId.typeid_fadd
-                pass TypeId.typeid_fmul
-                pass TypeId.typeid_fdiv
-                pass TypeId.typeid_sin
-                do (fvec 1)
-
-                pass TypeId.typeid_uconst
-                pass TypeId.typeid_add
-                pass TypeId.typeid_sub
-                pass TypeId.typeid_mul
-                pass TypeId.typeid_udiv
-                pass TypeId.typeid_sdiv
-                pass TypeId.typeid_and
-                pass TypeId.typeid_or
-                pass TypeId.typeid_xor
-                do (uvec 1)
-
-                pass TypeId.typeid_outputs
-                pass TypeId.typeid_output
-                do NoId
-
-                case TypeId.typeid_uvec2 (uvec 2)
-                case TypeId.typeid_uvec3 (uvec 3)
-                case TypeId.typeid_uvec4 (uvec 4)
-                case TypeId.typeid_fvec2 (fvec 2)
-                case TypeId.typeid_fvec3 (fvec 3)
-                case TypeId.typeid_fvec4 (fvec 4)
-
-                pass TypeId.typeid_comp
-                do
-                    for srcid in ('sources newhandle)
-                        let tid = ('getdefault ctx.types srcid NoId)
-                        if (tid != NoId)
-                            break tid
-                    else NoId
-                default
-                    error
-                        .. "still need to type: " ('repr module newid)
         newid
 
-    'translate module module ('rootid module)
+    let rootid = ('rootid module)
+    'setup ctx.typer module
+    'translate module module rootid
         on-leave =
             capture (module handle oldmodule id) {&ctx}
                 try

          
@@ 1910,5 2065,5 @@ type+ FIR.BuilderType
 
 do
     let FIR NoId AnyId SystemKey ImageDim ImageFormat ImageFlags TypeId
-        \ PrimitiveType FragmentType DepthTestType
+        \ PrimitiveType FragmentType DepthTestType FIRTyper
     locals;
  No newline at end of file

          
M testing/tukdag.sc +44 -27
@@ 22,7 22,8 @@ inline gen-level1-test ()
         \ bindings computefn imagestorage imagewrite globalid load fdiv
         \ fconst comp utof fadd fmul sin fvec2 fvec4 udiv add uconst image
         \ outputs output uvec2 fvec draw shaderfn position vertexid
-        \ rattr wattr block fsub urem store clear cos instanceid
+        \ rattr wattr block fsub urem store clearimage cos instanceid undef
+        \ primitiveid unpack-comp
 
     let inpss = (input SystemKey.ScreenSize)
     let inpit = (input SystemKey.Iteration)

          
@@ 82,8 83,15 @@ inline gen-level1-test ()
                                 fvec4 x y (fconst 0) (fconst 1)
                                 position;
                     do
+                        let pid = (primitiveid)
+                        let f = (fmul (utof pid) (fconst 1.0))
+                        let r g b a = (unpack-comp (load colorattr_in) 4)
                         store
-                            load colorattr_in
+                            fvec4
+                                fmul f r
+                                fmul f g
+                                fmul f b
+                                a
                             colorattr_frag
                 comp 0 inpss
                 comp 1 inpss

          
@@ 95,9 103,13 @@ inline gen-level1-test ()
                     tupleof angle u_it
                 bindings
                     tupleof
-                        clear
+                        clearimage
                             fvec4 (uconst 0) (uconst 0) (uconst 1) (uconst 1)
-                            imagestorage imgtype 4096 4096 1 1 0
+                            uconst 0
+                            uconst 0; uconst 0; uconst 0
+                            comp 0 inpss; comp 1 inpss; uconst 1
+                            undef
+                                imagestorage imgtype 4096 4096 1 1 0
                         colorattr_frag
     #outputs
         output SystemKey.Screen

          
@@ 142,29 154,34 @@ inline gen-level2-test ()
     let w h =
         unpack-comp (input SystemKey.ScreenSize) 2
     let screenrange = (range w h)
-
-    let prim = (primitive PrimitiveType.TriangleStrip (uconst 4) (uconst 1))
-    let vertexid = (comp 0 prim)
-    let u = (utof (urem vertexid (uconst 2)))
-    let v = (utof (udiv vertexid (uconst 2)))
-
-    let quadvertex =
-        do
-            let x = (fsub u (fconst 0.5))
-            let y = (fsub v (fconst 0.5))
-            fvec4 x y (fconst 0) (fconst 1)
-    let vertexcolor =
-        fragment FragmentType.Smooth
-            fvec3 u v (fconst 0)
     outputs
         output SystemKey.Screen
-            selectfragment
-                overlay quadvertex
-                vertexcolor
-                clear screenrange
-                    fvec3 (uconst 0) (uconst 0) (uconst 1)
+            clear screenrange
+                fvec3 (fconst 0) (fconst 0) (fconst 1)
+
+    #do
+        let prim = (primitive PrimitiveType.TriangleStrip (uconst 4) (uconst 1))
+        let vertexid = (comp 0 prim)
+        let u = (utof (urem vertexid (uconst 2)))
+        let v = (utof (udiv vertexid (uconst 2)))
 
-    outputs
+        let quadvertex =
+            do
+                let x = (fsub u (fconst 0.5))
+                let y = (fsub v (fconst 0.5))
+                fvec4 x y (fconst 0) (fconst 1)
+        let vertexcolor =
+            fragment FragmentType.Smooth
+                fvec3 u v (fconst 0)
+        outputs
+            output SystemKey.Screen
+                selectfragment
+                    overlay quadvertex
+                    vertexcolor
+                    clear screenrange
+                        fvec3 (uconst 0) (uconst 0) (uconst 1)
+
+    #outputs
         output SystemKey.Screen
             do
                 # frame time

          
@@ 201,15 218,15 @@ inline graphviz ()
         'showdot module ('rootid module)
             module-dir .. "/tukdag"
 
-gen-level1-test;
-#do
+#gen-level1-test;
+do
     gen-level2-test;
     cleanup;
     'dump module
     'lower module
 print;
 'fold-constant-expressions module
-cleanup;
+#cleanup;
 'dump-scope module
 #graphviz;
 run;