3050731fa734 — Leonard Ritter a month ago
* ccvm examples
8 files changed, 455 insertions(+), 138 deletions(-)

M lib/tukan/uvm.sc
M testing/ccvm_fib.sc
A => testing/ccvm_fib_opt1.sc
A => testing/ccvm_fib_opt2.sc
A => testing/ccvm_fib_opt3.sc
A => testing/test_compiler.sc
R testing/test_compiler.tuk => 
M testing/tuk_interpreter.sc
M lib/tukan/uvm.sc +6 -23
@@ 1557,7 1557,7 @@ struct CachedEval
                                                     'set env node ('get-index value (index - 1))
                                     \ triplet env value lastindex
                             else
-                                print "in" expr
+                                print "in" ('tostring expr)
                                 print "error: cell expected, not" ('tostring value)
                         elseif (tok == tok_let:)
                             let lastindex = (('next-index triplet) - 1)

          
@@ 1573,7 1573,7 @@ struct CachedEval
                                                     'set env node ('get value node)
                                     \ triplet env value lastindex
                             else
-                                print "in" expr
+                                print "in" ('tostring expr)
                                 print "error: cell expected, not" ('tostring value)
                         elseif (((tok == tok_fn) or (tok == tok_macro))
                             and (('kind ('get-index triplet 1)) == Atom.Kind.Symbol))

          
@@ 1638,7 1638,10 @@ struct CachedEval
         let envtable = (env as Cell)
         switch ('kind expr)
         case Atom.Kind.Symbol
-            return ('get envtable expr)
+            let result = ('get envtable expr)
+            #if ('none? result)
+                print "error: could not resolve symbol" ('tostring expr)
+            return result
         case Atom.Kind.Cell
             if (not ('none? ('get-meta (expr as Cell))))
                 # don't evaluate cells with metatables

          
@@ 1987,26 1990,6 @@ struct CachedEval
                         if (not (any-none? limit))
                             errormsg "number expected, got " (kindstrs limit)
                         return (Atom)
-                # (maptext size f)
-                case builtins.maptext
-                    let size = ('get-index args 0)
-                    let func = ('get-index args 1)
-                    if (all-kinds? Atom.Kind.Number size)
-                        let sz = (size as Number as integer)
-                        local str : String
-                        for i in (range sz)
-                            let result =
-                                ueval
-                                    uapply-env func
-                                        Cell.new (Atom i)
-                                        0
-                            if (('kind result) == Atom.Kind.Text)
-                                'append str (result as String)
-                        return (Atom str)
-                    else
-                        if (not (any-none? size))
-                            errormsg "number expected, got " (kindstrs size)
-                        return (Atom)
                 default
                     print "syntax error:" ('tostring expr)
                     return (Atom)

          
M testing/ccvm_fib.sc +1 -1
@@ 53,7 53,7 @@ loop
         closure sym.fib
         closure sym.exit
         Cell;
-        Cell.new 10
+        Cell.new 20
     let target = (('get-index (cont as Cell) 0) as Number as i32 as sym)
     let ctx = ('get-index (cont as Cell) 1)
     inline unpack-ctx (c)

          
A => testing/ccvm_fib_opt1.sc +92 -0
@@ 0,0 1,92 @@ 
+using import struct
+using import enum
+using import String
+
+import ..lib.tukan.use
+using import tukan.uvm
+
+#
+    # fibonacci, head recursive
+    fn fib-rec (f n)
+        cond (< n 2) n
+            +
+                f f (- n 1)
+                f f (- n 2)
+    fib-rec fib-rec 10
+
+# with inlined intrinsics and trivial blocks
+
+enum sym plain
+    fib
+    _7
+    _8
+    exit
+
+global mt_closure : Atom =
+    Cell.new
+        type = "closure"
+
+fn... closure (target : sym, ctx : Atom)
+    Atom
+        'set-meta
+            Cell.new (Atom (target as integer)) (copy ctx)
+            copy mt_closure
+case (target : sym)
+    this-function target (Atom)
+
+#struct Instruction
+    cont : Atom       # function to continue with
+    return : Atom     # return function
+    monad : Atom      # global "mutable" environment
+    args : Atom       # arguments to function
+
+loop
+    cont ret monad args =
+        closure sym.fib
+        closure sym.exit
+        Cell;
+        Cell.new 10
+    let target = (('get-index (cont as Cell) 0) as Number as i32 as sym)
+    let ctx = ('get-index (cont as Cell) 1)
+    inline unpack-ctx (c)
+        ctx := (ctx as Cell)
+        va-map
+            inline (i)
+                'get-index ctx i
+            va-range c
+    inline unpack-args (c)
+        va-map
+            inline (i)
+                'get-index args i
+            va-range c
+    switch target
+    case sym.fib
+        let n = (unpack-args 1)
+        if ((n as Number) < 2)
+            repeat ret (Atom) monad (Cell.new n)
+        else
+            repeat (closure sym.fib)
+                closure sym._7 (Cell.new ((n as Number) - 2) ret)
+                monad
+                Cell.new ((n as Number) - 1)
+    case sym._7
+        let n-2 ret = (unpack-ctx 2)
+        let fib_n-1 = (unpack-args 1)
+        repeat (closure sym.fib)
+            closure sym._8 (Cell.new fib_n-1 ret)
+            monad
+            Cell.new n-2
+    case sym._8
+        let fib_n-1 ret = (unpack-ctx 2)
+        let fib_n-2 = (unpack-args 1)
+        repeat ret (Atom) monad
+            Cell.new ((fib_n-1 as Number) + (fib_n-2 as Number))
+    case sym.exit
+        # print result and break
+        let x = (unpack-args 1)
+        print ('tostring x)
+        break;
+    default
+        error (.. "illegal instruction: " (repr target))
+
+;
  No newline at end of file

          
A => testing/ccvm_fib_opt2.sc +60 -0
@@ 0,0 1,60 @@ 
+using import struct
+using import enum
+using import String
+
+import ..lib.tukan.use
+using import tukan.uvm
+
+#
+    # fibonacci, head recursive
+    fn fib-rec (f n)
+        cond (< n 2) n
+            +
+                f f (- n 1)
+                f f (- n 2)
+    fib-rec fib-rec 10
+
+# with inlined intrinsics and trivial blocks
+# with removed nomad and unpacked cont/ret closure arguments
+# with u64 virtual register to carry arguments
+# closure context replaced with list
+
+enum sym plain
+    none
+    fib
+    _7
+    _8
+    exit
+
+loop
+    target ctx ret retctx u64_1 =
+        sym.fib
+        '()
+        sym.exit
+        '()
+        20:u64
+    switch target
+    case sym.fib
+        if (u64_1 < 2)
+            repeat ret retctx sym.none '() u64_1
+        else
+            repeat sym.fib '() sym._7 (cons (u64_1 - 2) ret retctx)
+                u64_1 - 1
+    case sym._7
+        let n-2 ret = (decons ctx)
+        repeat sym.fib '()
+            \ sym._8 (cons u64_1 ret)
+            n-2 as u64
+    case sym._8
+        let fib_n-1 ret retctx = (decons ctx 2)
+        repeat (ret as sym) retctx sym.none '()
+            (fib_n-1 as u64) + u64_1
+    case sym.exit
+        # print result and break
+        let x = u64_1
+        print x
+        break;
+    default
+        error (.. "illegal instruction: " (repr target))
+
+;
  No newline at end of file

          
A => testing/ccvm_fib_opt3.sc +117 -0
@@ 0,0 1,117 @@ 
+using import struct
+using import enum
+using import Array
+
+#
+    # fibonacci, head recursive
+    fn fib-rec (f n)
+        cond (< n 2) n
+            +
+                f f (- n 1)
+                f f (- n 2)
+    fib-rec fib-rec 10
+
+# with inlined intrinsics and trivial blocks
+# with removed nomad and unpacked cont/ret closure arguments
+# with u64 virtual register to carry arguments
+# closure context replaced with stack
+
+do
+    fn fib-rec (n)
+        if (n < 2)
+            return n
+        else
+            +
+                this-function (n - 1)
+                this-function (n - 2)
+
+    print
+        fib-rec 0
+    print
+        fib-rec 1
+    print
+        fib-rec 30
+
+do
+    fn fib-rec (n a b)
+        if (n < 2)
+            return (a * n)
+        else
+            +
+                this-function (n - 1) a b
+                this-function (n - 2) a b
+
+    print
+        fib-rec 0 1 0
+    print
+        fib-rec 1 1 0
+    print
+        fib-rec 30 1 0
+
+#do
+    fn fib-rec (n a b)
+        if (n < 2) (a * n)
+        else
+            +
+                this-function (n - 1) a 0
+                this-function (n - 1) b a
+
+    fn fib-norec (n a b)
+        if (n < 2) (a * n)
+        else (this-function (n - 1) (a + b) a)
+
+
+    print
+        fib-rec 0 1 0
+    print
+        fib-rec 1 1 0
+    print
+        fib-rec 30 1 0
+
+
+#print
+    fib-norec 0 1 0
+#print
+    fib-norec 1 1 0
+#print
+    fib-norec 30 1 0
+
+enum sym plain
+    none
+    fib
+    _7
+    _8
+    exit
+
+local stack : (Array (tuple u64 sym))
+loop
+    target ret u64_1 =
+        sym.fib
+        sym.exit
+        30:u64
+    switch target
+    case sym.fib
+        if (u64_1 < 2)
+            repeat ret sym.none u64_1
+        else
+            'append stack (tupleof (u64_1 - 2) ret)
+            repeat sym.fib sym._7
+                u64_1 - 1
+    case sym._7
+        let n-2 ret = (unpack ('pop stack))
+        'append stack (tupleof u64_1 ret)
+        repeat sym.fib sym._8
+            n-2 as u64
+    case sym._8
+        let fib_n-1 ret = (unpack ('pop stack))
+        repeat (ret as sym) sym.none
+            (fib_n-1 as u64) + u64_1
+    case sym.exit
+        # print result and break
+        let x = u64_1
+        print x
+        break;
+    default
+        error (.. "illegal instruction: " (repr target))
+
+;
  No newline at end of file

          
A => testing/test_compiler.sc +178 -0
@@ 0,0 1,178 @@ 
+#!/usr/bin/env -S scopes tuk_interpreter.sc
+let countof nextindex
+fn empty? (c)
+    == (nextindex c) 0
+fn lastindex (c)
+    - (nextindex c) 1
+fn last (c)
+    let idx (lastindex c)
+    get c idx
+fn pop (c)
+    let idx (lastindex c)
+    set c idx
+fn swap (c i1 i2)
+    set (set c i1 (get c i2)) i2 (get c i1)
+fn append (c value)
+    set c (nextindex c) value
+# call-continuation engine
+fn cc (ftable f args limit)
+    fn final (_ args)
+    let self
+        fold
+            cell f final args
+            limit
+            fn (self i)
+                let@ f fret args self
+                let fval (get ftable f)
+                let f (cond (defined? fval) fval f)
+                f fret args
+    get self 2
+fn transform-dag (self visitf root limit)
+    fn visit-child (ret nodeit)
+        let@ self nodes i outnodes nodeit
+        let child (get nodes i)
+        cond (defined? child)
+            cell 'visit
+                fn (_ self_newnode)
+                    let@ self newnode self_newnode
+                    cell 'visit-child ret
+                        cell self nodes (+ i 1) (append outnodes newnode)
+                cell self child
+            cell ret none (cell self outnodes)
+    cc
+        do
+            = error
+                fn (ret ...)
+                    let@ self msg ...
+                    cell
+                        fn (_ args)
+                        none
+                        cell
+                            set self 'error msg
+            = visit-child visit-child
+            = visit-nodes
+                fn (ret self_nodes)
+                    visit-child ret (append (append self_nodes 0) (cell))
+            = visit
+                fn (ret args)
+                    let@ self node args
+                    let visited (get self 'visited)
+                    cond (defined? (get visited node))
+                        cell ret none (cell self (get (get self 'map) node))
+                        do
+                            let self
+                                set self 'visited
+                                    set visited node true
+                            cell visitf
+                                fn (_ self_newnode)
+                                    let@ self newnode self_newnode
+                                    let self
+                                        set self 'map
+                                            set (get self 'map) node newnode
+                                    cell ret none (cell self newnode)
+                                cell self node
+
+        'visit
+        cell
+            set
+                set self 'visited (cell)
+                \ 'map (cell)
+            root
+        limit
+let source
+    quote
+        do
+            let exit?
+                cond (defined? readline)
+                    == "\n" readline
+                    false
+            let state
+                cond (defined? state) state
+                    do
+                        : meta
+                            cell
+                                : class "state"
+                        = index 0
+            cond exit?
+                do
+                    = exit 0
+                    = stdout "exiting...\n"
+                    = state state
+                do
+                    let state
+                        cond (defined? readline)
+                            set state 'index (+ (get state 'index) 1)
+                            state
+                    = block-break true
+                    = prompt
+                        .. (totext (get state 'index)) "> "
+                    = stdout
+                        cond (defined? break)
+                            "enter empty line to exit\n"
+                            readline
+                    = state state
+let source2
+    quote (a b (c d) d e (c d) f)
+fn error (self msg)
+    cell 'error none (cell self msg)
+fn handle-symbol (ret self node)
+    let value (get (get self 'env) node)
+    cond (defined? value)
+        cell ret none (cell self value)
+        error self
+            .. "undefined symbol: " (totext node)
+fn handle-cell (ret self node)
+    cell 'visit
+        fn (_ ...)
+            let@ self head ...
+            let type (get head 'type)
+            cond (== type 'form)
+                (get head 'func) ret self node
+                error self
+                    .. "don't know how to handle type: " (totext type)
+        cell self (get node 0)
+    #
+        cell 'visit-nodes
+            fn (_ self_nodes)
+                let@ self nodes self_nodes
+                cell ret none (cell (append-order self nodes) nodes)
+            self_node
+let kind-handlers
+    = symbol handle-symbol
+    = cell handle-cell
+let global-env
+    = do
+        do
+            = type 'form
+            = func
+                fn (ret self node)
+                    let _ (dump "do macro")
+let@ self root
+    transform-dag
+        do
+            = env global-env
+        fn (ret self_node)
+            let@ self node self_node
+            fn append-order (self node)
+                let order
+                    get self 'order
+                set self 'order
+                    cond (defined? order)
+                        append order node
+                        cell node
+            let node-kind (kindof node)
+            let kind-handler (get kind-handlers node-kind)
+            cond (defined? kind-handler)
+                kind-handler ret self node
+                error self
+                    .. "unhandled kind: " (totext node-kind)
+        source
+        1000000
+let errormsg (get self 'error)
+let error? (defined? errormsg)
+= stdout
+    cond error?
+        .. (.. "error: " errormsg) "\n"
+        do
+            #let _ (dump root)
+            "ok.\n"

          
R testing/test_compiler.tuk =>  +0 -113
@@ 1,113 0,0 @@ 
-#!/usr/bin/env -S scopes tuk_interpreter.sc
-let countof nextindex
-fn empty? (c)
-    == (nextindex c) 0
-fn lastindex (c)
-    - (nextindex c) 1
-fn last (c)
-    let idx (lastindex c)
-    get c idx
-fn pop (c)
-    let idx (lastindex c)
-    set c idx
-fn swap (c i1 i2)
-    set (set c i1 (get c i2)) i2 (get c i1)
-fn append (c value)
-    set c (nextindex c) value
-
-let source
-    quote
-        do
-            let exit?
-                cond (defined? readline)
-                    == "\n" readline
-                    false
-            let state
-                cond (defined? state) state
-                    do
-                        : meta
-                            cell
-                                : class "state"
-                        = index 0
-            cond exit?
-                do
-                    = exit 0
-                    = stdout "exiting...\n"
-                    = state state
-                do
-                    let state
-                        cond (defined? readline)
-                            set state 'index (+ (get state 'index) 1)
-                            state
-                    = block-break true
-                    = prompt
-                        .. (totext (get state 'index)) "> "
-                    = stdout
-                        cond (defined? break)
-                            "enter empty line to exit\n"
-                            readline
-                    = state state
-
-# call-continuation engine
-fn cc (ftable f args)
-    fn final (_ args)
-    let self
-        fold
-            cell f final args
-            65536
-            fn (self i)
-                let@ f fret args self
-                let fval (get ftable f)
-                let f (cond (defined? fval) fval f)
-                f fret args
-    get self 2
-let: order
-    cc
-        do
-            = visit-child
-                fn (ret nodeit)
-                    let@ self node i nodeit
-                    let child (get node i)
-                    cond (defined? child)
-                        cell 'visit
-                            fn (_ self)
-                                cell 'visit-child ret
-                                    cell self node (+ i 1)
-                            cell self child
-                        cell ret none self
-            = visit
-                fn (ret args)
-                    let@ self node args
-                    fn post (_ self)
-                        cell ret none
-                            set self 'order
-                                append (get self 'order) node
-                    let visited (get self 'visited)
-                    cond (defined? (get visited node))
-                        cell ret none self
-                        do
-                            let visited (set visited node true)
-                            let self (set self 'visited visited)
-                            cond (== (kindof node) 'cell)
-                                cell 'visit-child post
-                                    cell self node 0
-                                post none self
-        'visit
-        cell
-            do
-                = order (cell)
-                = visited (cell)
-            quote (a b (c d) d e (c d) f)
-dump order # prints (a b c d (c d) e f (a b (c d) d e (c d) f))
-#dump # prints (a b c d (c d) e f (a b (c d) d e (c d) f))
-    topowalk (cell)
-        quote (a b (c d) d e (c d) f)
-        fn (self v queue)
-            cond (== (kindof v) 'cell)
-                fold self (countof v)
-                    fn (self i)
-                        queue self (get v i)
-                self
-        append
-= stdout
-    "nothing to do.\n"

          
M testing/tuk_interpreter.sc +1 -1
@@ 455,7 455,7 @@ fn run (argc argv program opts)
         local repeat? : bool =
             sys.gfx | sys.audio_running | ((flags & OutputFlags.State) != 0)
         ins.flags |= InputFlags.SampleRate
-        ins.flags |= InputFlags.SampleCount            
+        ins.flags |= InputFlags.SampleCount
         if sys.audio_running
             ins.samplerate = audio.samplerate as u32
             ins.samplecount = (max 0 (AUDIO_BUFFERSIZE - (audio.queued) as i32)) as u32