7c3d5b107562 — Leonard Ritter a month ago
* initial support for constant expression folding
3 files changed, 556 insertions(+), 399 deletions(-)

M lib/tukan/CADAG/init.sc
M lib/tukan/FIR.sc
M testing/tukdag.sc
M lib/tukan/CADAG/init.sc +49 -47
@@ 1118,6 1118,55 @@ type+ CADAG
                     'insert (pred @ srcidx) idx
         pred
 
+    fn... dump-scope (self, order : Array, scopetree : IndexArrayArray)
+        #let cls = (typeof self)
+        print ('repr self (order @ 0))
+        let count = (countof order)
+        # index, subindex
+        local stack : (Array (tuple u32 u32))
+        'append stack (tupleof ((count - 1) as u32) 0:u32)
+        let tab =
+            default-styler style-comment "|   "
+        loop ()
+            let idx _subidx = (unpack ('last stack))
+            let idx = (copy idx)
+            let subidx = (copy _subidx)
+            _subidx += 1
+            let subscope = (scopetree @ idx)
+            if (subidx >= (countof subscope))
+                # done
+                if (empty? subscope)
+                    'pop stack
+                    for i in (range (countof stack))
+                        sc_write tab
+                    print ('repr self (order @ idx))
+                else
+                    for i in (range (countof stack))
+                        sc_write tab
+                    print
+                        .. ('repr self (order @ idx) (assign = false))
+                            default-styler style-comment
+                                .. " # " ('tostring (order @ idx))
+                    'pop stack
+                if (empty? stack)
+                    break;
+                repeat;
+            elseif (subidx == 0)
+                for i in (range ((countof stack) - 1))
+                    sc_write tab
+                sc_write ('repr (order @ idx))
+                sc_write
+                    default-styler style-operator " ="
+                sc_write "\n"
+            'append stack (tupleof (subscope @ subidx) 0:u32)
+            ;
+    case (self)
+        let ordered indices = ('ordered self ('rootid self))
+        let pred = ('predecessors self ordered indices)
+        let postdom = (postdominators ordered pred)
+        let scope = (scopetree ordered postdom)
+        this-function self ordered scope
+
     inline... store (self, typeid : TypeId, ...)
         (store-func typeid) self ...
 

          
@@ 1168,53 1217,6 @@ type+ CADAG
                 capture (module id) {}
                     print ('repr module id)
 
-    fn... dump-scope (self, order : Array, scopetree : IndexArrayArray)
-        #let cls = (typeof self)
-        print ('repr self (order @ 0))
-        let count = (countof order)
-        # index, subindex
-        local stack : (Array (tuple u32 u32))
-        'append stack (tupleof ((count - 1) as u32) 0:u32)
-        let tab =
-            default-styler style-comment "|   "
-        loop ()
-            let idx subidx = (unpack ('last stack))
-            let idx = (copy idx)
-            let subscope = (scopetree @ idx)
-            if (subidx >= (countof subscope))
-                # done
-                if (empty? subscope)
-                    'pop stack
-                    for i in (range (countof stack))
-                        sc_write tab
-                    print ('repr self (order @ idx))
-                else
-                    for i in (range (countof stack))
-                        sc_write tab
-                    print
-                        .. ('repr self (order @ idx) (assign = false))
-                            default-styler style-comment
-                                .. " # " ('tostring (order @ idx))
-                    'pop stack
-                if (empty? stack)
-                    break;
-                repeat;
-            elseif (subidx == 0)
-                for i in (range ((countof stack) - 1))
-                    sc_write tab
-                sc_write ('repr (order @ idx))
-                sc_write
-                    default-styler style-operator " ="
-                sc_write "\n"
-            'append stack (tupleof (subscope @ subidx) 0:u32)
-            subidx += 1
-    case (self)
-        let ordered indices = ('ordered self ('rootid self))
-        let pred = ('predecessors self ordered indices)
-        let postdom = (postdominators ordered pred)
-        let scope = (scopetree ordered postdom)
-        this-function self ordered scope
-
 do
     let CADAG RIFF riff->string postdominators scopetree
     locals;

          
M lib/tukan/FIR.sc +498 -4
@@ 178,39 178,64 @@ struct ImageType plain
     let array? = (Accessor (inline (self key) ((self.flags & ImageFlags.arrayed) != 0)))
     let ms? = (Accessor (inline (self key) ((self.flags & ImageFlags.multisampled) != 0)))
 define-type "image"         (RIFF "IMGT") ImageType
+    typecolor...
 define-type "sampler"       (RIFF "SMPT") ImageType
+    typecolor...
 define-type "wimage"        (RIFF "WIMG") (tuple (type = AnyId) (binding = u32))
+    funccolor...
 define-type "load"          (RIFF "LOAD") (tuple (pointer = AnyId))
+    instrcolor...
 define-type "getelementptr" (RIFF "GELP") (tuple (value = AnyId) (indices = (array AnyId)))
+    instrcolor...
 define-type "globalid"      (RIFF "GLID") (tuple)
+    funccolor...
 define-type "imagewrite"    (RIFF "IMGW") (tuple (element = AnyId) (offset = AnyId) (target = AnyId))
+    instrcolor...
 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...
 define-type "dispatch"      (RIFF "DISP") (tuple (func = AnyId) (x = AnyId) (y = AnyId) (z = AnyId) (sources = AnyId) (sinks = AnyId))
+    instrcolor...
 define-type "rimage"        (RIFF "RIMG") (tuple (type = AnyId) (binding = u32))
+    funccolor...
 define-type "mimage"        (RIFF "MIMG") (tuple (type = AnyId) (binding = u32))
+    funccolor...
 define-type "rssbo"         (RIFF "RSBO") (tuple (type = AnyId) (binding = u32))
+    funccolor...
 define-type "wssbo"         (RIFF "WSBO") (tuple (type = AnyId) (binding = u32))
+    funccolor...
 define-type "mssbo"         (RIFF "MSBO") (tuple (type = AnyId) (binding = u32)) # mutable SSBO
+    funccolor...
 define-type "store"         (RIFF "STOR") (tuple (value = AnyId) (pointer = AnyId))
+    instrcolor...
 define-type "bufferstorage" (RIFF "BFST") (tuple (size = u32))
+    funccolor...
 define-type "idispatch"     (RIFF "IDSP") (tuple (callee = AnyId) (size = AnyId) (sources = AnyId) (sinks = AnyId))
+    instrcolor...
 
 # FIR Level 0
 ################################################################################
 
 define-type "sample"    (RIFF "SAMP") (tuple (source = AnyId) (uv = AnyId))
+    instrcolor...
 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))
+    instrcolor...
 define-type "fvec3"     (RIFF "FVC3") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
+    instrcolor...
 define-type "fvec4"     (RIFF "FVC4") (tuple (x = AnyId) (y = AnyId) (z = AnyId) (w = AnyId))
+    instrcolor...
 define-type "uvec2"     (RIFF "UVC2") (tuple (x = AnyId) (y = AnyId))
+    instrcolor...
 define-type "uvec3"     (RIFF "UVC3") (tuple (x = AnyId) (y = AnyId) (z = AnyId))
+    instrcolor...
 define-type "uvec4"     (RIFF "UVC4") (tuple (x = AnyId) (y = AnyId) (z = AnyId) (w = AnyId))
+    instrcolor...
 define-type "input"     (RIFF "INPT") (tuple (source = SystemKey))
     instrcolor...
 define-type "output"    (RIFF "OUTP") (tuple (sink = SystemKey) (value = AnyId))

          
@@ 226,10 251,10 @@ let Operator1Type = (tuple (value = AnyI
 let Operator2Type = (tuple (lhs = AnyId) (rhs = AnyId))
 inline define-op1 (name riff)
     define-type name (RIFF riff) Operator1Type
-        funccolor...
+        instrcolor...
 inline define-op2 (name riff)
     define-type name (RIFF riff) Operator2Type
-        funccolor...
+        instrcolor...
 
 define-op2 "add"    "IADD"
 define-op2 "sub"    "ISUB"

          
@@ 266,6 291,9 @@ define-op1 "stof"   "STOF"
 define-op1 "ftou"   "FTOU"
 define-op1 "ftos"   "FTOS"
 
+define-op1 "fbtoib" "FBBU"
+define-op1 "ibtofb" "UBBF"
+
 define-op2 "fadd"   "FADD"
 define-op2 "fsub"   "FSUB"
 define-op2 "fmul"   "FMUL"

          
@@ 740,6 768,9 @@ fn generate-IL (module)
         case ftou (self) (castvecop1 self fptoui u32)
         case ftos (self) (castvecop1 self fptosi u32)
 
+        case fbtoib (self) (castvecop1 self bitcast u32)
+        case ibtofb (self) (castvecop1 self bitcast f32)
+
         case comp (self)
             `([(get self.value)] @ [self.index])
         case fvec2 (self)

          
@@ 1061,8 1092,473 @@ fn generate-IL (module)
     fptr := fptr as RealizeType
     (fptr)
 
+################################################################################
+
+fn tryfconst (x)
+    dispatch x
+    case fconst (self) (_ true (copy self.value))
+    default (_ false 0.0)
+fn tryuconst (x)
+    dispatch x
+    case uconst (self) (_ true (copy self.value))
+    default (_ false 0:u32)
+fn tryfconsts (lhs rhs)
+    let a? a = (tryfconst lhs)
+    let b? b = (tryfconst rhs)
+    _ (| (? a? 1 0) (? b? 2 0)) a b
+fn tryuconsts (lhs rhs)
+    let a? a = (tryuconst lhs)
+    let b? b = (tryuconst rhs)
+    _ (| (? a? 1 0) (? b? 2 0)) a b
+
+# returns NoId if expression can't be folded, otherwise id of new expression
+fn fold-constant-expression (self handle)
+    viewing self
+    raising Error
+    from (methodsof self.builder) let uconst fconst
+    inline tryfconsts (expr)
+        tryfconsts
+            'handleof self expr.lhs
+            'handleof self expr.rhs
+    inline tryuconsts (expr)
+        tryuconsts
+            'handleof self expr.lhs
+            'handleof self expr.rhs
+    let cls = (typeof self)
+    dispatch handle
+    case uconst (self)
+    case fconst (self)
+    case add (self)
+        let mask A B = (tryuconsts self)
+        switch mask
+        #case 0 # a b
+        case 1 # A b
+            if (A == 0:u32) # 0 + b = b
+                return (copy self.rhs)
+        case 2 # a B
+            if (B == 0:u32) # a + 0 = a
+                return (copy self.lhs)
+        case 3 # A B
+            return (uconst (add A B))
+        default;
+    case sub (self)
+        let mask A B = (tryuconsts self)
+        switch mask
+        #case 0 # a b
+        #case 1 # A b
+        case 2 # a B
+            if (B == 0:u32) # a - 0 = a
+                return (copy self.lhs)
+        case 3 # A B
+            return (uconst (sub A B))
+        default;
+    case mul (self)
+        let mask A B = (tryuconsts self)
+        switch mask
+        #case 0 # a b
+        case 1 # A b
+            if (A == 0:u32) # 0 * b = 0
+                return (copy self.lhs)
+            elseif (A == 1:u32) # 1 * b = b
+                return (copy self.rhs)
+        case 2 # a B
+            if (B == 0:u32) # a * 0 = 0
+                return (copy self.rhs)
+            elseif (B == 1:u32) # a * 1 = a
+                return (copy self.lhs)
+        case 3 # A B
+            return (uconst (mul A B))
+        default;
+    case udiv (self)
+        let mask A B = (tryuconsts self)
+        switch mask
+        #case 0 # a b
+        case 1 # A b
+            if (A == 0:u32) # 0 / b = 0
+                return (copy self.lhs)
+        case 2 # a B
+            if (B == 0:u32) # a / 0 = error
+                error "integer division by zero"
+            elseif (B == 1:u32) # a / 1 = a
+                return (copy self.lhs)
+        case 3 # A B
+            return (uconst (udiv A B))
+        default;
+    case sdiv (self)
+        let mask A B = (tryuconsts self)
+        switch mask
+        #case 0 # a b
+        case 1 # A b
+            if (A == 0:u32) # 0 / b = 0
+                return (copy self.lhs)
+        case 2 # a B
+            if (B == 0:u32) # a / 0 = error
+                error "integer division by zero"
+            elseif (B == 1:u32) # a / 1 = a
+                return (copy self.lhs)
+        case 3 # A B
+            return (uconst (sdiv A B))
+        default;
+    default;
+    cls.NoId
+
+fn fold-constant-expressions (self)
+    let cls = (typeof self)
+    'translate self self ('rootid self)
+        on-leave =
+            capture (module handle oldmodule id) {}
+                try
+                    let id = (fold-constant-expression module handle)
+                    if (id != cls.NoId) id
+                    else
+                        'commit module handle
+                except (err)
+                    error@+ err unknown-anchor
+                        .. "while folding " ('repr oldmodule id)
+
+################################################################################
+
+# lower range based expressions to compute functions and dispatches
+fn lower-FIR (module)
+    viewing module
+
+    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)
+
+    struct GPUJob
+        size : (tuple AnyId AnyId AnyId)
+        localsize : uvec3
+        capacity : uvec3
+        uniforms : (Map AnyId AnyId)
+        next_uniform_id = 0:u32
+
+        fn __copy (self)
+            this-type
+                size = self.size
+                localsize = self.localsize
+                capacity = self.capacity
+                next_uniform_id = self.next_uniform_id
+                uniforms = (copy self.uniforms)
+
+    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
+
+    fn gendispatch (ctx module source)
+        let source_idx =
+            try (copy ('get ctx.gpujobmap source))
+            else
+                error "source must be range"
+        let tid = ('getdefault ctx.types source NoId)
+        let imgformat count =
+            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"
+        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 dispatch computefn
+            \ bindings image wimage imagewrite imagestorage
+            \ load sampler uvec4 fvec4 uconst fconst
+        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 =
+            '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)
+        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 source =
+            dispatch
+                computefn lx ly lz
+                    imagewrite writevalue uv (load img)
+                \ sx sy sz
+                sources
+                bindings
+                    tupleof
+                        imagestorage imgtype cx cy cz 1 0
+                        img
+        'set ctx.types source (sampler ImageDim.2D imgformat ImageFlags.none)
+        _ source imgformat
+
+    fn translate-value (ctx module handle oldmodule id)
+        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
+            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)
+            newid
+        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)
+            from (methodsof module.builder) let load uvec2 uvec3 fvec2 fvec3
+                \ comp
+            let uniid =
+                load
+                    'getuniform ctx gpujob module source
+            self.source = uniid
+            let newid = ('commit module handle)
+            let numcomp = ('components imgformat)
+            let newid =
+                if (numcomp == 4) newid
+                else
+                    let fmt = ('format imgformat)
+                    switch fmt
+                    pass ImageFormat.U
+                    pass ImageFormat.S
+                    do
+                        switch numcomp
+                        case 1 (comp 0 newid)
+                        case 2 (uvec2 (comp 0 newid) (comp 1 newid))
+                        case 3 (uvec3 (comp 0 newid) (comp 1 newid) (comp 2 newid))
+                        default
+                            error "invalid number of components"
+                    pass ImageFormat.F
+                    pass ImageFormat.UNORM
+                    pass ImageFormat.SNORM
+                    do
+                        switch numcomp
+                        case 1 (comp 0 newid)
+                        case 2 (fvec2 (comp 0 newid) (comp 1 newid))
+                        case 3 (fvec3 (comp 0 newid) (comp 1 newid) (comp 2 newid))
+                        default
+                            error "invalid number of components"
+                    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
+                '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)
+        on-leave =
+            capture (module handle oldmodule id) {&ctx}
+                try
+                    translate-value ctx module handle oldmodule id
+                except (err)
+                    error@+ err unknown-anchor
+                        .. "while checking " ('repr oldmodule id)
+
+################################################################################
+
 type+ FIR
     let gen-templates = generate-IL
+    let lower = lower-FIR
+    let fold-constant-expressions
 
 type+ FIR.BuilderType
     inline unpack-comp (self value n)

          
@@ 1071,8 1567,6 @@ type+ FIR.BuilderType
                 'comp self i value
             va-range n
 
-################################################################################
-
 do
     let FIR NoId AnyId SystemKey ImageDim ImageFormat ImageFlags TypeId
     locals;
  No newline at end of file

          
M testing/tukdag.sc +9 -348
@@ 13,344 13,6 @@ using import tukan.vm
 
 ################################################################################
 
-fn lower-FIR (module)
-    viewing module
-
-    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)
-
-    struct GPUJob
-        size : (tuple AnyId AnyId AnyId)
-        localsize : uvec3
-        capacity : uvec3
-        uniforms : (Map AnyId AnyId)
-        next_uniform_id = 0:u32
-
-        fn __copy (self)
-            this-type
-                size = self.size
-                localsize = self.localsize
-                capacity = self.capacity
-                next_uniform_id = self.next_uniform_id
-                uniforms = (copy self.uniforms)
-
-    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
-
-    fn gendispatch (ctx module source)
-        let source_idx =
-            try (copy ('get ctx.gpujobmap source))
-            else
-                error "source must be range"
-        let tid = ('getdefault ctx.types source NoId)
-        let imgformat count =
-            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"
-        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 dispatch computefn
-            \ bindings image wimage imagewrite imagestorage
-            \ load sampler uvec4 fvec4 uconst fconst
-        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 =
-            '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)
-        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 source =
-            dispatch
-                computefn lx ly lz
-                    imagewrite writevalue uv (load img)
-                \ sx sy sz
-                sources
-                bindings
-                    tupleof
-                        imagestorage imgtype cx cy cz 1 0
-                        img
-        'set ctx.types source (sampler ImageDim.2D imgformat ImageFlags.none)
-        _ source imgformat
-
-    fn translate-value (ctx module handle oldmodule id)
-        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 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)
-            from (methodsof module.builder) let load uvec2 uvec3 fvec2 fvec3
-                \ comp
-            let uniid =
-                load
-                    'getuniform ctx gpujob module source
-            self.source = uniid
-            let newid = ('commit module handle)
-            let numcomp = ('components imgformat)
-            let newid =
-                if (numcomp == 4) newid
-                else
-                    let fmt = ('format imgformat)
-                    switch fmt
-                    pass ImageFormat.U
-                    pass ImageFormat.S
-                    do
-                        switch numcomp
-                        case 1 (comp 0 newid)
-                        case 2 (uvec2 (comp 0 newid) (comp 1 newid))
-                        case 3 (uvec3 (comp 0 newid) (comp 1 newid) (comp 2 newid))
-                        default
-                            error "invalid number of components"
-                    pass ImageFormat.F
-                    pass ImageFormat.UNORM
-                    pass ImageFormat.SNORM
-                    do
-                        switch numcomp
-                        case 1 (comp 0 newid)
-                        case 2 (fvec2 (comp 0 newid) (comp 1 newid))
-                        case 3 (fvec3 (comp 0 newid) (comp 1 newid) (comp 2 newid))
-                        default
-                            error "invalid number of components"
-                    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
-                '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)
-        on-leave =
-            capture (module handle oldmodule id) {&ctx}
-                try
-                    translate-value ctx module handle oldmodule id
-                except (err)
-                    error@+ err unknown-anchor
-                        .. "while checking " ('repr oldmodule id)
-
-################################################################################
-
 # instantiate a module
 local module : FIR
 

          
@@ 434,6 96,7 @@ inline gen-level2-test ()
             do
                 # frame time
                 let it = (fdiv (utof inpit) (fconst 60.0))
+                let itsin = (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5))
                 # screen size
                 let w h =
                     unpack-comp inpss 2

          
@@ 442,18 105,14 @@ inline gen-level2-test ()
                     unpack-comp pos 2
                 let u = (fdiv (utof x) (utof w))
                 let v = (fdiv (utof y) (utof h))
-                let q0 = (sample checkers_texture1 (fvec2 (fadd u (fconst 0.01)) v))
-                let q1 = (sample checkers_texture2 (fvec2 u (fadd v (fconst 0.01))))
+                let q0 = (sample checkers_texture1 (fvec2 (fadd u itsin) v))
+                let q1 = (sample checkers_texture2 (fvec2 u (fadd v itsin)))
                 #let q = (fconst 1.0)
                 let u = (fmul q0 u)
                 let v = (fmul q1 v)
-                let z = (fmul (fadd q0 q1) (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5)))
+                let z = (fmul (fadd q0 q1) itsin)
                 fvec4 u v z (fconst 1)
 
-# lower range based expressions to compute functions and dispatches
-inline lower ()
-    do
-        lower-FIR module
 # perform an identity transform and swap out the new module
     all transformations are immutable.
 inline cleanup ()

          
@@ 476,12 135,14 @@ inline graphviz ()
 do
     gen-level2-test;
     cleanup;
-    'dump-scope module
-    lower;
+    'dump module
+    'lower module
 print;
+'fold-constant-expressions module
 cleanup;
 'dump-scope module
-run;
+#graphviz;
+#run;
 
 drop module
 unlet module