10072c1dcdaa — Leonard Ritter 21 days ago
* more work on UVM, logregion
3 files changed, 1563 insertions(+), 19 deletions(-)

A => testing/logregion.sc
A => testing/test_node3.sc
M testing/test_node4.sc
A => testing/logregion.sc +126 -0
@@ 0,0 1,126 @@ 
+
+#   logregion
+
+    An encoding of 2**n sized regions that allows addressing 2**31/2**63 units
+    with a single 32-bit/64-bit value, provided the address is size-aligned.
+    In this format, we encode size and offset (which must be a multiple of size)
+    as ((offset << 1) | size). Then size(addr) = addr & -addr and offset(addr)
+    = (addr ^ size(addr)) >> 1. Zero can still be used as a null value.
+
+    The final partitioning resembles a binary subdivision; when regions are
+    ordered by decreasing size, the packing will be gapless.
+
+""""round x to the next highest power of 2
+inline... alignsize (x : u32)
+    x := x - 1
+    x := x | x >> 1
+    x := x | x >> 2
+    x := x | x >> 4
+    x := x | x >> 8
+    x := x | x >> 16
+    x + 1
+case (x : u64)
+    x := x - 1
+    x := x | x >> 1
+    x := x | x >> 2
+    x := x | x >> 4
+    x := x | x >> 8
+    x := x | x >> 16
+    x := x | x >> 32
+    x + 1
+
+""""extract the highest bit from x (round x to the next lowest power of 2)
+inline msbbit (x)
+    x := x | x >> 1
+    x := x | x >> 2
+    x := x | x >> 4
+    x := x | x >> 8
+    x := x | x >> 16
+    x & ((x >> 1) + 1)
+
+inline alignoffsetu (offset align)
+    """"align `offset` up to `align`, which must be a power of 2
+    (offset + align - 1) & -align
+
+inline alignoffsetd (offset align)
+    """"align `offset` down to `align`, which must be a power of 2
+    offset & -align
+
+inline encaddr (offset size)
+    """"encode an address from `offset` and `size`, where `size` is a power
+        of 2, and offset is aligned by size. If the range doesn't fit into
+        the maximum partition, the result is undefined.
+    (offset << 1) | size
+
+fn encaddrun (offset size)
+    """"encode an address from an arbitrary `offset` and `size`, which are
+        aligned and rounded to the next highest partition that fits the
+        requested range.
+        If the resulting range doesn't fit into the maximum partition, the result
+        is undefined.
+    size := (alignsize size)
+    encaddr (alignoffsetu offset size) size
+
+fn encaddrrangeun (lhs rhs)
+    """"encode an address from an arbitrary range `lhs` (inclusive) and `rhs`
+        (exclusive), which are aligned and rounded to a partition that wraps the
+        requested range.
+        If the resulting range doesn't fit into the maximum partition, the
+        result is undefined.
+    assert (rhs > lhs)
+    # highest changing bit in inclusive range
+    blocksize := (max (1 as (typeof rhs)) (msbbit (lhs ^ (rhs - 1))))
+    _lhs := (alignoffsetd lhs blocksize)
+    _rhs := (alignoffsetu rhs blocksize)
+    size := (_rhs - _lhs)
+    encaddr _lhs size
+
+inline decaddr (addr)
+    """"decode offset and size from a provided `addr` that was previously
+        encoded with `encaddr`.
+    size := addr & -addr
+    _ ((addr ^ size) >> 1) size
+
+if main-module?
+    # 0:u32
+    print
+        decaddr 0:u32
+
+    # 113280:u32 128:u32
+    print
+        decaddr
+            encaddrun 113241:u32 100:u32
+
+    print
+        decaddr
+            encaddrun 7:u32 1:u32
+
+    for o in (range 12345:u32)
+        for s in (range 1:u32 12345:u32)
+            let lhs rhs = o (o + s)
+            let ro rs =
+                decaddr
+                    encaddrrangeun lhs rhs
+            let lhs2 rhs2 = ro (ro + rs)
+            assert ((lhs2 <= lhs) & (rhs2 >= rhs))
+
+    # 2044:u32 4:u32
+    print
+        decaddr
+            encaddrrangeun 2045:u32 2048:u32
+
+    # 113152:u32 256:u32
+    print
+        decaddr
+            encaddrrangeun 113241:u32 (113241:u32 + 100:u32)
+
+    # 8388608:u64 8388608:u64
+    print
+        decaddr
+            encaddrun 54321:u32 (1920:u32 * 1080 * 4)
+
+do
+    let encaddr encaddrun encaddrrangeun decaddr alignoffsetu alignoffsetd
+        \ alignsize
+
+

          
A => testing/test_node3.sc +1311 -0
@@ 0,0 1,1311 @@ 
+
+using import enum
+using import struct
+using import Rc
+using import Option
+using import Array
+using import Map
+using import Set
+using import String
+using import testing
+using import itertools
+using import UTF-8
+
+""""two-dimensional entry of expressions
+
+    Usage:
+
+        :::scopes
+        2d print    'X0 'X1 'X2
+            -------------------
+            'Y0     1   2   3
+            'Y1     4   5   6
+            'Y2     7   8   9
+
+    Will expand to:
+
+        :::scopes
+        embed
+            print 'X0 'Y0 1; print 'X1 'Y0 2; print 'X2 'Y0 3
+            print 'X0 'Y1 4; print 'X1 'Y1 5; print 'X2 'Y1 6
+            print 'X0 'Y2 7; print 'X1 'Y2 8; print 'X2 'Y2 9
+sugar 2d (f args...)
+    let header rest =
+        loop (header rest = '() args...)
+            if (empty? rest)
+                error "-* expected"
+            let arg rest = (decons rest)
+            if (('typeof arg) == Symbol)
+                let s = (arg as Symbol as string)
+                if ((lslice s 1) == "-")
+                    break header rest
+            repeat
+                cons arg header
+                rest
+    let numcolumns = (countof header)
+    let reversed_header = ('reverse header)
+    cons embed
+        'reverse
+            fold (result = '()) for row in rest
+                let y z-entries = (decons (row as list))
+                fold (result = result) for z x in
+                    zip z-entries reversed_header
+                    cons ('tag `[(list f x y z)] ('anchor z)) result
+
+sugar makevisitor (s)
+    if (('typeof s) == string)
+        spice-quote
+            inline "visit" (cls visitor)
+                spice-unquote
+                    let expr = (sc_expression_new)
+                    str := s as string
+                    for i c in (enumerate str)
+                        let op =
+                            switch c
+                            case (char "*") # ignore
+                                continue;
+                            case (char "u") `(visitor.visit-i32)
+                            case (char "b") `(visitor.visit-bool)
+                            case (char "@") `(visitor.visit-id)
+                            case (char "s") `(visitor.visit-string)
+                            case (char "I") `(visitor.visit-input)
+                            case (char "O") `(visitor.visit-output)
+                            default
+                                local c = c
+                                hide-traceback;
+                                error@
+                                    sc_anchor_offset ('anchor s) (i + 1)
+                                    "while parsing signature"
+                                    .. "unknown signature token: "
+                                        string (& c) 1
+                        let op =
+                            switch (str @ (i + 1))
+                            case (char "*")
+                                `(for i in (visitor.oprange) op)
+                            default op
+                        sc_expression_append expr op
+                    expr
+
+    else s
+
+# enumerate the bit indices of integer
+inline... iterbits (value : integer)
+    let zero = (0 as (typeof value))
+    let bit = (1 as (typeof value))
+    let eob = (-1 as (typeof value))
+    Generator
+        inline () (findlsb value)
+        inline (pos) (pos != eob)
+        inline (pos) pos
+        inline (pos)
+            pos := pos + bit
+            ofs := (findlsb (lshr value pos))
+            ? (ofs == eob) ofs (pos + ofs)
+
+run-stage;
+
+sugar defnode (attr name value)
+    #vvv report
+    switch (attr as Symbol)
+    case 'super
+        qq type [name] < [value]
+    case 'signature
+        list ''define-symbol name ''visit #(list sugar-quote attr)
+            'tag `[(list makevisitor value)] ('anchor value)
+    default
+        if
+            and (('typeof value) == Symbol)
+                (value as Symbol == '-)
+            '()
+        else
+            qq 'define-symbol [name] '[attr] [value]
+
+spice va-each-key (scope f)
+    scope as:= Scope
+    let expr = (sc_expression_new)
+    for k v in scope
+        sc_expression_append expr ('tag `(f k v) ('anchor k))
+    expr
+
+spice va-switch-case (scope enum-type funcname cond defaultf ...)
+    scope as:= Scope
+    let sw = (sc_switch_new cond)
+    for k v in scope
+        sc_switch_append_case sw
+            `(getattr enum-type k)
+            `((getattr v funcname) v ...)
+    sc_switch_append_default sw `(defaultf ...)
+    sw
+
+run-stage;
+
+let Id = u32
+
+let NoId = (Id 0)
+let NoType = NoId
+
+#
+    fundamental idea:
+        all processing flow organized around single I/O wait blackbox,
+        therefore purely functional
+
+    sync options:
+
+    sequencer pattern that repeats in custom unit of time?
+
+    supply audio frames
+        per sample
+        per N samples
+
+    supply video frames
+        per pixel
+        per full frame
+
+    supply network packets
+        per received packet
+        conditional source linked to periodic event?
+
+    supply filestream
+
+    always pull timecode from audio?
+
+    custom sync sources?
+        every N audio samples
+        every N video frames
+        every N nanoseconds
+        per input event
+        ?
+
+
+enum Input : u32
+    # TypeInt 32 false
+    Samplerate
+
+    # TypeVector (TypeInt 32 false) 2
+    ScreenSize
+
+    # TypeVector (TypeInt 32 false) 2
+    ScreenCoord
+
+    # TypeString
+    Readline
+
+    # TypeTuple
+    Setup
+
+enum Output : u32
+    # TypeVector (TypeReal 32) 2
+    Audio
+
+    # TypeVector (TypeReal 32) 4
+    Color
+
+    # TypeString
+    Stdout
+
+    # TypeString
+    Stderr
+
+    # TypeTuple
+    Exit
+
+    # TypeString
+    Prompt
+
+#
+    function definitions w. closure support:
+
+    Environment <parent-env>
+
+    Parameter <environment | previous-parameter>
+
+    Function <last-parameter> <value>
+
+    -- then --
+
+    fn outer (x y z)
+        fn inner (a b)
+            + x y z a b
+
+    -- translates to --
+
+    %1 = Environment NoId
+    %2 = Parameter %1
+    %3 = Parameter %2
+    %4 = Parameter %3
+    %5 = Environment %1
+    %6 = Parameter %5
+    %7 = Parameter %6
+    %8 = Add %2 %3 %4 %6 %7
+    %9 = Function %7 %8
+    %10 = Function %4 %9
+
+enum Op : u32
+struct Node
+
+struct Module
+
+type OpAny
+    inline visit (cls visitor)
+
+type OpType < OpAny
+
+type OpPure < OpAny
+
+type OpInstr < OpAny
+
+type OpControl < OpAny
+
+type OpConstant < OpPure
+    inline constant? (cls) true
+
+inline constsig (cls visitor)
+    switch (visitor.typeop)
+    case Op.TypeBool
+        visitor.visit-bool;
+    case Op.TypeInt
+        visitor.visit-i32;
+    case Op.TypeReal
+        visitor.visit-f32;
+    default;
+
+vvv bind OpDefs
+do
+    let _Input = Input
+    let _Output = Output
+    unlet Input Output
+
+    2d defnode              super       signature   eval
+        -------------------------------------------------------
+        TypeVoid            OpType      ""          -
+        TypeInt             OpType      "ub"        -
+        TypeBool            OpType      ""          -
+        TypeReal            OpType      "u"         -
+        TypeVector          OpType      "@u"        -
+        TypeArray           OpType      "@u"        -
+        TypeTuple           OpType      "@*"        -
+        TypeString          OpType      ""          -
+        Constant            OpConstant  constsig    -
+        ConstantComposite   OpConstant  "@*"        -
+        ConstantString      OpConstant  "s"         -
+        Undefined           OpPure      ""          -
+        Parameters          OpPure      "@"         -
+        Parameter           OpPure      "@u"        -
+        Function            OpPure      "@@"        -
+        Input               OpPure      "I"         -
+        Output              OpPure      "O"         -
+        State               OpPure      "@@"        -
+        Defined             OpPure      "@"         -
+        Merge               OpControl   "@@"        -
+        If                  OpControl   "@@@"       -
+        Body                OpControl   "@@"        -
+        Bind                OpInstr     "@@"        -
+        CompositeInsert     OpInstr     "@@u*"      -
+        CompositeConstruct  OpInstr     "@*"        -
+        ConvertIntToReal    OpInstr     "@"         -
+        ConvertRealToInt    OpInstr     "@"         -
+        Sin                 OpInstr     "@"         -
+        Cos                 OpInstr     "@"         -
+        FAdd                OpInstr     "@@"        -
+        FMul                OpInstr     "@@"        -
+        FDiv                OpInstr     "@@"        -
+        Equal               OpInstr     "@@"        -
+
+    unlet _Input _Output
+    locals;
+
+################################################################################
+
+enum Op
+    None = 0
+
+    va-each-key OpDefs
+        inline (name T)
+            tag name
+
+inline visit-node (code defaultf visitor)
+    va-switch-case OpDefs Op 'visit code defaultf visitor
+
+inline canonicalize-node (node)
+    va-switch-case OpDefs Op 'canonicalize node.opCode (inline ()) node
+
+################################################################################
+
+fn... append-operand (self, operand : Id)
+    'append self operand
+    ;
+case (self, text : String)
+    numbytes := (countof text)
+    let word =
+        fold (word = 0:u32) for i c in (enumerate text)
+            i0 := (i as u32 & 3:u32)
+            word := word | (c as u32 << (i0 * 8:u32))
+            if (i0 == 3:u32)
+                'append self word
+                0:u32
+            else word
+    'append self word
+    ;
+
+struct Node
+    opCode : Op
+    typeId : Id
+    operands : (Array Id)
+
+    fn __hash (self)
+        h := (hash self.opCode self.typeId)
+        fold (h = h) for operand in self.operands
+            hash h operand
+
+    fn __copy (self)
+        super-type.__typecall this-type
+            self.opCode
+            self.typeId
+            copy self.operands
+
+    fn getstring (self idx)
+        local text : String
+        let ops = self.operands
+        let count = ((countof self.operands) as i32)
+        label done
+            for idx in (range idx count)
+                let word = (ops @ idx)
+                for c in (range 4:u32)
+                    byte := (word >> (c * 8:u32)) as i8
+                    if (byte == 0:i8)
+                        merge done
+                    'append text byte
+        text
+
+    @@ memo
+    inline __== (cls T)
+        static-if (cls == T)
+            fn (a b)
+                and
+                    a.opCode == b.opCode
+                    a.typeId == b.typeId
+                    a.operands == b.operands
+
+    inline... __typecall
+    case (cls, opCode : Op, typeId : Id, ...)
+        super-type.__typecall cls opCode typeId
+            static-if (va-empty? ...) ()
+            else
+                local ops : (Array Id)
+                va-map
+                    inline (value)
+                        append-operand ops value
+                    ...
+                ops
+    case (cls, opCode : Op, typeId : Id, ...)
+        this-function cls NoId opCode typeId ...
+
+let RcNode = (Rc Node)
+
+################################################################################
+
+fn idstr (id)
+    if (id == 0) "none"
+    else
+        "%" .. (tostring id)
+
+################################################################################
+
+struct Module
+    nodes : (Array RcNode)
+    root : Id
+    # maps node specification to id
+    rnodes :
+        Map RcNode Id
+            fn (rcnode)
+                hash (rcnode as Node)
+    # cached select simplifications
+    select_cache : (Map (tuple Id Id Id) Id)
+    rnodes_valid = false
+
+    inline __typecall (cls)
+        local nodes : (Array RcNode)
+        'append nodes (RcNode Op.None NoType)
+        super-type.__typecall cls
+            nodes = nodes
+
+    fn rebuild-rnodes (self)
+        if self.rnodes_valid
+            return;
+        'clear self.rnodes
+        for id node in (enumerate self.nodes u32)
+            let oldid = ('getdefault self.rnodes node NoId)
+            if (oldid == NoId)
+                'set self.rnodes (copy node) id
+        self.rnodes_valid = true
+
+    fn... insert-node (self, node : RcNode)
+        let newid = ((countof self.nodes) as Id)
+        'append self.nodes (copy node)
+        'set self.rnodes node newid
+        copy newid
+
+    fn... nodeId
+    case (self, node : RcNode)
+        rebuild-rnodes self
+        let id = ('getdefault self.rnodes node NoId)
+        if (id == NoId)
+            insert-node self node
+        else (copy id)
+    case (self, node : Node)
+        rebuild-rnodes self
+        let id = ('getdefault self.rnodes node NoId)
+        if (id == NoId)
+            insert-node self (Rc.wrap (deref node))
+        else (copy id)
+
+    fn... integerType (self, width : i32, signed : bool)
+        'nodeId self
+            Node Op.TypeInt NoType
+                width as u32; signed as u32
+
+    fn... realType (self, width : i32)
+        'nodeId self
+            Node Op.TypeReal NoType
+                width as u32
+
+    fn boolType (self)
+        'nodeId self
+            Node Op.TypeBool NoType
+
+    fn voidType (self)
+        'nodeId self
+            Node Op.TypeVoid NoType
+
+    fn... vectorType (self, compId : Id, count : i32)
+        'nodeId self
+            Node Op.TypeVector NoType compId (count as u32)
+
+    fn... arrayType (self, elemId : Id, count : i32)
+        'nodeId self
+            Node Op.TypeArray NoType elemId (count as u32)
+
+    fn... tupleType (self, ...)
+        'nodeId self
+            Node Op.TypeTuple NoType ...
+
+    fn stringType (self)
+        'nodeId self
+            Node Op.TypeString NoType
+
+    fn... constInt (self, typeId : Id, value : u32)
+        'nodeId self
+            Node Op.Constant typeId value
+    case (self, value : i32)
+        this-function self ('integerType self 32 true) (value as u32)
+
+    fn... constUInt (self, value : u32)
+        'constInt self ('integerType self 32 true) value
+
+    fn... constFloat (self, typeId : Id, value : f32)
+        'nodeId self
+            Node Op.Constant typeId (bitcast value u32)
+    case (self, value : f32)
+        this-function self ('floatType self 32) value
+
+    fn... constBool (self, value : bool)
+        'nodeId self
+            Node Op.Constant ('boolType self) (value as u32)
+
+    fn... constString (self, value : String)
+        'nodeId self
+            Node Op.ConstantString ('stringType self) value
+
+    fn... constComposite (self, typeId : Id, ...)
+        'nodeId self
+            Node Op.ConstantComposite typeId ...
+
+    fn... constBang (self)
+        constComposite self (tupleType self)
+
+    fn... parameters (self, typeId : Id, parent : Id = NoId)
+        'nodeId self
+            Node Op.Parameters typeId parent
+
+    fn... function (self, typeId : Id, params : Id, value : Id)
+        'nodeId self
+            Node Op.Function typeId params value
+
+    fn... parameter (self, params : Id, index : u32)
+        typeId := ('getArg self ('getType self params) index)
+        'nodeId self
+            Node Op.Parameter typeId params index
+
+    fn... rawinput (self, typeId : Id, name : Input)
+        'nodeId self
+            Node Op.Input typeId name
+
+    fn... defined? (self, source : Id)
+        'nodeId self
+            Node Op.Defined ('boolType self) source
+
+    fn... input
+    case (self, typeId : Id, name : Input)
+        let inp = (rawinput self typeId name)
+        'then self
+            'defined? self inp
+            inp
+    case (self, name : Input)
+        let inp = (rawinput self NoId name)
+        'defined? self inp
+
+    fn... output (self, typeId : Id, name : Output)
+        'nodeId self
+            Node Op.Output typeId name
+
+    fn... intToReal (self, typeId : Id, node : Id)
+        'nodeId self
+            Node ('getCond self node) Op.ConvertIntToReal typeId node
+
+    fn... realToInt (self, typeId : Id, node : Id)
+        'nodeId self
+            Node ('getCond self node) Op.ConvertRealToInt typeId node
+
+    fn... state (self, typeId : Id, default : Id, name : String)
+        'nodeId self
+            Node Op.State typeId default name
+
+    fn... getArgs (self, node : Id, index : u32, ...)
+        ops := (self.nodes @ node) . operands
+        va-map
+            inline (i)
+                copy (ops @ i)
+            \ index ...
+    fn... getArg (self, node : Id, index : u32)
+        copy ((self.nodes @ node) . operands @ index)
+    fn... getType (self, node : Id)
+        copy ((self.nodes @ node) . typeId)
+    fn... getOp (self, node : Id)
+        copy ((self.nodes @ node) . opCode)
+
+    inline unary_op (op)
+        fn... (self, x : Id)
+            'nodeId self
+                Node ('getCond self x) op (getType self x) x
+
+    inline binary_op (op)
+        fn... (self, a : Id, b : Id)
+            'nodeId self
+                Node
+                    \ op (getType self a) a b
+
+    inline binary_bool_op (op)
+        fn... (self, a : Id, b : Id)
+            'nodeId self
+                Node op ('boolType self) a b
+    let
+        sin = (unary_op Op.Sin)
+        cos = (unary_op Op.Cos)
+        fadd = (binary_op Op.FAdd)
+        fmul = (binary_op Op.FMul)
+        fdiv = (binary_op Op.FDiv)
+        equal = (binary_bool_op Op.Equal)
+
+    fn... compositeInsert (self, value : Id, target : Id, ...)
+        'nodeId self
+            Node Op.CompositeInsert (getType self target) value target ...
+
+    fn... compositeConstruct (self, typeId : Id, ...)
+        'nodeId self
+            Node Op.CompositeConstruct typeId ...
+
+    @@ memo
+    inline genvisitor (visit-id visit-input visit-output visit-i32 visit-f32 visit-bool visit-string visit-unknown)
+        fn (self node ctx...)
+            local idx = 0
+            let operand-count = (countof node.operands)
+            inline readop ()
+                assert (idx < operand-count)
+                    .. "missing operand in node of type "
+                        repr node.opCode
+                let operand = (node.operands @ idx)
+                idx += 1
+                operand
+            inline nop ()
+            visit-unknown := visit-unknown or nop
+            visit-id := visit-id or visit-unknown
+            visit-input := visit-input or visit-unknown
+            visit-output := visit-output or visit-unknown
+            visit-i32 := visit-i32 or visit-unknown
+            visit-f32 := visit-f32 or visit-unknown
+            visit-bool := visit-bool or visit-unknown
+            visit-string := visit-string or visit-unknown
+            let visitor =
+                do
+                    inline visit-id ()
+                        visit-id self (readop) ctx...
+                    inline visit-input ()
+                        visit-input self (bitcast (readop) Input) ctx...
+                    inline visit-output ()
+                        visit-output self (bitcast (readop) Output) ctx...
+                    inline visit-i32 ()
+                        visit-i32 self ((readop) as i32) ctx...
+                    inline visit-f32 ()
+                        visit-f32 self (bitcast (readop) f32) ctx...
+                    inline visit-bool ()
+                        visit-bool self (? ((readop) != 0) true false) ctx...
+                    inline visit-string ()
+                        local text : String
+                        label done
+                            while (idx < operand-count)
+                                let word = (readop)
+                                for c in (range 4:u32)
+                                    byte := (word >> (c * 8:u32)) as i8
+                                    if (byte == 0:i8)
+                                        merge done
+                                    'append text byte
+                        visit-string self text ctx...
+                    inline visit-unknown ()
+                        visit-unknown self (readop) ctx...
+                    inline oprange () (range idx operand-count)
+                    inline typeop () ('getOp self node.typeId)
+                    locals;
+            visit-node node.opCode
+                inline "default" ()
+                    for i in (visitor.oprange)
+                        visitor.visit-unknown;
+                \ visitor
+            for i in (visitor.oprange)
+                visitor.visit-unknown;
+
+    fn remap (self remap)
+        for id node in (enumerate self.nodes u32)
+            fn visit (self id remap)
+                id = remap @ id
+            visit self node.typeId remap
+            call
+                genvisitor
+                    visit-id = visit
+                \ self node remap
+        self.root = remap @ self.root
+        self.rnodes_valid = false
+        'clear self.select_cache
+
+    fn... topolist (self, root : Id)
+        let nodes = self.nodes
+        let count = ((countof nodes) as u32)
+        local visited : (Set Id)
+
+        # find roots
+        local queue : (Array Id)
+        'insert visited root
+        'append queue root
+        # tag all reachable nodes
+        for nodeid in queue
+            node := nodes @ nodeid
+            fn visit (self id queue visited)
+                if (id != NoType)
+                    if (not ('in? visited id))
+                        'append queue id
+                    'insert visited id
+            visit self (copy node.typeId) queue visited
+            call
+                genvisitor
+                    visit-id = visit
+                \ self node queue visited
+        queue
+
+    fn... reachable-indegrees (self)
+        let nodes = self.nodes
+        let count = ((countof nodes) as u32)
+        local visited : (Array i32)
+        'resize visited count 0
+
+        local queue : (Array Id)
+        do
+            let id = self.root
+            visited @ id = 1
+            'append queue id
+        # tag all reachable nodes
+        for nodeid in queue
+            node := nodes @ nodeid
+            fn visit (self id queue visited)
+                if (id != NoType)
+                    if ((visited @ id) == 0)
+                        'append queue id
+                    visited @ id += 1
+            visit self (copy node.typeId) queue visited
+            call
+                genvisitor
+                    visit-id = visit
+                \ self node queue visited
+        visited
+
+    fn cull (self)
+        let nodes = self.nodes
+        let count = ((countof nodes) as u32)
+        let visited = (reachable-indegrees self)
+
+        local newnodes : (Array RcNode)
+        'append newnodes (RcNode Op.None NoType)
+        local remap : (Array u32)
+        'resize remap count 0:u32
+        local nextid = 1:u32
+        for oldid node in (enumerate nodes u32)
+            if (visited @ oldid)
+                newid := (copy nextid)
+                nextid += 1
+
+                remap @ oldid = newid
+                'append newnodes (copy node)
+
+        self.nodes = newnodes
+        'remap self remap
+
+    fn indegrees (self)
+        let nodes = self.nodes
+        let count = ((countof nodes) as u32)
+        local used : (Array u32)
+        'resize used count 0:u32
+
+        # build refcount
+        for id in (range 1:u32 count)
+            node := nodes @ id
+            fn visit (self id used)
+                if (id != NoType)
+                    used @ id += 1
+            visit self (copy node.typeId) used
+            call
+                genvisitor
+                    visit-id = visit
+                \ self node used
+
+        used
+
+    fn toposort (self)
+        let nodes = self.nodes
+        let count = ((countof nodes) as u32)
+
+        let noderange = (range 1:u32 count)
+
+        let used = (indegrees self)
+
+        local queue : (Array u32)
+        for id in noderange
+            if ((used @ id) == 0)
+                'append queue id
+        for nodeid in queue
+            fn visit (self id used queue)
+                if (id != NoType)
+                    used @ id -= 1
+                    if (used @ id == 0)
+                        'append queue id
+            node := nodes @ nodeid
+            visit self (copy node.typeId) used queue
+            call
+                genvisitor
+                    visit-id = visit
+                \ self node used queue
+
+        local newnodes : (Array RcNode)
+        'append newnodes (RcNode Op.None NoType)
+        local remap : (Array u32)
+        'resize remap count 0:u32
+        for newid oldid in (enumerate ('reverse queue) u32)
+            newid := newid + 1
+            remap @ oldid = newid
+            node := nodes @ oldid
+            'append newnodes (copy node)
+
+        self.nodes = newnodes
+        'remap self remap
+
+    fn... tolist
+    case (self, nodeId : Id)
+        returning list
+        local result = '()
+        inline append (...)
+            va-map
+                inline (s)
+                    result = (cons s result)
+                ...
+        node := self.nodes @ nodeId
+        append (Symbol (tostring node.opCode))
+        let recur = this-function
+        do
+            inline append (result ...)
+                va-map
+                    inline (s)
+                        result = (cons s result)
+                    ...
+            inline write-any (self v out)
+                append out v
+            inline write-enum (self v out)
+                append out (Symbol (tostring v))
+            vvv bind visit
+            genvisitor
+                visit-id =
+                    inline "write-id" (self v out)
+                        append out
+                            recur self v
+                visit-input = write-enum
+                visit-output = write-enum
+                visit-i32 = write-any
+                visit-f32 = write-any
+                visit-bool = write-any
+                visit-string =
+                    inline "write-string" (self v out)
+                        append out (v as string)
+                visit-unknown =
+                    inline "write-unknown" (self v out)
+                        static-if ((typeof v) == u32)
+                            append out " ?0x" (hex v)
+                        else
+                            append out " ?" (repr v)
+            visit self node result
+        'reverse result
+    case (self)
+        this-function self (copy self.root)
+
+    fn... tostring
+    case (self, nodeId : Id, result : (mutable &String))
+        fn outidstr (id)
+            if (id == 0) "none"
+            else
+                .. "(" (tostring id) ")"
+        inline write (...)
+            va-map
+                inline (s)
+                    'append result s
+                ...
+        node := self.nodes @ nodeId
+        if (nodeId == self.root)
+            write "(" (idstr nodeId) ") "
+        else
+            write (idstr nodeId)
+            if (node.typeId != NoType)
+                write " : " (idstr node.typeId)
+            write " = "
+        write (repr node.opCode)
+        inline write (result ...)
+            va-map
+                inline (s)
+                    'append result s
+                ...
+        inline write-any (self v out)
+            write out " " (repr v)
+        vvv bind visit
+        genvisitor
+            visit-id =
+                inline "write-id" (self v out)
+                    write out " " (idstr v)
+            visit-input = write-any
+            visit-output = write-any
+            visit-i32 = write-any
+            visit-f32 = write-any
+            visit-bool = write-any
+            visit-string =
+                inline "write-string" (self v out)
+                    write out " " (repr (v as string))
+            visit-unknown =
+                inline "write-unknown" (self v out)
+                    static-if ((typeof v) == u32)
+                        write out " ?0x" (hex v)
+                    else
+                        write out " ?" (repr v)
+        visit self node result
+    case (self, nodeId : Id)
+        local result : String
+        this-function self nodeId result
+        result
+    case (self)
+        local result : String
+        inline write (...)
+            va-map
+                inline (s)
+                    'append result s
+                ...
+        for id in (range 1 (countof self.nodes))
+            this-function self (id as Id) result
+            write "\n"
+        result
+
+    fn distsort (self)
+        let nodes = self.nodes
+
+        fn visit-source-argument (self id nodeid dist maxdist)
+            if (id != NoId)
+                d := (max (dist @ nodeid) ((dist @ id) + 1))
+                dist @ nodeid = d
+                maxdist = (max maxdist d)
+            ;
+
+        local dist : (Array i32)
+        'resize dist (countof nodes) 0
+        local maxdist = 0
+
+        for id in (range 1:u32 (countof nodes))
+            node := nodes @ id
+            # compute distance from sources
+            let visitctx... = id dist maxdist
+            visit-source-argument self (copy node.typeId) visitctx...
+            call
+                genvisitor
+                    visit-id = visit-source-argument
+                \ self node visitctx...
+
+        local rows : (Array (Array Id))
+        'resize rows (maxdist + 1)
+
+        for id in (range 1:u32 (countof nodes))
+            'append (rows @ (dist @ id)) id
+
+        local newnodes : (Array RcNode)
+        'append newnodes (RcNode Op.None NoType)
+        local remap : (Array u32)
+        'resize remap (countof nodes) 0:u32
+
+        for row in rows
+            'sort row
+                fn (id self)
+                    node := self.nodes @ id
+                    tupleof
+                        node.opCode as integer
+                        node.typeId
+                \ self
+            for oldid in row
+                newid := (countof newnodes) as Id
+                remap @ oldid = newid
+                'append newnodes (copy (nodes @ oldid))
+
+        self.nodes = newnodes
+        'remap self remap
+
+    fn isbool? (self id)
+        ('getOp self ('getType self id)) == Op.TypeBool
+
+    fn isconstant? (self id)
+        va-switch-case OpDefs Op 'constant? ('getOp self id)
+            inline (cls) false
+
+    fn isundef? (self id)
+        ('getOp self id) == Op.Undefined
+
+    fn isthen? (self id)
+        and (('getOp self id) == Op.If)
+            or
+                isundef? self ('getArg self id 1)
+                isundef? self ('getArg self id 2)
+
+    fn isif? (self id)
+        ('getOp self id) == Op.If
+
+    fn unthen (self id)
+        returning Id Id
+        loop (cond id = ('constBool self true) id)
+            if (('getOp self id) == Op.If)
+                let tval fval =
+                    'getArg self id 1
+                    'getArg self id 2
+                if (isundef? self fval)
+                    repeat ('and self cond ('getArg self id 0)) tval
+                elseif (isundef? self tval)
+                    repeat ('and self cond ('not self ('getArg self id 0))) fval
+            break (copy cond) (copy id)
+
+    fn... getbool (self, id : Id)
+        """"returns bool as signed integer; zero = undefined
+        if ('isbool? self id)
+            if ('isconstant? self id)
+                ? (('getArg self id 0) != 0) 1 -1
+            else 0
+        else 0
+
+    fn... subst (self, id : Id, substmap : (Map Id Id))
+        """"recursive substitution
+        returning Id
+        # see if there is a direct replacement
+        for k v in substmap
+            assert (k != v)
+        try
+            assert (('get substmap id) != id)
+        else;
+        for id in ('reverse (topolist self id))
+            local found = false
+            # see if any change is necessary
+            node := self.nodes @ id
+            fn visit-argument (self id substmap found)
+                if (id != NoId)
+                    if ('in? substmap id)
+                        found = true
+                        raise;
+                ;
+            let visitctx... = substmap found
+            try
+                visit-argument self node.typeId visitctx...
+                call
+                    genvisitor
+                        visit-id = visit-argument
+                    \ self node visitctx...
+            else;
+            if (not found)
+                continue;
+            # make the changes
+            local node = (copy ((self.nodes @ id) as Node))
+            fn visit-argument (self id substmap found)
+                if (id != NoId)
+                    try
+                        let newid = ('get substmap id)
+                        assert (id != newid)
+                        id = newid
+                    else;
+                ;
+            let visitctx... = substmap found
+            visit-argument self node.typeId visitctx...
+            call
+                genvisitor
+                    visit-id = visit-argument
+                \ self node visitctx...
+            let newid =
+                vvv copy
+                'nodeId self (deref node)
+            assert (id != newid)
+            # update select statements that have become constant
+            let newid =
+                if (('getOp self newid) == Op.If)
+                    let cond = ('getArg self newid 0)
+                    let b = ('getbool self cond)
+                    let tval = ('getArg self newid 1)
+                    let fval = ('getArg self newid 2)
+                    if (b != 0)
+                        if (b > 0) tval
+                        else fval
+                    elseif (tval == fval) tval
+                    elseif
+                        and
+                            ('getbool self fval) == -1
+                            ('getbool self tval) == 1
+                        cond
+                    else newid
+                else newid
+            if (id != newid)
+                'set substmap id newid
+        try (copy ('get substmap id))
+        else (copy id)
+
+'define-symbols Module
+    if =
+        fn... "if" (self, cond : Id, tvalue : Id, fvalue : Id)
+            'nodeId self
+                Node Op.If ('getType self tvalue) cond tvalue fvalue
+
+    merge =
+        fn... "merge" (self, value1 : Id, value2 : Id)
+            'nodeId self
+                Node Op.Merge ('voidType self) value1 value2
+
+    bind =
+        fn... "bind" (self, target : Id, source : Id)
+            let id =
+                'nodeId self
+                    Node Op.Bind ('voidType self) target source
+            self.root =
+                do
+                    if (self.root == NoId) id
+                    else
+                        'body self (copy self.root) id
+
+    body =
+        fn... "body" (self, value1 : Id, value2 : Id)
+            'nodeId self
+                Node Op.Body ('getType self value1) value1 value2
+
+    then =
+        fn... "then" (self, cond : Id, value : Id)
+            'if self cond value ('undef self ('getType self value))
+
+    undef =
+        fn... "undef" (self, typeId : Id)
+            'nodeId self
+                Node Op.Undefined typeId
+
+    else =
+        fn... "else" (self, cond : Id, value : Id)
+            'if self cond ('undef self ('getType self value)) value
+
+    or =
+        fn... "or" (self, value1 : Id, value2 : Id)
+            'if self value1 value1 value2
+
+    and =
+        fn... "and" (self, value1 : Id, value2 : Id)
+            'if self value1 value2 value1
+
+    not =
+        fn... "not" (self, _value : Id)
+            'if self _value ('constBool self false) ('constBool self true)
+
+    xor =
+        fn... "xor" (self, value1 : Id, value2 : Id)
+            'if self value1
+                'not self value2
+                value2
+
+################################################################################
+
+type+ Module
+    fn evaluate (self)
+
+        fn... visit (self, ctx : RcContext, id : Id)
+            returning Id
+            raising Error
+            viewing ctx
+            let visit = this-function
+            try
+                return (copy ('get ctx id))
+            else;
+            vvv bind id2
+            switch ('getOp self id)
+            case Op.If
+                let _cond _tval _fval = ('getArgs self id 0 1 2)
+                cond := (visit self ctx _cond)
+                if ('isundef? self cond)
+                    cond
+                #elseif ('isconstant? self cond)
+                    let b = ('getbool self cond)
+                    if (b > 0)
+                elseif ('isif? self cond)
+                    # if(if(a,b,c),d,e) -> if(a,if(b,d,e),if(c,d,e))
+                    let cc ct cf = ('getArgs self cond 0 1 2)
+                    'if self cc
+                        'if self ct _tval _fval
+                        'if self cf _tval _fval
+                else
+                    #(replace (f a b) x y) -> (f (replace a x y) (replace b x y))
+                    #define tval
+                        subctx := (RcContext.subctx ctx)
+                        'set subctx cond ('constBool self true)
+                        visit self subctx _tval
+                    #define fval
+                        subctx := (RcContext.subctx ctx)
+                        'set subctx cond ('constBool self false)
+                        visit self subctx _fval
+                    #'set ctx _tval tval
+                    #'set ctx _fval fval
+                    'if self cond tval fval
+            case Op.Bind
+                let target source = ('getArgs self id 0 1)
+                if ('isundef? self source)
+                    'undef self ('voidType self)
+                elseif (('getOp self source) == Op.If)
+                    let c t f = ('getArgs self source 0 1 2)
+                    'if self c
+                        'bind self target t
+                        'bind self target f
+                else
+                    'nodeId self
+                        Node Op.Bind ('voidType self) target source
+            #case Op.Equal
+                let lhs rhs = ('getArgs self id 0 1)
+                lhs := (visit self ctx lhs)
+                rhs := (visit self ctx rhs)
+                if ('isthen? self lhs)
+                    let lc lt lf = ('getArgs self lhs 0 1 2)
+                    'if self lc
+                        if ('isundef? self lt) lt
+                        else ('equal self lt rhs)
+                        if ('isundef? self lf) lf
+                        else ('equal self lf rhs)
+                elseif ('isthen? self rhs)
+                    let rc rt rf = ('getArgs self rhs 0 1 2)
+                    'if self rc
+                        if ('isundef? self rt) rt
+                        else ('equal self lhs rt)
+                        if ('isundef? self rf) rf
+                        else ('equal self lhs rf)
+                else
+                    'equal self lhs rhs
+            default
+                local node =
+                    copy ((self.nodes @ id) as Node)
+                inline visit-arg (self id ctx)
+                    id = (visit self ctx (copy id))
+                    ;
+                let visitctx... = ctx
+                visit-arg self node.typeId visitctx...
+                call
+                    Module.genvisitor
+                        visit-id = visit-arg
+                    \ self node visitctx...
+                'nodeId self (deref node)
+            'set ctx id id2
+            id2
+
+        local ctx : RcContext
+        local
+        'set ctx 0:u32 0:u32
+        self.root =
+            visit self ctx (copy self.root)
+        ;
+
+################################################################################
+
+static-if main-module?
+    local module : Module
+    do
+        from (methodsof module) let integerType realType arrayType stringType
+            \ getType vectorType intToReal state constFloat fadd fmul fdiv sin cos
+            \ constComposite compositeInsert compositeConstruct constBool constString
+            \ parameter parameters function tupleType else bind then merge
+            \ equal input load output constInt and or not xor if
+
+        let string =
+            stringType;
+        let inttype =
+            integerType 32 true
+        let readline =
+            input string Input.Readline
+        let setup =
+            input Input.Setup
+        let stdout =
+            output string Output.Stdout
+        let exit =
+            output inttype Output.Exit
+        let prompt =
+            output string Output.Prompt
+
+        let exit? =
+            equal (constString "\n") readline
+
+        bind exit
+            then exit? (constInt inttype 0)
+
+        bind prompt
+            then (merge setup (not exit?)) (constString "> ")
+
+        bind stdout
+            merge
+                then exit? (constString "exiting...\n")
+                else exit? readline
+            #if exit? (constString "exiting...\n") readline
+
+    #'toposort module
+    #'catsort module
+
+    print
+        'tostring module
+    print
+        'serialize
+            list
+                'tolist module
+    print;
+
+    'evaluate module
+    'cull module
+    #'toposort module
+    #'distsort module
+    print
+        'tostring module
+    print
+        'serialize
+            list
+                'tolist module
+
+
+
+;

          
M testing/test_node4.sc +126 -19
@@ 118,7 118,7 @@ struct Module
                         mark self used
                             p @ (bitpos2id bitwordofs (findlsb bitofsmask))
                     else
-                        report "miss"
+                        report "ref miss"
                     # go to next ref in this word
                     repeat (bitofsmask << 1)
                 if (bitwordofs >= maxwordofs)

          
@@ 129,7 129,7 @@ struct Module
         mark self used root
         bitofsmask := (1:u32 << bitofs)
 
-        #let p sep ref = self.p self.sep self.ref
+        # tagging, from front to back
         loop (bitwordofs bitofsmask = bitwordofs bitofsmask)
             w := (used @ bitwordofs)
             vvv bind bitwordofs bitofsmask

          
@@ 150,26 150,133 @@ struct Module
             w := (used @ bitwordofs)
             repeat bitwordofs (prevbit w bitofsmask)
 
-local module : Module
-print "n1="
-    n1 := ('alloc module 5)
-print "n2="
-    n2 := ('alloc module 10)
-print "n3="
-    n3 := ('alloc module 16)
-print "n4="
-    n4 := ('alloc module 16)
-print "n5="
-    n5 := ('alloc module 40)
-'setref module (n5 + 2) n4
-'setref module (n5 + 35) n3
-'setref module (n3 + 0) (n1 + 2)
-'setref module (n3 + 1) (n2 + 3)
-'setref module (n2 + 2) n1
-'collect module n5
+        # compaction
+        local t_p : (Array WordType)
+        local t_sep : (Array BitWordType)
+        local t_ref : (Array BitWordType)
+        'append t_p 0:u32
+        'append t_sep 1:u32
+        'append t_ref 0:u32
+
+        # sweep from back to front; first used flag in a sequence copies the
+            sequence to the new buffer, starting from that point; every used
+            word in the previous sequence is replaced with the id of the new
+            one. every reference being transferred looks up its new address
+            in the old buffer.
+
+
+        # tagging without separators and with ranged references:
+            create new empty buffer
+            flag beginning of range as used
 
 
+#do
+    local module : Module
+    print "n1="
+        n1 := ('alloc module 5)
+    print "n2="
+        n2 := ('alloc module 10)
+    print "n3="
+        n3 := ('alloc module 16)
+    print "n4="
+        n4 := ('alloc module 16)
+    print "n5="
+        n5 := ('alloc module 40)
+    'setref module (n5 + 2) n4
+    'setref module (n5 + 35) n3
+    'setref module (n3 + 0) (n1 + 2)
+    'setref module (n3 + 1) (n2 + 3)
+    'setref module (n2 + 2) n1
+    'collect module n5
 
+#
+    0123456789ABCDEF
+    --------0-------
+    ----1-------1---
+    --2---2---2---2-
+    -3-3-3-3-3-3-3-3
+    -323132303231323 - type B: tree order equivalent to sorted array
+    ?2428646?ACA8ECE
+     848284818482848
+    ?0010011?0011011
+    -0-1-0-1-0-1-0-1
+    --0---1---0---1-
+    ----0-------1---
+    0101010101010101
+    0011001100110011
+    0000111100001111
+    0000000011111111
+
+    ----0-------1---
+    00X100X100X100X1
+    0000XX1X0000XX1X
+    00000000XXXX1XXX
+
+    ?0010011?0011011
+    0001000100010001
+    0000001100000011
+    0000000000001111
+    0000000000000000
+    0000000000000000
+
+    in type B, best to keep array at size=2**depth and blank at index 0; then
+    depth(index) = (max_depth - findlsb(index))
+    parent_radius(index) = (index & ~(index - 1))
+    radius(index) = (parent_radius(index) >> 1)
+    is_leaf(index) = (width(index) == 0)
+    left/right(index) = (index ± radius(index))
+    is_left(index) = ((parent_radius (index + parent_radius(index))) == parent_radius(index) * 2)
+    parent(index) = index + is_left(index)?w:-w
+    root() = size >> 1
+
+
+    right(index) = index + radius(index)
+    r_child_index - radius(parent_index) = parent_index
+
+fn radius (index)
+    (index & (~ (index - 1))) >> 1
+
+fn parent-radius (index)
+    index & (~ (index - 1))
+
+fn is_right (b)
+    let ~b = (~ b)
+    # (b0 b1 (b1 b2 (b2 b3 0)))
+
+    & 1
+        |
+            b & (b >> 1)
+            ~b & (b >> 1) & (b >> 2)
+            ~b & (~b >> 1) & (b >> 2) & (b >> 3)
+            ~b & (~b >> 1) & (~b >> 2) & (b >> 3) & (b >> 4)
+            ~b & (~b >> 1) & (~b >> 2) & (~b >> 3) & (b >> 4) & (b >> 5)
+
+fn is_right2 (index)
+    w := (index & (~ (index - 1)))
+    q := (index - w)
+    == 0
+        (q & (~ (q - 1))) - w * 2
+
+fn parent (index)
+    w := index & (~ (index - 1))
+    pl := index - w
+    pr := index + w
+    ? (pl + (radius pl) == index) pl pr
+
+fn parent2 (index)
+    w := index & -index
+    ql := index - w
+    qr := index + w
+    #wwl := ql & -ql
+    wwr := qr & -qr
+    # w * 2 is either wwl or wwr
+    ? (wwr == w * 2) qr ql
+
+for i in (range 128)
+    if (i > 0)
+        #assert ((is_right i) == (is_right2 i))
+        assert ((parent2 i) == (parent i))
+    print i (parent i) (radius i) #(is_right i) (is_right2 i)
 
 ;