aae80633d38c — Leonard Ritter 10 days ago
* tukdag: routing through values
* support for custom repr functions in CADAG
2 files changed, 495 insertions(+), 0 deletions(-)

M lib/tukan/CADAG.sc
A => testing/tukdag.sc
M lib/tukan/CADAG.sc +6 -0
@@ 210,6 210,12 @@ fn repr-atomic-value (ET value)
 
 fn value-typeid-repr (T value sz)
     returning Value
+    try
+        let func = ('@ T '__CADAG_repr)
+        return
+            spice-quote
+                .. " " (func value sz)
+    else;
     let ST = ('storageof T)
     switch ('kind ST)
     pass type-kind-array

          
A => testing/tukdag.sc +489 -0
@@ 0,0 1,489 @@ 
+
+using import enum
+using import struct
+using import Capture
+using import Map
+using import Array
+
+import ..lib.tukan.use
+using import tukan.CADAG
+
+let SYSKEY_START = 0x80000000:u32
+
+enum SystemKey : u32
+    #   inputs
+        ======
+
+    # u32[0]
+    Setup = SYSKEY_START
+    # u32x2
+    ScreenSize
+    # u32
+    Iteration
+    # u32[?]
+    IState
+    # u32[0]
+    Break
+    # u32[0]
+    Close
+    # zterm u32[?]
+    Readline
+    # u32
+    SampleRate
+    # u32
+    SampleCount
+
+    #   outputs
+        =======
+
+    # u32[?]
+    OState
+    # zterm u32[?]
+    Stdout
+    # u32[0]
+    BlockBreak
+    # u32[0]
+    BlockClose
+    # 2D texture
+    Screen
+    # zterm u32[?]
+    Title
+    # u32[4 * ?]
+    Program
+    # zterm u32[?]
+    Prompt
+    # i32
+    Exit
+    # f32[samplecount * 2]
+    Sound
+
+################################################################################
+
+# generate a new DAG module type
+let FIR = (CADAG "FIR")
+from FIR let AnyId NoId Id
+from (methodsof FIR) let define-type
+
+define-type "ILSymbol"          (RIFF "ISYM") (tuple (size = u32) (str = (array char)))
+define-type "ILString"          (RIFF "ISTR") (tuple (size = u32) (str = (array char)))
+define-type "ILConstInt"        (RIFF "ICIN") (tuple (type = AnyId) (value = u32))
+define-type "ILParams"          (RIFF "IPMS") (tuple (level = i32) (count = i32))
+    dedup = false
+define-type "ILVAGet"           (RIFF "IGET") (tuple (index = i32) (args = AnyId))
+define-type "ILVA"              (RIFF "ILVA") (tuple (args = (array AnyId)))
+define-type "ILTemplate"        (RIFF "ITMP") (tuple (params = AnyId) (body = AnyId))
+    dedup = false
+define-type "ILDo"              (RIFF "IRDO") (tuple (scoped? = bool) (body = (array AnyId)))
+    dedup = false
+define-type "ILCall"            (RIFF "ICAL") (tuple (callee = AnyId) (args = (array AnyId)))
+    dedup = false
+define-type "ILNoReturnType"    (RIFF "INRT") (tuple)
+define-type "ILIntegerType"     (RIFF "IINT") (tuple (width = i32) (signed? = bool))
+define-type "ILArgumentsType"   (RIFF "IATY") (tuple (types = (array AnyId)))
+define-type "ILStringType"      (RIFF "ISTY") (tuple)
+define-type "ILFunctionType"    (RIFF "IFTY") (tuple (return = AnyId) (raise = AnyId) (params = (array AnyId)))
+define-type "ILGlobal"          (RIFF "IGLO")
+    tuple (name = AnyId) (type = AnyId) (flags = u32) (storage = AnyId) (attrs = (array AnyId))
+define-type "ILIf"              (RIFF "ILIF") (tuple (cond = AnyId) (then = AnyId) (else = AnyId))
+    dedup = false
+define-type "ILXValue"          (RIFF "ILXV")
+    type ILXValueType <: (tuple u32 u32 u32 u32)
+        @@ memo
+        inline __as (cls T)
+            static-if (T == Value)
+                fn (self)
+                    let w0 w1 w2 w3 = (unpack self)
+                    let u128 = (integer 128)
+                    local value =
+                        |
+                            w0 as u128
+                            (w1 as u128) << 32
+                            (w2 as u128) << 64
+                            (w3 as u128) << 96
+                    deref (@ (bitcast (& value) @Value))
+
+        inline __CADAG_repr (self)
+            repr (self as Value)
+
+define-type "vec"       (RIFF "VECT") (tuple i32)
+define-type "vec2"      (RIFF "VEC2") (tuple AnyId AnyId)
+define-type "vec3"      (RIFF "VEC3") (tuple AnyId AnyId AnyId)
+define-type "vec4"      (RIFF "VEC4") (tuple AnyId AnyId AnyId AnyId)
+define-type "input"     (RIFF "INPT") (tuple AnyId SystemKey)
+define-type "output"    (RIFF "OUTP") (tuple SystemKey AnyId)
+define-type "uconst"    (RIFF "U32C") u32
+define-type "fconst"    (RIFF "F32C") f32
+define-type "range"     (RIFF "RANG") (tuple AnyId AnyId)
+define-type "comp"      (RIFF "COMP") (tuple i32 AnyId)
+define-type "and"       (RIFF "BAND") (tuple AnyId AnyId)
+define-type "xor"       (RIFF "BXOR") (tuple AnyId AnyId)
+define-type "utof"      (RIFF "UTOF") (tuple AnyId)
+define-type "sin"       (RIFF "FSIN") (tuple AnyId)
+define-type "cos"       (RIFF "FCOS") (tuple AnyId)
+define-type "fadd"      (RIFF "FADD") (tuple AnyId AnyId)
+define-type "fmul"      (RIFF "FMUL") (tuple AnyId AnyId)
+define-type "fdiv"      (RIFF "FDIV") (tuple AnyId AnyId)
+define-type "sample"    (RIFF "SAMP") (tuple AnyId AnyId)
+
+################################################################################
+
+type+ FIR.BuilderType
+    let ILSymbol = this-type.ILSymbol
+    inline ILSymbol (self str)
+        static-if (none? str) (ILSymbol self 0)
+        else (ILSymbol self ((countof str) as u32) str)
+
+    let ILString = this-type.ILString
+    inline ILString (self str)
+        ILString self ((countof str) as u32) str
+
+    let ILDo = this-type.ILDo
+    inline ILEmbed (self ...)
+        ILDo self false ...
+    inline ILDo (self ...)
+        ILDo self true ...
+
+    spice ILType (self value)
+        value as:= type
+        switch ('kind value)
+        case type-kind-function
+            let retT raiseT = (sc_function_type_return_type value)
+            let count = (sc_type_countof value)
+            let call = (sc_call_new 'ILFunctionType)
+            sc_call_append_argument call self
+            sc_call_append_argument call `('ILType self retT)
+            sc_call_append_argument call `('ILType self raiseT)
+            for i in (range count)
+                let ET = (sc_type_element_at value i)
+                sc_call_append_argument call `('ILType self ET)
+            call
+        case type-kind-arguments
+            let count = (sc_arguments_type_argcount value)
+            let call = (sc_call_new 'ILArgumentsType)
+            sc_call_append_argument call self
+            for i in (range count)
+                let ET = (sc_arguments_type_getarg value i)
+                sc_call_append_argument call `('ILType self ET)
+            call
+        case type-kind-typename
+            match value
+            case string `('ILStringType self)
+            case noreturn `('ILNoReturnType self)
+            default
+                error (.. "cannot translate typename " (repr value))
+        default
+            error (.. "cannot translate type " (repr value))
+
+    spice ILValue (self value)
+        switch ('kind value)
+        case value-kind-global
+            let flags = (sc_global_flags value)
+            let name = ((sc_global_name value) as string)
+            let storage_class = ((sc_global_storage_class value) as string)
+            let location = (sc_global_location value)
+            let binding = (sc_global_binding value)
+            let set = (sc_global_descriptor_set value)
+            let T = (sc_type_element_at (sc_value_type value) 0)
+            spice-quote
+                from (methodsof self) let ILGlobal ILSymbol ILType
+                ILGlobal (ILSymbol name) (ILType T) flags
+                    ILSymbol storage_class
+        default
+            error (.. "cannot translate value " (repr value))
+
+    let ILXValue = this-type.ILXValue
+    fn... ILXValue (self, value : Value)
+        static-assert ((sizeof Value) == 16)
+        local value = (copy value)
+        let value = (deref (@ (bitcast (& value) (@ (integer 128)))))
+        let w0 = (value as u32)
+        let w1 = ((value >> 32) as u32)
+        let w2 = ((value >> 64) as u32)
+        let w3 = ((value >> 96) as u32)
+        ILXValue self w0 w1 w2 w3
+
+run-stage;
+
+################################################################################
+
+let ValueMap = (Map AnyId Value)
+struct ILFunction
+    func : Value
+    values : ValueMap
+
+fn resolve (funcstack id)
+    for ctx in ('reverse funcstack)
+        try
+            return (copy ('get ctx.values id))
+        else;
+    else
+        raise;
+
+fn resolve-value (funcstack id)
+    try (resolve funcstack id)
+    else
+        error
+            .. "unmapped id: " (repr id)
+
+fn generate-IL (self)
+    local funcstack : (Array ILFunction)
+    'append funcstack (ILFunction `none)
+    'descend self ('rootid self)
+        on-enter =
+            capture (module id) {&funcstack}
+                #report "enter" id
+                let handle = ('handleof module id)
+                dispatch handle
+                case ILTemplate (self)
+                    let f = (sc_template_new unnamed)
+                    local ctx : ILFunction
+                    ctx.func = f
+                    let paramsid = self.params
+                    dispatch ('handleof module paramsid)
+                    case ILParams (params)
+                        let args = (alloca-array Value params.count)
+                        for i in (range params.count)
+                            let arg = (sc_parameter_new unnamed)
+                            sc_template_append_parameter f arg
+                            args @ i = arg
+                        'set ctx.values paramsid
+                            sc_argument_list_new params.count args
+                    default;
+                    #'set ctx.values id f
+                    'append funcstack ctx
+                default;
+                true
+        visit =
+            capture (module id) {&funcstack}
+                inline get (id)
+                    resolve-value funcstack id
+                try
+                    return (resolve funcstack id)
+                else;
+                #report "leave" id
+                let handle = ('handleof module id)
+                let vacount = ('vacount handle)
+                local global? = false
+                vvv bind value
+                dispatch handle
+                case ILXValue (self)
+                    self as Value
+                case ILTemplate (self)
+                    #report "pop"
+                    let ctx = ('last funcstack)
+                    let f = (copy ctx.func)
+                    sc_template_set_body f (get self.body)
+                    'pop funcstack
+                    f
+                case ILSymbol (self)
+                    global? = true
+                    `[(Symbol (string (& (self.str @ 0)) (min vacount self.size)))]
+                case ILString (self)
+                    global? = true
+                    `[(string (& (self.str @ 0)) (min vacount self.size))]
+                case ILArgumentsType (self)
+                    global? = true
+                    let count = vacount
+                    let types = (alloca-array type count)
+                    let ptypes = self.types
+                    for i in (range count)
+                        types @ i =
+                            \ (get (ptypes @ i)) as type
+                    `[(sc_arguments_type (count as i32) types)]
+                case ILVA (self)
+                    let args = (alloca-array Value vacount)
+                    for i in (range vacount)
+                        args @ i = (get (self.args @ i))
+                    sc_argument_list_new (vacount as i32) args
+                case ILVAGet (self)
+                    sc_extract_argument_new (get self.args) self.index
+                case ILNoReturnType ()
+                    global? = true
+                    `noreturn
+                case ILStringType ()
+                    global? = true
+                    `string
+                case ILFunctionType (self)
+                    global? = true
+                    let types = (alloca-array type vacount)
+                    let params = self.params
+                    for i in (range vacount)
+                        types @ i = ((get (params @ i)) as type)
+                    let return-type = ((get self.return) as type)
+                    let raise-type = ((get self.raise) as type)
+                    let RT = (sc_function_type return-type (vacount as i32) types)
+                    let RT =
+                        if (raise-type != noreturn)
+                            sc_function_type_raising RT raise-type
+                        else RT
+                    `RT
+                case ILIntegerType (self)
+                    global? = true
+                    `[(sc_integer_type self.width self.signed?)]
+                case ILConstInt (self)
+                    global? = true
+                    `[(sc_const_int_new ((get self.type) as type) self.value)]
+                case ILIf (self)
+                    `[(sc_cond_new
+                        (get self.cond) (get self.then) (get self.else))]
+                case ILGlobal (self)
+                    global? = true
+                    let name = ((get self.name) as Symbol)
+                    let type = ((get self.type) as type)
+                    let storage = ((get self.storage) as Symbol)
+                    sc_global_new name type self.flags storage
+                case ILCall (self)
+                    let call = (sc_call_new (get self.callee))
+                    let args = self.args
+                    for i in (range vacount)
+                        sc_call_append_argument call (get (args @ i))
+                    call
+                case ILDo (self)
+                    let expr = (sc_expression_new)
+                    if self.scoped?
+                        sc_expression_set_scoped expr
+                    let body = self.body
+                    for i in (range vacount)
+                        sc_expression_append expr (get (body @ i))
+                    expr
+                default
+                    error@ unknown-anchor
+                        .. "while translating " ('repr module id)
+                        "invalid expression"
+                let ctx =
+                    if global? (funcstack @ 0)
+                    else ('last funcstack)
+                'set ctx.values id value
+                value
+    try
+        resolve funcstack ('rootid self)
+    else
+        assert false
+        unreachable;
+
+################################################################################
+
+# instantiate a module
+local module : FIR
+
+from (methodsof module) let rootid transform descend
+
+do
+    from (methodsof module.builder) let ILGlobal ILSymbol ILFunctionType
+        \ ILArgumentsType ILNoReturnType ILStringType ILSymbol ILTemplate ILParams
+        \ ILCall ILString ILDo ILIf ILConstInt ILInteger ILVAGet ILVA ILEmbed
+        \ ILValue ILXValue
+
+    let sc_write =
+        ILXValue `sc_write
+    ILTemplate
+        let params = (ILParams 0 1)
+        ILEmbed
+            ILIf
+                let param0 = (ILVAGet 0 params)
+                ILCall sc_write (ILString "hello world\n")
+                ILCall sc_write (ILString "hello me\n")
+            ILVA param0 param0
+
+
+#do
+    from (methodsof module.builder) let vec vec2 vec3 vec4 input output uconst
+        \ fconst range comp and xor utof sin cos fadd fmul fdiv sample
+        \ nativefn symbol
+
+
+    do
+        let inpss = (input (vec 2) SystemKey.ScreenSize)
+        let inpit = (input (vec 1) SystemKey.Iteration)
+
+        let TS = (uconst 32)
+        let checkers_texture =
+            do
+                let pos = (range TS TS)
+                let x y =
+                    comp 0 pos
+                    comp 1 pos
+                utof (xor (and x (uconst 1)) (and y (uconst 1)))
+
+        output SystemKey.Screen
+            do
+                # frame time
+                let it = (fdiv (utof inpit) (fconst 60.0))
+                # screen size
+                let w h =
+                    comp 0 inpss
+                    comp 1 inpss
+                let pos = (range w h)
+                let x y =
+                    comp 0 pos
+                    comp 1 pos
+                let u = (fdiv (utof x) (utof w))
+                let v = (fdiv (utof y) (utof h))
+                let q = (sample checkers_texture (vec2 u v))
+                #let q = (fconst 1.0)
+                let u = (fmul q u)
+                let v = (fmul q v)
+                let z = (fmul q (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5)))
+                vec4 u v z (fconst 1)
+
+
+        nativefn (symbol "test")
+
+# perform a topological transform where we increment the constant values
+#let newmodule newid =
+    transform (rootid)
+        visit =
+            capture (module handle finalize) {}
+                dispatch handle
+                case const (self)
+                    print self
+                    self += 1
+                case const2 (self)
+                    return (('const module.builder (self + 10)) as u32)
+                case vec3 (self)
+                    print (self @ 0) (self @ 1) (self @ 2)
+                    dispatch ('handleof module (self @ 0))
+                    case const (self)
+                        print "yes is a const"
+                    default;
+                case u32x (self)
+                    print ('vacount handle)
+                case str (self)
+                    ptr := self @ 0
+                    # find last nonzero char
+                    let count =
+                        for i in (rrange ('vacount handle))
+                            if ((ptr @ i) != 0:char)
+                                break (i + 1)
+                        else 0:u32
+                    print
+                        repr
+                            string (& (ptr @ 0)) count
+                default
+                    print "unhandled:" (string handle.name)
+                finalize;
+
+# perform an identity transform and swap out the new module
+    all transformations are immutable.
+let newmodule newid = (transform (rootid))
+module = newmodule
+#module = newmodule
+#assert (newid == (rootid))
+#descend newid
+'dump module
+
+let f =
+    generate-IL module
+
+drop module
+unlet module
+unlet newmodule
+run-stage;
+
+compile
+    typify f bool
+    'dump-function
+    'dump-disassembly
+
+
+;
  No newline at end of file