70bbdb2d7fa4 — Leonard Ritter a month ago
* more work on tukan compiler
5 files changed, 1117 insertions(+), 5 deletions(-)

A => lib/tukan/ccvm.sc
M lib/tukan/uvm.sc
A => testing/test_ccvm.sc
A => testing/test_tuk2dag.sc
M testing/tuk_interpreter.sc
A => lib/tukan/ccvm.sc +468 -0
@@ 0,0 1,468 @@ 
+using import struct
+using import enum
+using import Array
+using import Map
+using import Rc
+using import Option
+
+using import .uvm
+
+################################################################################
+
+let Index = i32
+let Label = u64
+
+""""CCVM builtins
+enum Builtins : Label
+    \ unknown unreachable + - * / // % & | ^ fn quote set get nextindex
+    \ < <= > >= == != :
+    \ not dump totext .. cond setmeta getmeta macro eval maptext
+    \ tou32 tof32 floor sqrt fold do cell sin cos map kindof defined?
+    \ condbr
+    userlabel = 1000
+
+global mt_ccvm_c : Atom = (Cell.new (type = "ccvm.c"))
+global mt_ccvm_x : Atom = (Cell.new (type = "ccvm.x"))
+global mt_ccvm_label : Atom = (Cell.new (type = "ccvm.label"))
+global mt_ccvm_ret : Atom = (Cell.new (type = "ccvm.ret"))
+global mt_ccvm_fx : Atom = (Cell.new (type = "ccvm.fx"))
+global mt_ccvm_fret : Atom = (Cell.new (type = "ccvm.fret"))
+
+enum Argument
+
+fn... getarg (args, i = 0)
+    if (i >= (countof args))
+        Argument.undefined;
+    else
+        copy (args @ i)
+
+""""CCVM Inputs
+enum Inputs : i32
+    setup
+    screensize
+    iteration
+    state
+    break
+    close
+    readline
+    samplerate
+    samplecount
+
+""""CCVM argument
+enum Argument
+    c : Index # closure context index
+    x : Index # argument index
+    label : Label # instruction label
+    const : Atom # constant
+    ret # capture return label + context as closure
+    undefined # undefined value that can not be computed
+    fx : Label Index # foreign argument index
+    fret : Label # foreign return argument
+    variadic : (Rc (Array this-type)) # variadic argument list
+    fxall : Label Index # all foreign arguments of this label starting at index
+    keyed : Atom (Rc this-type)
+
+    fn append (self return_expr last_arg?)
+        if last_arg?
+            dispatch self
+            case variadic (args)
+                for arg in args
+                    'append return_expr (copy arg)
+            default
+                'append return_expr self
+        else
+            'append return_expr ('getarg self)
+
+    fn... getarg (self, i = 0)
+        dispatch self
+        case variadic (args)
+            getarg args i
+        case fxall (id k)
+            Argument.fx id (i + k)
+        default
+            self
+
+    fn from-args (return_expr)
+        if ((countof return_expr) == 1)
+            return ('pop return_expr)
+        else
+            return (this-type.variadic (Rc.wrap (deref return_expr)))
+
+    fn... wrap (value : this-type)
+        viewing value
+        let return-metacell =
+            inline "#hidden" (T ...)
+                return (Atom ('set-meta (Cell.new ...) (copy T)))
+        dispatch value
+        case c (i)
+            return-metacell mt_ccvm_c i
+        case x (i)
+            return-metacell mt_ccvm_x i
+        case label (id)
+            return-metacell mt_ccvm_label id
+        case const (atom)
+            return (copy atom)
+        case ret ()
+            return-metacell mt_ccvm_ret
+        case fx (id i)
+            return-metacell mt_ccvm_fx id i
+        case fret (id)
+            return-metacell mt_ccvm_fret id
+        default
+            unreachable;
+
+    fn... unwrap (value : Atom)
+        viewing value
+        switch ('kind value)
+        case Atom.Kind.Cell
+            value as:= Cell
+            let mt = ('get-meta value)
+            if (not ('none? mt))
+                let return-int1 =
+                    inline "#hidden" (T IT)
+                        let a = ('get-index value 0)
+                        return (T
+                            (copy (a as Number as integer as IT)))
+                let return-int2 =
+                    inline "#hidden" (T IT1 IT2)
+                        let a = ('get-index value 0)
+                        let b = ('get-index value 1)
+                        return (T
+                            (copy (a as Number as integer as IT1))
+                            (copy (a as Number as integer as IT2)))
+                let content2 = ('get-index value 1)
+                if (mt == mt_ccvm_c)
+                    return-int1 this-type.c Index
+                elseif (mt == mt_ccvm_x)
+                    return-int1 this-type.x Index
+                elseif (mt == mt_ccvm_label)
+                    return-int1 this-type.label Label
+                elseif (mt == mt_ccvm_ret)
+                    return (this-type.ret)
+                elseif (mt == mt_ccvm_fx)
+                    return-int2 this-type.fx Label Index
+                elseif (mt == mt_ccvm_fret)
+                    return-int1 this-type.fx Label
+        default;
+        this-type.const (copy value)
+
+let Argument__repr = Argument.__repr
+type+ Argument
+    fn __repr (self)
+        returning string
+        dispatch self
+        case label (id)
+            if (id < Builtins.userlabel)
+                repr (id as Builtins)
+            else
+                .. "L" (tostring id)
+        case fx (id i)
+            if (id == Builtins.userlabel)
+                repr ((copy i) as Inputs)
+            else
+                .. "L" (tostring id) ".x" (tostring i)
+        case fret (id)
+            if (id == Builtins.userlabel)
+                "main.ret"
+            else
+                .. "L" (tostring id) ".ret"
+        case fxall (id i)
+            .. "L" (tostring id) ".x" (tostring i) "..."
+        case keyed (sym arg)
+            .. "(: " (('tostring sym) as string) " " (repr (arg as Argument)) ")"
+        case const (atom)
+            ('tostring atom) as string
+        default
+            Argument__repr self
+
+struct Bindings
+let RcBindings = (Rc Bindings)
+
+struct Bindings
+    parent : (Option RcBindings)
+    symbols : (Map Symbol Argument)
+
+    fn... set (self, name : Symbol, value : Argument)
+        'set self.symbols name value
+    fn... get (self, name : Symbol)
+        loop (self = self)
+            try
+                break ('get self.symbols name)
+            else
+                repeat
+                    try (('unwrap self.parent) as this-type)
+                    else
+                        error
+                            .. "no such bound name: " (repr name)
+
+    fn fork (parent)
+        RcBindings (copy parent)
+
+""""CCVM instruction
+struct Instruction
+    next : Argument = (Argument.undefined)
+    args : (Array Argument)
+    ret : Argument = (Argument.undefined)
+    retctx : (Array Argument)
+
+    fn __repr (self)
+        let s =
+            fold (s = (repr self.next)) for arg in self.args
+                .. s " " (repr arg)
+        dispatch self.ret
+        case undefined () s
+        default
+            fold (s = (.. s " -> " (repr self.ret))) for arg in self.retctx
+                .. s " " (repr arg)
+
+""""CCVM program
+struct Program
+    instrs : (Array Instruction) # id = index + userlabel
+    start : Label
+
+    cache :
+        Map (tuple Argument (Array Argument)) Label
+            fn (value)
+                let next args = (unpack value)
+                fold (h = (hash next)) for arg in args
+                    hash h arg
+
+    fn index->label (i)
+        (Builtins.userlabel as integer + i) as Label
+
+    fn label->index (label)
+        label - Builtins.userlabel as integer
+
+    fn... next-label-id (self)
+        index->label (countof self.instrs)
+
+    fn tocondbr (self)
+        # find cond labels and change them to condbr
+        let count = (countof self.instrs)
+        let cond_builtin = (Argument.label Builtins.cond)
+        let condbr_builtin = (Argument.label Builtins.condbr)
+
+        for i in (range count)
+            instr := self.instrs @ i
+            if (instr.next != cond_builtin)
+                continue;
+            let ret = (copy instr.ret)
+
+            let then_label = ('next-label-id self)
+            let then_instr = ('append self.instrs (Instruction))
+            then_instr.next = (copy ret)
+            let then_value = (copy (instr.args @ 1))
+            'append then_instr.args then_value
+
+            let else_label = ('next-label-id self)
+            let else_instr = ('append self.instrs (Instruction))
+            else_instr.next = (copy ret)
+            let else_value = (copy (instr.args @ 2))
+            'append else_instr.args else_value
+
+            instr.next = (copy condbr_builtin)
+            instr.ret = (Argument.undefined)
+            instr.args @ 1 = (Argument.label then_label)
+            instr.args @ 2 = (Argument.label else_label)
+            ;
+
+    fn singleuserpull (self)
+        # pull labels that produce values used by only one site close to that site
+
+        # LE -> LD -> LC, LB refs LC.x*
+        #   if LB is only user of LC vars, generated by LD,
+        #       and LB != LC and LB provides no vars
+        #       we need to repoint LD to LB, and LE skips LD to reach LC directly
+        #   LD = pred(LC)
+        #   LE = pred(LD)
+        # if condbr?(LC)
+        #   and LB is only user of its var
+        #   and count(pred(LC)) == 1
+        # then
+        #   replaceret(LE, LD -> LC) # fix route
+        #   replacevars(*, LD -> LC) # fix var
+        #   replaceret(LD, LC -> LB) # fix route
+        #   replacevars(LB, LC -> LB) # fix var
+        #   replacelabels(pred(LB), LB -> LD) # fix route
+
+    fn optimize (self)
+        'tocondbr self
+        'singleuserpull self
+
+    fn... fill-label (self, next : Argument, args : (Array Argument), ret : Argument)
+        let instr = ('last self.instrs)
+        dispatch instr.next
+        case undefined ()
+            instr.next = next
+            instr.args = args
+            instr.ret = ret
+        default
+            assert false "append instruction is non-empty"
+
+    fn... make-label (self, next : Argument, args : (Array Argument))
+        let key = (tupleof (copy next) (copy args))
+        let index_dest =
+            try
+                copy ('get self.cache (view key))
+            else
+                let index_dest = ((Builtins.userlabel as integer + (countof self.instrs)) as Label)
+                'fill-label self next args (Argument.label index_dest)
+                'append self.instrs
+                    Instruction;
+                'set self.cache key index_dest
+                index_dest
+        Argument.fxall index_dest 0
+
+    fn... eval-do (self, env : RcBindings, args : list)
+        returning (uniqueof Argument -1)
+        raising Error
+        local newenv = (Bindings.fork env)
+        let lastindex = ((countof args) - 1)
+        local return_expr : (Array Argument)
+        for i expr in (enumerate args usize)
+            if (('typeof expr) == list)
+                let head expr = (decons (expr as list))
+                let head2 = (decons expr)
+                if (('typeof head) == Symbol)
+                    head as:= Symbol
+                    if (head == 'let) # (let name body ...)
+                        let name expr = (decons expr)
+                        'set newenv (name as Symbol)
+                            'getarg ('eval-do self newenv expr)
+                        continue;
+                    elseif (head == 'let@) # (let@ name ... expr)
+                        print "todo: let@"
+                        continue;
+                    elseif (head == 'let:) # (let: name ... expr)
+                        print "todo: let:"
+                        continue;
+                    elseif (((head == 'fn) or (head == 'macro))
+                        and (('typeof head2) == Symbol)) # (fn|macro name ...)
+                        print "todo: fn"
+                        continue;
+            let result =
+                'eval self newenv expr
+            'append result return_expr (i == lastindex)
+        Argument.from-args return_expr
+
+    fn... eval-builtin-call (self, head_value, id : Label, args : (Array Argument))
+        let next = (Argument.label id)
+        switch id
+        pass Builtins.cond
+        pass Builtins.defined?
+        pass Builtins.==
+        pass Builtins.!=
+        pass Builtins.>
+        pass Builtins.>=
+        pass Builtins.<
+        pass Builtins.<=
+        pass Builtins.+
+        pass Builtins.-
+        pass Builtins.*
+        pass Builtins./
+        pass Builtins.//
+        pass Builtins.%
+        pass (getattr Builtins '..)
+        pass Builtins.get
+        pass Builtins.set
+        pass Builtins.cell
+        pass Builtins.totext
+        do
+            return
+                'make-label self next args
+        default;
+        error
+            .. "can not apply builtin: " (repr head_value)
+
+    fn... eval (self, env : RcBindings, expr_value : Value)
+        viewing env expr_value
+        returning (uniqueof Argument -1)
+        raising Error
+        let T = ('typeof expr_value)
+        try
+            if (T == Symbol)
+                let sym = (expr_value as Symbol)
+                return (copy ('get env sym))
+            elseif (T == list)
+                let expr = (expr_value as list)
+                let head_value expr = (decons expr)
+                let head = ('eval self env head_value)
+                dispatch head
+                case label (id)
+                    if (id < Builtins.userlabel)
+                        id as:= Builtins
+                        switch id
+                        case Builtins.do
+                            return ('eval-do self env expr)
+                        case Builtins.quote
+                            let value = (decons expr)
+                            return (Argument.const (Atom.from-value value))
+                        case (getattr Builtins ':)
+                            let key expr = (decons expr)
+                            let value = ('getarg ('eval-do self env expr))
+                            return (Argument.keyed (key as Symbol) (Rc.wrap value))
+                        default
+                            local args : (Array Argument)
+                            let lastindex = ((countof expr) - 1)
+                            for i arg in (enumerate expr usize)
+                                'append
+                                    'eval self env arg
+                                    \ args (i == lastindex)
+                            return ('eval-builtin-call self head_value id args)
+                    else
+                        print "label" id
+                default
+                    error
+                        .. "unhandled expression: " (repr expr_value)
+        except (err)
+            hide-traceback;
+            error@+ err ('anchor expr_value) "while expanding"
+        return
+            Argument.const
+                Atom.from-value expr_value
+        #error
+            .. "unhandled token: " (repr expr_value)
+
+    """"transcode to CCVM representation
+    fn... from-expr (self, expr : list)
+        let userlabel = (Builtins.userlabel as integer)
+        local env : RcBindings
+        'set env 'false (Argument.const (Atom false))
+        'set env 'true (Argument.const (Atom true))
+        va-map
+            inline (field)
+                let name = field.Name
+                let index = field.Index
+                static-if (index != userlabel)
+                    'set env name (Argument.label field.Index)
+            Builtins.__fields__
+        'set env 'sugar-quote (copy ('get env 'quote))
+        let label_start = ('next-label-id self)
+        'append self.instrs
+            Instruction;
+        va-map
+            inline (field)
+                let name = field.Name
+                let index = field.Index
+                'set env name (Argument.fx label_start field.Index)
+            Inputs.__fields__
+        let result = ('eval self env expr)
+        local args : (Array Argument)
+        'append args result
+        'fill-label self
+            Argument.fret label_start
+            args
+            ret = (Argument.undefined)
+        'optimize self
+
+    fn debug-dump (self)
+        for i instr in (enumerate self.instrs)
+            id := Builtins.userlabel as integer + i
+            print (.. "L" (tostring id) ":") (repr instr)
+        #instrs : (Array Instruction) # id = index + userlabel
+        #start : Label
+
+do
+    let Program
+
+    locals;

          
M lib/tukan/uvm.sc +14 -5
@@ 164,17 164,20 @@ type Number :: (storageof bf_t)
         bf_get_float64 self &outp bf_rnd_t.BF_RNDN
         outp
 
+    fn integer? (self)
+        ('floor self) == self
+
     fn toindex32 (self)
         if (self >= 0)
             if (self <= 0x7fffffff:i32)
-                if (('floor self) == self)
+                if ('integer? self)
                     return ((toi32 self) as u32)
         raise;
 
     fn toindex (self)
         if (self >= 0)
             if (self <= 0x7fffffffffffffff:i64)
-                if (('floor self) == self)
+                if ('integer? self)
                     return ((toi64 self) as u64)
         raise;
 

          
@@ 447,10 450,12 @@ struct Cell
         digest
 
     @@ memo
-    inline gen-each-index (f)
+    inline gen-each-index (f errorT)
         fn process (table ...)
             fn recur (node depth index ...)
                 returning void
+                static-if (not (none? errorT))
+                    raising errorT
                 dispatch node
                 case CellLimb (limb)
                     let maxindex = (depth-maxindex depth)

          
@@ 468,10 473,12 @@ struct Cell
             recur table.ivalues table.depth 0:u64 ...
 
     @@ memo
-    inline gen-each-index-reverse (f)
+    inline gen-each-index-reverse (f errorT)
         fn process (table ...)
             fn recur (node depth index ...)
                 returning void
+                static-if (not (none? errorT))
+                    raising errorT
                 dispatch node
                 case CellLimb (limb)
                     let maxindex = (depth-maxindex depth)

          
@@ 489,10 496,12 @@ struct Cell
             recur table.ivalues table.depth 0:u64 ...
 
     @@ memo
-    inline gen-each-pair (f)
+    inline gen-each-pair (f errorT)
         fn process (table ...)
             fn recur (key value ...)
                 returning void
+                static-if (not (none? errorT))
+                    raising errorT
                 dispatch key
                 case CellLimb (klimb)
                     dispatch value

          
A => testing/test_ccvm.sc +40 -0
@@ 0,0 1,40 @@ 
+import ..lib.tukan.use
+using import tukan.ccvm
+
+local prog : Program
+'from-expr prog
+    sugar-quote
+        do
+            let exit?
+                cond (defined? readline)
+                    == "\n" readline
+                    false
+            let state
+                cond (defined? state) state
+                    cell
+                        : meta
+                            cell
+                                : class "state"
+                        : index 0
+            cond exit?
+                cell
+                    : exit 0
+                    : stdout "exiting...\n"
+                    : state state
+                do
+                    let state
+                        cond (defined? readline)
+                            set state 'index (+ (get state 'index) 1)
+                            state
+                    cell
+                        : block-break true
+                        : prompt
+                            .. (totext (get state 'index)) "> "
+                        : stdout
+                            cond (defined? break)
+                                "enter empty line to exit\n"
+                                readline
+                        : state state
+'debug-dump prog
+
+;

          
A => testing/test_tuk2dag.sc +594 -0
@@ 0,0 1,594 @@ 
+using import struct
+using import enum
+using import itertools
+using import Array
+using import String
+using import Rc
+using import Map
+
+import ..lib.tukan.use
+using import tukan.uvm
+
+global mt_builtin : Atom =
+    Cell.new
+        type = 'builtin
+global mt_input : Atom =
+    Cell.new
+        type = 'input
+global mt_variadic : Atom =
+    Cell.new
+        type = 'variadic
+global mt_param : Atom =
+    Cell.new
+        type = 'param
+global mt_closure : Atom =
+    Cell.new
+        type = 'closure
+global mt_keyed : Atom =
+    Cell.new
+        type = 'keyed
+global mt_call : Atom =
+    Cell.new
+        type = 'call
+global mt_quote : Atom =
+    Cell.new
+        type = 'quote
+
+let global-env builtins inputs =
+    do
+        inline bind-scope-env-symbols (env mt names)
+            fold (scope env = (Scope) env) for name in names
+                sym := (Atom (name as Symbol))
+                code := ('hashbits sym)
+                _
+                    'bind scope name `code
+                    'set env sym
+                        'set-meta
+                            Cell.new (copy sym)
+                            copy mt
+
+        let builtins env =
+            bind-scope-env-symbols (Cell) mt_builtin
+                sugar-quote unknown unreachable + - * / // % & | ^ fn quote set get
+                    \ nextindex < <= > >= == != : not dump totext .. cond setmeta
+                    \ getmeta macro eval maptext tou32 tof32 floor sqrt fold do cell
+                    \ sin cos map kindof defined? condbr arg funcdef
+
+        let env = ('set env 'sugar-quote (copy ('get env 'quote)))
+
+        let inputs env =
+            bind-scope-env-symbols env mt_input
+                sugar-quote setup screensize iteration state break close readline \
+                    samplerate samplecount
+
+        let env = ('set env 'false false)
+        let env = ('set env 'true true)
+
+        let env = ('set env 'globals (copy env))
+
+        _ env builtins inputs
+
+global global-env : Atom = global-env
+
+run-stage;
+
+let original =
+    sugar-quote
+        do
+            let exit?
+                cond (defined? readline)
+                    == "\n" readline
+                    false
+            let state
+                cond (defined? state) state
+                    cell
+                        : meta
+                            cell
+                                : class "state"
+                        : index 0
+            cond exit?
+                cell
+                    : exit 0
+                    : stdout "exiting...\n"
+                    : state state
+                do
+                    let state
+                        cond (defined? readline)
+                            set state 'index (+ (get state 'index) 1)
+                            state
+                    cell
+                        : block-break true
+                        : prompt
+                            .. (totext (get state 'index)) "> "
+                        : stdout
+                            cond (defined? break)
+                                "enter empty line to exit\n"
+                                readline
+                        : state state
+
+fn array->cell (args)
+    viewing args
+    fold (l = (Cell)) for arg in args
+        'append l (copy arg)
+fn array->arglist (args)
+    viewing args
+    if ((countof args) == 1)
+        return (copy ('last args))
+    else
+        Atom
+            'set-meta
+                array->cell args
+                copy mt_variadic
+
+fn getarg (value index)
+    viewing value
+    dispatch value
+    case Cell (cell)
+        if (('get-meta cell) == mt_variadic)
+            return (copy ('get cell index))
+    default;
+    if (index == 0)
+        copy value
+    else
+        (Atom) # none
+
+inline getmeta (value)
+    dispatch value
+    case Cell (cell)
+        copy ('get-meta cell)
+    default
+        (Atom)
+
+inline ismeta? (value mt)
+    dispatch value
+    case Cell (cell)
+        ('get-meta cell) == mt
+    default
+        false
+
+fn argcount (value)
+    viewing value
+    if (ismeta? value mt_variadic)
+        'next-index (value as Cell)
+    else
+        1:u64
+
+fn append-arg (self return_expr last_arg?)
+    viewing self return_expr
+    if last_arg?
+        for i in (range (argcount self))
+            'append return_expr (getarg self i)
+    else
+        'append return_expr (getarg self 0)
+    ;
+
+#
+    common subexpression elimination during codegen:
+
+    if for any variadic list, argument list or cond branch pair, there are
+    common subexpressions between them, they need to be generated first -
+    recursively.
+
+    for fold/map functions, every expression not depending on an input argument
+    is going to be executed multiple times, and so must be moved in front of the
+    fold operation
+
+#
+    type specialization:
+
+    do a DFS type inference first, collecting properties of types as they build
+
+#
+    present kinds
+
+    none
+    bool
+    string
+    number
+    cell
+
+    reduced kinds
+
+    none
+    bit[N]
+        bool: bit[1] as 1-bit integer - or just bit.
+            operations:
+                * cond
+        number:
+            bit[N] for N-bit integers
+            operations:
+                * add
+                * sub
+                * mul
+                * div
+                * rem
+                * and
+                * or
+                * xor
+            bit[32 | 64] for floats and doubles
+            operations:
+                * fadd
+                * fsub
+                * fmul
+                * fdiv
+                * frem
+                * various transcendental functions
+    bit[V][N]
+        bool vector: bit[v][1]
+        number:
+            bit[V][N] for N-bit integer vectors
+            bit[V][32 | 64] for float and double vectors
+        string: bit[V][8] for strings
+            operations:
+                * slice x i1 i2
+                * join a b
+        factorial packings:
+            bit[32] converts to
+                bit[2][16]
+                bit[4][8]
+            and vice versa, and so on
+    these require constant V=1..4 and N=8,16,32:
+        bit[W][V][N] for arrays of vectors
+        bit[H][W][V][N] for 2d images
+        bit[D][H][W][V][N] for 3d images
+            bit[D][H][W][4][8] for RGBA8 layer/volume textures
+        all three support special sampling methods
+    cell
+        in the abstract, this is a sparse, polymorphic bit[inf]... in which
+        at the first level, any other bit array can be used as key; in an
+        implementation, the key is hashed to keep the key size constant.
+        the depth of the bit array after this point is arbitrary and depends
+        on the provided key.
+
+    bit-array reduction:
+
+    (bit[x][y]...)[k] = bit[y]...
+
+let NodeId = u64
+let IndexMask = u8
+
+enum Node
+let RcNode = (Rc Node)
+
+enum Node
+    empty
+    const : Atom
+    op : (array NodeId 4)
+
+struct NodeDAG
+    let NodeUserMap = (Map NodeId IndexMask)
+    nodes : (Map NodeId RcNode)
+    users : (Map NodeId NodeUserMap)
+    next-id : NodeId = 0
+
+    fn new-id (self)
+        let next-id = self.next-id
+        let id = (copy next-id)
+        next-id += 1
+        id
+
+    fn... connect-sources (self, id : NodeId, node : RcNode)
+        viewing node
+        let users = self.users
+        dispatch (node as Node)
+        case op (args)
+            for i arg in (enumerate args IndexMask)
+                let mask = ((IndexMask 1) << i)
+                try
+                    let srcusers = ('get users arg)
+                    'set srcusers id
+                        | mask
+                            try (copy ('get srcusers id))
+                            else (IndexMask)
+                    ;
+                else
+                    local srcusers : NodeUserMap
+                    'set srcusers id mask
+                    'set users arg (deref srcusers)
+                    ;
+        default;
+
+    fn... disconnect-sources (self, id : NodeId, node : RcNode)
+        viewing node
+        let users = self.users
+        dispatch (node as Node)
+        case op (args)
+            for i arg in (enumerate args IndexMask)
+                let mask = (~ ((IndexMask 1) << i))
+                try
+                    let srcusers = ('get users arg)
+                    'discard srcusers id
+                    ;
+                else;
+        default;
+
+    fn... replace-users (self, id : NodeId, newid : NodeId)
+        let nodes = self.nodes
+        let users = self.users
+        let srcusers =
+            try ('pop users id)
+            else
+                return;
+        for snkid mask in srcusers
+            let node =
+                try ('get nodes snkid)
+                else
+                    continue;
+            dispatch node
+            case op (args)
+                for i in (iterbits mask)
+                    args @ i = newid
+            default;
+        if newid
+            'set users newid srcusers
+
+    fn... disconnect-users (self, id : NodeId)
+        'replace-users self id (NodeId 0)
+        ;
+
+    fn... insert (self, node : RcNode)
+        let id = ('new-id self)
+        'connect-sources self id node
+        'set self.nodes id node
+        id
+    case (self, node : Node)
+        this-function self (Rc.wrap node)
+
+    fn... replace (self, id : NodeId, node : RcNode)
+        let nodes = self.nodes
+        let oldnode =
+            try ('pop nodes id)
+            else
+                return;
+        'disconnect-sources self id oldnode
+        'set nodes id node
+        'connect-sources self id node
+
+    fn... remove (self, id : NodeId)
+        let node =
+            try ('get self.nodes id)
+            else
+                return;
+        'disconnect-sources self id node
+        'disconnect-users self id
+        'discard self.nodes id
+        ;
+
+
+do
+    local dag : NodeDAG
+
+    'remove dag
+        'insert dag (Node.empty)
+
+    ;
+
+
+struct Tuk2DAG
+    struct Context
+        env : Atom
+        closure-def : Atom
+
+        fn __copy (self)
+            this-type
+                env = (copy self.env)
+                closure-def = (copy self.closure-def)
+
+    fn... eval-do (self, ctx : Context, args : list)
+        viewing ctx
+        returning (uniqueof Atom -1)
+        raising Error
+        local newenv = (copy ctx.env)
+        let lastindex = ((countof args) - 1)
+        local return_expr : (Array Atom)
+        for i expr in (enumerate args usize)
+            if (('typeof expr) == list)
+                let head expr = (decons (expr as list))
+                let head2 = (decons expr)
+                if (('typeof head) == Symbol)
+                    head as:= Symbol
+                    if (head == 'let) # (let name body ...)
+                        let name expr = (decons expr)
+                        name as:= Symbol # verify
+                        local ctx = (copy ctx)
+                        ctx.env = (copy newenv)
+                        newenv =
+                            'set (newenv as Cell) name
+                                getarg ('eval-do self (deref ctx) expr) 0
+                        continue;
+                    elseif (head == 'let@) # (let@ name ... expr)
+                        print "todo: let@"
+                        continue;
+                    elseif (head == 'let:) # (let: name ... expr)
+                        print "todo: let:"
+                        continue;
+                    elseif ((head == 'fn)
+                        and (('typeof head2) == Symbol)) # (fn|macro name ...)
+                        let name expr = (decons expr)
+                        name as:= Symbol # verify
+                        local ctx = (copy ctx)
+                        ctx.env = (copy newenv)
+                        newenv =
+                            'set (newenv as Cell) name
+                                getarg ('eval-fn self (deref ctx) expr) 0
+                        continue;
+            local ctx = (copy ctx)
+            ctx.env = (copy newenv)
+            let result =
+                'eval self (deref ctx) expr
+            append-arg result return_expr (i == lastindex)
+        return (array->arglist return_expr)
+
+    fn make-param (i level)
+        'set-meta
+            if (level == 0)
+                Cell.new i
+            else
+                Cell.new i level
+            copy mt_param
+
+    fn... eval-fn (self, ctx : Context, args : list)
+        viewing ctx
+        returning (uniqueof Atom -1)
+        raising Error
+        local newenv = (copy ctx.env)
+        let params body = (decons args)
+        params as:= list
+        let paramcount = ((countof params) as i32)
+        let level = ('next-index (ctx.closure-def as Cell))
+        for i param in (enumerate params)
+            param as:= Symbol
+            newenv =
+                'set (newenv as Cell) param (make-param i level)
+        let closure-def = ('append (ctx.closure-def as Cell) paramcount)
+        local ctx = (copy ctx)
+        ctx.env = newenv
+        ctx.closure-def = (copy closure-def)
+        Atom
+            'set-meta
+                Cell.new closure-def
+                    'eval-do self ctx body
+                copy mt_closure
+
+    fn... eval-call (self, ctx : Context, func : Atom, args : (Array Atom))
+        returning (uniqueof Atom -1)
+        raising Error
+        func as:= Cell
+        let params = ('get-index func 0)
+        let body = ('get-index func 1)
+        let paramcount = (('get (params as Cell) 0) as Number as integer)
+        let level = (('next-index (params as Cell)) - 1)
+        local newenv = (copy ctx.env)
+        for i arg in (enumerate args)
+            let paramdef = (make-param i level)
+            newenv =
+                'set (newenv as Cell) paramdef (copy arg)
+        local ctx = (copy ctx)
+        ctx.env = newenv
+        'remap self ctx body
+
+    fn... remap (self, ctx : Context, value : Atom)
+        returning (uniqueof Atom -1)
+        raising Error
+        let key = ('get (ctx.env as Cell) value)
+        if (not ('none? key))
+            return key
+        dispatch value
+        case Cell (cell)
+            let mt = ('get-meta cell)
+            match mt
+            case mt_call
+                value as:= Cell
+                let head = ('get-index value 0)
+                let head = ('remap self ctx head)
+                let callargs = (('get-index value 1) as Cell)
+                local args : (Array Atom)
+                let argcount = ('next-index callargs)
+                let lastindex = (argcount - 1)
+                for i in (range argcount)
+                    append-arg
+                        'remap self ctx ('get-index callargs i)
+                        \ args (i == lastindex)
+                return
+                    Atom
+                        'set-meta
+                            Cell.new head (array->cell args)
+                            copy mt_call
+            case mt_builtin (return (copy value))
+            case mt_param (return (copy value))
+            case mt_variadic
+                value as:= Cell
+                local args : (Array Atom)
+                let argcount = ('next-index value)
+                let lastindex = (argcount - 1)
+                for i in (range argcount)
+                    append-arg
+                        'remap self ctx ('get-index value i)
+                        \ args (i == lastindex)
+                return (array->arglist args)
+            case mt_closure
+                value as:= Cell
+                let params = ('get-index value 0)
+                let body = ('get-index value 1)
+                let body = ('remap self ctx body)
+                return
+                    Atom
+                        'set-meta
+                            Cell.new params body
+                            copy mt_closure
+            default;
+        default
+            return (copy value)
+        error
+            .. "unhandled remap: " (('tostring value) as string)
+
+    fn... eval (self, ctx : Context, expr_value : Value)
+        viewing ctx
+        returning (uniqueof Atom -1)
+        raising Error
+        let T = ('typeof expr_value)
+        try
+            if (T == Symbol)
+                return ('get (ctx.env as Cell) (expr_value as Symbol))
+            elseif (T == list)
+                let expr = (expr_value as list)
+                let head_value expr = (decons expr)
+                let head = (getarg ('eval self ctx head_value) 0)
+                if (ismeta? head mt_builtin)
+                    id := ('hashbits ('get (head as Cell) 0))
+                    switch id
+                    case builtins.do
+                        return ('eval-do self ctx expr)
+                    case builtins.quote
+                        let value expr = (decons expr)
+                        return
+                            Atom
+                                'set-meta
+                                    Cell.new (Atom.from-value value)
+                                    copy mt_quote
+                    case builtins.fn
+                        return ('eval-fn self ctx expr)
+                    case (getattr builtins ':)
+                        let key expr = (decons expr)
+                        key as:= Symbol
+                        let value = (getarg ('eval-do self ctx expr) 0)
+                        return
+                            Atom
+                                'set-meta
+                                    Cell.new key value
+                                    copy mt_keyed
+                    default;
+                local args : (Array Atom)
+                let lastindex = ((countof expr) - 1)
+                for i arg in (enumerate expr usize)
+                    append-arg
+                        'eval self ctx arg
+                        \ args (i == lastindex)
+                if (ismeta? head mt_closure)
+                    # function application
+                    return ('eval-call self ctx head args)
+                else
+                    return
+                        Atom
+                            'set-meta
+                                Cell.new head (array->cell args)
+                                copy mt_call
+                #error
+                    .. "unhandled expression: " (repr expr_value)
+        except (err)
+            hide-traceback;
+            error@+ err ('anchor expr_value) "while expanding"
+        return (Atom.from-value expr_value)
+
+    fn... from-expr (self, expr : list)
+        let env = (copy global-env)
+        let ctx =
+            Context
+                env = env
+                closure-def = (Atom (Cell))
+        'eval self ctx expr
+
+local t2d : Tuk2DAG
+print
+    'tostring
+        'from-expr t2d original

          
M testing/tuk_interpreter.sc +1 -0
@@ 88,6 88,7 @@ global KEY_SAMPLECOUNT = (Atom 'sampleco
 global KEY_SOUND = (Atom 'sound)
 
 fn run (argc argv program opts)
+
     #
         BASIC
         =====