a0d51e6bd0da — Leonard Ritter 5 days ago
* range based form is beginning to work
3 files changed, 267 insertions(+), 191 deletions(-)

M lib/tukan/CADAG/init.sc
M lib/tukan/FIR.sc
M testing/tukdag.sc
M lib/tukan/CADAG/init.sc +33 -16
@@ 409,7 409,8 @@ type CADAG < Struct
         for arg in ('args ...)
             let k v = ('dekey arg)
             if (k == unnamed)
-                sc_switch_append_default sw `(v)
+                sc_switch_append_default sw
+                    'tag `(v) ('anchor arg)
             else
                 name := (k as string)
                 let code =

          
@@ 572,7 573,7 @@ type Handle
         Generator
             inline () (_ 0:u32 (('enum-id-offset typeid 0:u32) // u32_size))
             inline (i wordofs) (wordofs < sz)
-            inline (i wordofs) (bitcast (copy (ptr @ wordofs)) AnyId)
+            inline (i wordofs) (bitcast (ptr @ wordofs) AnyId)
             inline (i wordofs)
                 i := i + 1
                 _ i (('enum-id-offset typeid i) // u32_size)

          
@@ 776,6 777,10 @@ type+ CADAG
             bitcast (deref (self.words @ offset)) cls.TypeId
             deref (self.words @ (offset + 1))
 
+    fn... typeidof (self, offset : u32)
+        let cls = (typeof self)
+        bitcast (deref (self.words @ offset)) cls.TypeId
+
     struct StackEntry plain
         id : u32
         offset : u32

          
@@ 813,6 818,8 @@ type+ CADAG
 
     fn descend (self root ...)
         let cls = (typeof self)
+        if (root == cls.NoId)
+            return;
         let on-leave =
             va-option on-leave ...
                 inline (module id)

          
@@ 823,6 830,7 @@ type+ CADAG
                 inline (module id) true
         local stack : DescendStack
         local seen : (Set u32)
+        'insert seen 0:u32
         if (on-enter (view self) root)
             'push stack self root
         loop ()

          
@@ 885,6 893,9 @@ type+ CADAG
         viewing self
         viewing oldmodule
         let cls = (typeof self)
+        let oldcls = (typeof oldmodule)
+        if (root == oldcls.NoId)
+            return root
         local aliases : (Map u32 cls.AnyId)
         let on-enter =
             va-option on-enter ...

          
@@ 917,34 928,40 @@ type+ CADAG
                     ((storageof cls.MutableHandleType) md.typeid md.size
                         (& (stack.data @ md.offset)))
                     cls.MutableHandleType)
-                let newid = (on-leave self handle oldmodule (copy md.id))
-                let oldid = (copy md.id)
+                let oldid = (bitcast (copy md.id) oldcls.AnyId)
+                let newid = (on-leave self handle oldmodule oldid)
                 # clear
                 'pop stack
                 if (empty? stack)
                     return (copy newid)
                 let md = ('peek stack)
-                on-leave-param self oldmodule (copy md.id) ((copy md.refindex) - 1) oldid newid
-                _ oldid (storagecast newid)
+                on-leave-param self oldmodule (bitcast (copy md.id) oldcls.AnyId)
+                    \ ((copy md.refindex) - 1) oldid newid
+                _ oldid newid
             else
                 assert ((ofs % u32_size) == 0)
                 let ofs = (md.offset + 2 + wordofs)
                 md.refoffset = (ofs as u32)
-                let oldid = (copy (stack.data @ ofs))
-                let enter? newid = (on-enter-param self oldmodule (copy md.id) (copy md.refindex) oldid)
-                static-assert ((typeof newid) == cls.AnyId)
-                md.refindex += 1
-                if enter?
-                    on-enter self oldmodule oldid
-                    'push stack oldmodule oldid
-                    repeat;
+                let oldid = (bitcast (copy (stack.data @ ofs)) oldcls.AnyId)
+                if (oldid == oldcls.NoId)
+                    md.refindex += 1
+                    _ oldid oldid
                 else
-                    _ oldid (storagecast newid)
+                    let parentid = (bitcast (copy md.id) oldcls.AnyId)
+                    let enter? newid = (on-enter-param self oldmodule parentid (copy md.refindex) oldid)
+                    static-assert ((typeof newid) == cls.AnyId)
+                    md.refindex += 1
+                    if enter?
+                        on-enter self oldmodule oldid
+                        'push stack oldmodule oldid
+                        repeat;
+                    else
+                        _ oldid newid
             # update reference in parent
             let md = ('peek stack)
             let idref = (stack.data @ md.refoffset)
             assert (idref == oldid)
-            idref = newid
+            idref = (storagecast newid)
             ;
 
     @@ memo

          
M lib/tukan/FIR.sc +14 -4
@@ 158,8 158,15 @@ let
 # FIR Level 2
 ################################################################################
 
-define-type "range"     (RIFF "RANG") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
+define-type "range"     (RIFF "RANG") (tuple (dims = (array AnyId)))
     stringcolor...
+define-type "bind"      (RIFF "BNDL") (tuple (value = AnyId) (target = AnyId) (next = AnyId))
+define-type "gpucall"   (RIFF "GPUC")
+    tuple
+        sx = AnyId; sy = AnyId; sz = AnyId
+        lx = u32; ly = u32; lz = u32
+        sources = AnyId; sinks = AnyId
+        expr = AnyId
 
 # FIR Level 1
 ################################################################################

          
@@ 928,7 935,9 @@ fn generate-IL (module)
             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))
+            if (empty? retargs) `()
+            else
+                sc_argument_list_new ((countof retargs) as i32) (& (retargs @ 0))
         case input (self)
             read-input module ctx self.source
         case output (self)

          
@@ 936,7 945,8 @@ fn generate-IL (module)
             `()
         case outputs (self) `()
         default
-            error "unhandled node type"
+            error
+                .. "unhandled node type: " ('repr module id)
         'set ctx.values id value
         ;
 

          
@@ 1025,5 1035,5 @@ type+ FIR
 ################################################################################
 
 do
-    let FIR NoId AnyId SystemKey ImageDim ImageFormat ImageFlags
+    let FIR NoId AnyId SystemKey ImageDim ImageFormat ImageFlags TypeId
     locals;
  No newline at end of file

          
M testing/tukdag.sc +220 -171
@@ 13,166 13,215 @@ using import tukan.vm
 
 ################################################################################
 
-fn lower-FIR (self module)
-    viewing self
+fn lower-FIR (module)
     viewing module
 
-    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 programkey (self)
-            tupleof self.range self.read_order
-
-        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 FIRContext
-        md : (Map AnyId Metadata)
-
-        fn getmd (self id)
-            try ('get self.md id)
-            else
-                assert false
-                unreachable;
-
-
-    local ctx : FIRContext
-
-    fn merge-all-read-orders (ctx handle md)
-        md.read_order =
-            fold (ro = 0) for id in ('sources handle)
-                max ro (('getmd ctx id) . read_order)
-
-    fn merge-all-ranges (ctx handle md)
-        md.range =
-            fold (r = NoId) for id in ('sources handle)
-                let newr = (copy (('getmd ctx id) . range))
-                if (newr == NoId) r
-                else
-                    if (r == NoId) newr
-                    elseif (r == newr) r
-                    else
-                        error "operation is mixing different ranges"
-
-    fn compute-metadata (ctx module handle vacount id)
-        local md : Metadata
-        inline get (id)
-            'getmd ctx id
-        inline merge-all-read-orders ()
-            merge-all-read-orders ctx handle md
-        inline merge-all-ranges ()
-            merge-all-ranges ctx handle md
-        inline merge-all ()
-            merge-all-read-orders ctx handle md
-            merge-all-ranges ctx handle md
-
-        inline ibinop (self iaf)
-            merge-all;
-        inline fbinop (self iaf)
-            merge-all;
-        inline ifunop (self iaf)
-            merge-all;
-        inline funop (self iaf)
-            merge-all;
+    fn get-capacity (module id)
+        dispatch ('handleof module id)
+        case uconst (self)
+            return (copy self.value)
+        case comp (self)
+            let index = self.index
+            dispatch ('handleof module self.value)
+            case input (self)
+                switch self.source
+                case SystemKey.ScreenSize
+                    return 4096:u32
+                default;
+            default;
+        default;
+        error
+            .. "cannot derive capacity from " ('repr module id)
 
-        dispatch handle
-        case outputs (self)
-        case output (self)
-            md.elements = 0
-            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"
-            default
-                error
-                    .. "unsupported output key: " (repr key)
-        case uconst (self)
-        case fconst (self)
-        case input (self)
-            switch self.source
-            case SystemKey.ScreenSize
-                md.elements = 2
-            case SystemKey.Iteration
-            default
-                error
-                    .. "invalid input source: " (repr key)
-        case range (self)
-            md.range = id
-            md.elements = 3
-            merge-all-read-orders;
-        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"
-        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)
-        case sin (self) (funop self 'sin)
-        case cos (self) (funop self 'cos)
-        case and (self) (ibinop self 'and)
-        case xor (self) (ibinop self 'xor)
-        case utof (self) (ifunop self 'utof)
-        case uvec (self)
-            md.elements = self.count
-        case fvec2 (self)
-            md.elements = 2
-            merge-all;
-        case fvec4 (self)
-            md.elements = 4
-            merge-all;
-        case sample (self)
-            merge-all-read-orders;
-            let srcmd = (get self.source)
-            if (srcmd.range == NoId)
-                error "ranged expression expected"
-            md.range = (get self.uv) . range
-            md.read_order += 1
-            md.elements = srcmd.elements
-        default
-            error@ unknown-anchor
-                .. "while checking " (string handle.typeid.name)
-                "invalid node type"
-        md
+    struct GPUJob
+        size : (tuple AnyId AnyId AnyId)
+        localsize : uvec3
+        capacity : uvec3
+        uniforms : (Map AnyId AnyId)
+        next_uniform_id = 0:u32
 
-    '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
+    struct Context
+        gpujobs : (Array GPUJob)
+        gpujobmap : (Map AnyId u32)
+        types : (Map AnyId AnyId)
+
+        fn getuniform (ctx gpujob module id)
+            try (copy ('get gpujob.uniforms id))
+            else
+                let ty = ('getdefault ctx.types id NoId)
+                from (methodsof module.builder) let uniform
+                let uniid = (uniform ty gpujob.next_uniform_id)
+                gpujob.next_uniform_id += 1
+                'set gpujob.uniforms id uniid
+                uniid
+    local ctx : Context
 
     'translate module module ('rootid module)
         on-leave =
             capture (module handle oldmodule id) {&ctx}
-                'commit module handle
+
+                vvv bind merge-gpujobs
+                inline "#hidden" (self)
+                    let idx =
+                        fold (idx = -1:u32) for id in ('sources handle)
+                            let argidx = ('getdefault ctx.gpujobmap id -1:u32)
+                            if (argidx != idx)
+                                if (argidx == -1:u32) idx
+                                elseif (idx != -1:u32)
+                                    error "illegal mixing of ranges"
+                                else argidx
+                            else idx
+                    if (idx != -1:u32)
+                        let gpujob = (ctx.gpujobs @ idx)
+                        # generate uniforms where required
+                        for id in ('sources handle)
+                            let argidx = ('getdefault ctx.gpujobmap id -1:u32)
+                            if (argidx == -1:u32)
+                                from (methodsof module.builder) let load
+                                dispatch ('handleof module id)
+                                case fconst ()
+                                case uconst ()
+                                default
+                                    let uniid =
+                                        load
+                                            'getuniform ctx gpujob module id
+                                    id = uniid
+                    let id = ('commit module handle)
+                    if (idx != -1:u32)
+                        'set ctx.gpujobmap id idx
+                    print ('repr module id)
+                    id
+
+                let vacount = ('vacount handle)
+                vvv bind newid
+                dispatch handle
+                case range (self)
+                    let dim = vacount
+                    if ((dim < 1) | (dim > 3))
+                        error "range must have 1 to 3 arguments"
+                    let lx ly lz =
+                        switch dim
+                        case 1 (_ 64:u32 1:u32 1:u32)
+                        case 2 (_ 8:u32 8:u32 1:u32)
+                        case 3 (_ 4:u32 4:u32 4:u32)
+                        default
+                            trap;
+                    from (methodsof module.builder) let add udiv globalid uconst uvec
+                    let dims = self.dims
+                    let x cx =
+                        udiv (add (dims @ 0) (uconst (lx - 1))) (uconst lx)
+                        max lx (get-capacity module (copy (dims @ 0)))
+                    let y cy =
+                        if (ly == 1)
+                            _ (uconst 1) 1:u32
+                        else
+                            _
+                                udiv (add (dims @ 1) (uconst (lx - 1))) (uconst ly)
+                                max ly (get-capacity module (copy (dims @ 1)))
+                    let z cz =
+                        if (lz == 1)
+                            _ (uconst 1) 1:u32
+                        else
+                            _
+                                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
+                            size = (tupleof x y z)
+                            localsize = (uvec3 lx ly lz)
+                            capacity = (uvec3 cx cy cz)
+                    print ('repr module newid)
+                    newid
+                case output (self)
+                    switch self.sink
+                    case SystemKey.Screen
+                        let idx =
+                            try (copy ('get ctx.gpujobmap self.value))
+                            else
+                                error "screen output must source range"
+                        let gpujob = (ctx.gpujobs @ idx)
+                        from (methodsof module.builder) let dispatch computefn
+                            \ bindings image wimage imagewrite imagestorage
+                            \ globalid comp uvec2 load
+                        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 ImageFormat.RGBA8UNORM ImageFlags.none)
+                        let img = (wimage imgtype 0)
+                        let pos = (globalid)
+                        let x y =
+                            comp 0 pos
+                            comp 1 pos
+                        let numsources = (countof gpujob.uniforms)
+                        let sources =
+                            'alloc module TypeId.typeid_bindings numsources
+                        local ofs = 0
+                        let entries = sources.entries
+                        for k v in gpujob.uniforms
+                            entries @ ofs =
+                                tupleof k v
+                            ofs += 1
+                        let sources = ('commit module)
+                        self.value =
+                            dispatch
+                                computefn lx ly lz
+                                    imagewrite self.value (uvec2 x y) (load img)
+                                \ sx sy sz
+                                sources
+                                bindings
+                                    tupleof
+                                        imagestorage imgtype cx cy cz 1 0
+                                        img
+                        '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)
+                        case TypeId.typeid_uconst (uvec 1)
+                        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_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
 
 ################################################################################
 

          
@@ 184,31 233,32 @@ inline gen-level1-test ()
     from (methodsof module.builder) let input uniform uvec wimage dispatch
         \ bindings computefn imagestorage imagewrite globalid load fdiv
         \ fconst comp utof fadd fmul sin fvec2 fvec4 udiv add uconst image
-        \ outputs output uvec2
+        \ outputs output uvec2 fvec
 
     let inpss = (input SystemKey.ScreenSize)
     let inpit = (input SystemKey.Iteration)
 
-    let ss = (uniform (uvec 2) 0)
-    let u_it = (uniform (uvec 1) 1)
+    let ssx = (uniform (fvec 1) 0)
+    let ssy = (uniform (fvec 1) 1)
+    let u_it = (uniform (fvec 1) 2)
     let imgtype = (image ImageDim.2D ImageFormat.RGBA8UNORM ImageFlags.none)
-    let img = (wimage imgtype 1)
+    let img = (wimage imgtype 0)
+    let z = (fadd (fmul (sin (fdiv (utof inpit) (fconst 60.0))) (fconst 0.5)) (fconst 0.5))
     let func =
         computefn 8 8 1
             do
                 # screen size
-                let ss = (load ss)
-                let it = (fdiv (utof (load u_it)) (fconst 60.0))
+                let it = (load u_it)
                 let w h =
-                    comp 0 ss
-                    comp 1 ss
+                    load ssx
+                    load ssy
                 let pos = (globalid)
                 let x y =
                     comp 0 pos
                     comp 1 pos
-                let u = (fdiv (utof x) (utof w))
-                let v = (fdiv (utof y) (utof h))
-                let z = (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5))
+                let u = (fdiv (utof x) w)
+                let v = (fdiv (utof y) h)
+                let z = (load u_it)
                 imagewrite
                     fvec4 u v z (fconst 1)
                     uvec2 x y

          
@@ 221,8 271,9 @@ inline gen-level1-test ()
                 udiv (add (comp 1 inpss) (uconst 7)) (uconst 8)
                 uconst 1
                 bindings
-                    tupleof inpss ss
-                    tupleof inpit u_it
+                    tupleof (utof (comp 0 inpss)) ssx
+                    tupleof (utof (comp 1 inpss)) ssy
+                    tupleof z u_it
                 bindings
                     tupleof
                         imagestorage imgtype 4096 4096 1 1 0

          
@@ 254,7 305,7 @@ inline gen-level2-test ()
                 let w h =
                     comp 0 inpss
                     comp 1 inpss
-                let pos = (range w h (uconst 1))
+                let pos = (range w h)
                 let x y =
                     comp 0 pos
                     comp 1 pos

          
@@ 270,9 321,7 @@ inline gen-level2-test ()
 # lower range based expressions to compute functions and dispatches
 inline lower ()
     do
-        local newmodule : FIR
-        let newid = (lower-FIR newmodule module)
-        module = newmodule
+        lower-FIR module
 # perform an identity transform and swap out the new module
     all transformations are immutable.
 inline cleanup ()

          
@@ 291,8 340,8 @@ inline graphviz ()
         'showdot module ('rootid module)
             module-dir .. "/tukdag"
 
-gen-level1-test;
-#do
+#gen-level1-test;
+do
     gen-level2-test;
     lower;
 print;