tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

specialize.tri (15782B)

      1 !import prelude *
      2 !import consumers_structural as S
      3 !import consumers_pattern_slots as Slots
      4 !export *
      5 -- Bounded tricu-authored staging: prepareConsumer compiles patterns;
      6 -- prepareFully also compiles output templates; compileDirect additionally
      7 -- lowers the finite rule list to executable first-match branches.
      8 -- Capture lookup, Result plumbing and dynamic invocation remain at runtime.
      9 -- Keep authored IR separately; executable representations are not interchangeable.
     10 
     11 compiledStem inner value bindings = triage nothing (subtree : inner subtree bindings) (_ _ : nothing) value
     12 compiledFork first second value bindings = triage nothing (_ : nothing) (leftValue rightValue : lazyMaybe (_ : nothing) (leftBindings : second rightValue leftBindings) (first leftValue bindings)) value
     13 compiledAs inner slot value bindings =
     14   inner value (pair (pair slot value) bindings)
     15 
     16 compiledPattern_ self pattern = matchPair (tag payload :
     17   lazyBool (_ : value bindings : just bindings)
     18     (_ : lazyBool
     19       (_ : value bindings : triage (just bindings) (_ : nothing)
     20         (_ _ : nothing) value)
     21       (_ : lazyBool
     22         (_ : compiledStem (self payload))
     23         (_ : lazyBool
     24           (_ : matchPair (left right :
     25             compiledFork (self left) (self right)) payload)
     26           (_ : lazyBool
     27             (_ : value bindings : just (pair (pair payload value) bindings))
     28             (_ : lazyBool
     29               (_ : value bindings : lazyBool (_ : just bindings)
     30                 (_ : nothing) (equal? payload value))
     31               (_ : lazyBool
     32                 (_ : matchPair (slot child : compiledAs (self child) slot) payload)
     33                 (_ : value bindings : nothing)
     34                 (equal? tag 6))
     35               (equal? tag 5))
     36             (equal? tag 4))
     37           (equal? tag 3))
     38         (equal? tag 2))
     39       (equal? tag 1))
     40     (equal? tag 0)) pattern
     41 compiledPattern pattern = y compiledPattern_ pattern
     42 
     43 compiledRule rule = matchPair (inputPattern more : matchPair
     44   (statePattern output : pair (compiledPattern inputPattern)
     45     (pair (compiledPattern statePattern) output)) more) rule
     46 prepareConsumer consumer = S.makeConsumer (fst consumer) (map compiledRule (snd consumer))
     47 
     48 choosePrepared_ self rules input state =
     49   lazyList (_ : nothing)
     50     (rule rest : matchPair (inputMatcher more : matchPair
     51     (stateMatcher output : lazyMaybe
     52       (_ : self rest input state)
     53       (inputBindings : lazyMaybe
     54         (_ : self rest input state)
     55         (bindings : just (pair output bindings))
     56         (stateMatcher state inputBindings))
     57       (inputMatcher input t)) more) rule)
     58     rules
     59 choosePrepared rules input state = y choosePrepared_ rules input state
     60 
     61 runPrepared_ self input program state =
     62   lazyMaybe (_ : err "no matching consumer rule" t)
     63     (selected : matchPair (output bindings :
     64     S.evalOutput output bindings
     65       (nextInput nextState : self nextInput program nextState)
     66       (worker argument initial : self argument worker initial)) selected)
     67     (choosePrepared (snd program) input state)
     68 runPrepared program input = y runPrepared_ input program (fst program)
     69 
     70 -- Second stage: compile output-template tags and child traversal as well.
     71 -- Results, dynamic workers, capture lookup and the host reducer are unchanged.
     72 compiledForkOutput left right bindings recur invoke =
     73   bindResult (left bindings recur invoke) (leftValue _ :
     74     bindResult (right bindings recur invoke) (rightValue _ :
     75       ok (pair leftValue rightValue) t))
     76 compiledStemOutput child bindings recur invoke =
     77   bindResult (child bindings recur invoke) (value _ : ok (t value) t)
     78 compiledRecurOutput input state bindings recur invoke =
     79   bindResult (input bindings recur invoke) (nextInput _ :
     80     bindResult (state bindings recur invoke) (nextState _ :
     81       recur nextInput nextState))
     82 compiledCallOutput worker input returnSlot receiver bindings recur invoke =
     83   bindResult (worker bindings recur invoke) (workerValue _ :
     84     bindResult (input bindings recur invoke) (argument _ :
     85       bindResult (invoke workerValue argument (fst workerValue)) (returned _ :
     86         receiver (pair (pair returnSlot returned) bindings) recur invoke)))
     87 compiledBecomeOutput worker input state bindings recur invoke =
     88   bindResult (worker bindings recur invoke) (target _ :
     89     bindResult (input bindings recur invoke) (argument _ :
     90       bindResult (state bindings recur invoke) (initial _ :
     91         invoke target argument initial)))
     92 compiledEqualOutput left right bindings recur invoke =
     93   bindResult (left bindings recur invoke) (a _ :
     94     bindResult (right bindings recur invoke) (b _ : ok (equal? a b) t))
     95 compiledOutput_ self output = matchPair (tag payload :
     96   lazyBool (_ : bindings recur invoke : ok payload t)
     97     (_ : lazyBool
     98       (_ : bindings recur invoke : S.capture bindings payload)
     99       (_ : lazyBool
    100         (_ : matchPair (left right :
    101           compiledForkOutput (self left) (self right)) payload)
    102         (_ : lazyBool
    103           (_ : matchPair (input state :
    104             compiledRecurOutput (self input) (self state)) payload)
    105           (_ : lazyBool
    106             (_ : matchPair (worker more : matchPair (input continuation :
    107               matchPair (returnSlot receiver :
    108                 compiledCallOutput (self worker) (self input) returnSlot
    109                   (self receiver)) continuation) more) payload)
    110             (_ : lazyBool
    111               (_ : compiledStemOutput (self payload))
    112               (_ : lazyBool
    113                 (_ : matchPair (worker more : matchPair (input state :
    114                   compiledBecomeOutput (self worker) (self input)
    115                     (self state)) more) payload)
    116                 (_ : lazyBool
    117                   (_ : matchPair (left right :
    118                     compiledEqualOutput (self left) (self right)) payload)
    119                   (_ : bindings recur invoke : err "unknown output form" t)
    120                   (equal? tag 8))
    121                 (equal? tag 6))
    122               (equal? tag 5))
    123             (equal? tag 4))
    124           (equal? tag 3))
    125         (equal? tag 2))
    126       (equal? tag 1))
    127     (equal? tag 0)) output
    128 compiledOutput output = y compiledOutput_ output
    129 
    130 compiledFullRule rule = matchPair (inputPattern more : matchPair
    131   (statePattern output : pair (compiledPattern inputPattern)
    132     (pair (compiledPattern statePattern) (compiledOutput output))) more) rule
    133 prepareFully consumer = S.makeConsumer (fst consumer) (map compiledFullRule (snd consumer))
    134 
    135 runFull_ self input program state =
    136   lazyMaybe (_ : err "no matching consumer rule" t)
    137     (selected : matchPair (output bindings : output bindings
    138     (nextInput nextState : self nextInput program nextState)
    139     (worker argument initial : self argument worker initial)) selected)
    140     (choosePrepared (snd program) input state)
    141 runFull program input = y runFull_ input program (fst program)
    142 
    143 -- A bounded further lowering for known consumers: turn the finite rule list
    144 -- into executable first-match branches. Runtime data still selects branches;
    145 -- there is no rule-list walk or pattern/template tag traversal per call.
    146 -- Dynamic workers must themselves be compiled with compileDirect.
    147 directBranch inputMatcher stateMatcher output fallback input state recur invoke =
    148   lazyMaybe (_ : fallback input state recur invoke)
    149     (inputBindings : lazyMaybe (_ : fallback input state recur invoke)
    150       (bindings : output bindings recur invoke)
    151       (stateMatcher state inputBindings))
    152     (inputMatcher input t)
    153 compileDirectRules_ self rules =
    154   lazyList (_ : input state recur invoke : err "no matching consumer rule" t)
    155     (rule rest : matchPair (inputPattern more : matchPair
    156       (statePattern output : directBranch (compiledPattern inputPattern)
    157         (compiledPattern statePattern) (compiledOutput output)
    158         (self rest)) more) rule)
    159     rules
    160 compileDirectRules rules = y compileDirectRules_ rules
    161 compileDirect program = S.makeConsumer (fst program) (compileDirectRules (snd program))
    162 runDirect_ self input program state = (snd program) input state (nextInput nextState : self nextInput program nextState) (worker argument initial : self argument worker initial)
    163 runDirect program input = y runDirect_ input program (fst program)
    164 
    165 
    166 -- Indexed matchers retain values only, in the same capture order.
    167 indexedAs inner value bindings = inner value (pair value bindings)
    168 indexedPattern_ self pattern = matchPair (tag payload :
    169   lazyBool (_ : value bindings : just bindings)
    170     (_ : lazyBool
    171       (_ : value bindings : triage (just bindings) (_ : nothing)
    172         (_ _ : nothing) value)
    173       (_ : lazyBool
    174         (_ : compiledStem (self payload))
    175         (_ : lazyBool
    176           (_ : matchPair (left right :
    177             compiledFork (self left) (self right)) payload)
    178           (_ : lazyBool
    179             (_ : value bindings : just (pair value bindings))
    180             (_ : lazyBool
    181               (_ : value bindings : lazyBool (_ : just bindings)
    182                 (_ : nothing) (equal? payload value))
    183               (_ : lazyBool
    184                 (_ : matchPair (slot child : indexedAs (self child)) payload)
    185                 (_ : value bindings : nothing)
    186                 (equal? tag 6))
    187               (equal? tag 5))
    188             (equal? tag 4))
    189           (equal? tag 3))
    190         (equal? tag 2))
    191       (equal? tag 1))
    192     (equal? tag 0)) pattern
    193 indexedPattern pattern = y indexedPattern_ pattern
    194 indexedCallOutput worker input returnSlot receiver bindings recur invoke = bindResult (worker bindings recur invoke) (workerValue _ : bindResult (input bindings recur invoke) (argument _ : bindResult (invoke workerValue argument (fst workerValue)) (returned _ : receiver (pair returned bindings) recur invoke)))
    195 
    196 -- Slot names are static. Compile their search into finite binding projections.
    197 -- Matchers build value lists, without runtime slot/value pairs. Missing slots
    198 -- retain the original Result error.
    199 indexedHead bindings = ok (fst bindings) t
    200 indexedTail next bindings = next (snd bindings)
    201 indexedCapture_ self slots slot = lazyList (_ : bindings : err "unknown capture" t) (name rest : lazyBool (_ : indexedHead) (_ : indexedTail (self rest slot)) (equal? name slot)) slots
    202 indexedCapture slots slot bindings = y indexedCapture_ slots slot bindings
    203 -- Compatibility entry point for the indexed-lowering experiments.
    204 patternSlots pattern slots = Slots.patternSlots pattern slots
    205 -- Literal workers are already executable direct/indexed consumers. Link their
    206 -- application here instead of routing through the runtime invoke argument.
    207 linkedCall worker input slot receiver bindings recur invoke = bindResult (input bindings recur invoke) (argument _ : bindResult (runDirect worker argument) (returned _ : receiver (pair returned bindings) recur invoke))
    208 linkedBecome worker input state bindings recur invoke = bindResult (input bindings recur invoke) (argument _ : bindResult (state bindings recur invoke) (initial _ : y runDirect_ argument worker initial))
    209 indexedOutput_ self output slots = matchPair (tag payload :
    210   lazyBool (_ : bindings recur invoke : ok payload t)
    211     (_ : lazyBool
    212       (_ : bindings recur invoke : indexedCapture slots payload bindings)
    213       (_ : lazyBool
    214         (_ : matchPair (left right :
    215           compiledForkOutput (self left slots) (self right slots)) payload)
    216         (_ : lazyBool
    217           (_ : matchPair (input state :
    218             compiledRecurOutput (self input slots) (self state slots)) payload)
    219           (_ : lazyBool
    220             (_ : matchPair (worker more : matchPair (input continuation :
    221               matchPair (returnSlot receiver :
    222                 lazyBool (_ : linkedCall (snd worker) (self input slots) returnSlot (self receiver (pair returnSlot slots)))
    223                   (_ : indexedCallOutput (self worker slots) (self input slots) returnSlot (self receiver (pair returnSlot slots))) (equal? (fst worker) 0)) continuation) more) payload)
    224             (_ : lazyBool
    225               (_ : compiledStemOutput (self payload slots))
    226               (_ : lazyBool
    227                 (_ : matchPair (worker more : matchPair (input state :
    228                   lazyBool (_ : linkedBecome (snd worker) (self input slots) (self state slots))
    229                     (_ : compiledBecomeOutput (self worker slots) (self input slots) (self state slots)) (equal? (fst worker) 0)) more) payload)
    230                 (_ : lazyBool
    231                   (_ : matchPair (left right :
    232                     compiledEqualOutput (self left slots) (self right slots)) payload)
    233                   (_ : bindings recur invoke : err "unknown output form" t)
    234                   (equal? tag 8))
    235                 (equal? tag 6))
    236               (equal? tag 5))
    237             (equal? tag 4))
    238           (equal? tag 3))
    239         (equal? tag 2))
    240       (equal? tag 1))
    241     (equal? tag 0)) output
    242 indexedOutput output slots = y indexedOutput_ output slots
    243 compileIndexedRules_ self rules = lazyList (_ : input state recur invoke : err "no matching consumer rule" t) (rule rest : matchPair (inputPattern more : matchPair (statePattern output :
    244     directBranch (indexedPattern inputPattern) (indexedPattern statePattern)
    245       (indexedOutput output (patternSlots statePattern (patternSlots inputPattern t)))
    246       (self rest)) more) rule) rules
    247 compileIndexed program = S.makeConsumer (fst program) (y compileIndexedRules_ (snd program))
    248 
    249 -- Bind a known initial state only for non-recurrent consumers. Recur would
    250 -- invalidate the static-state assumption, so reject it rather than miscompile.
    251 withoutSlot_ self bindings slot = lazyList (_ : t) (entry rest : lazyBool (_ : self rest slot) (_ : pair entry (self rest slot)) (equal? (fst entry) slot)) bindings
    252 withoutSlot bindings slot = y withoutSlot_ bindings slot
    253 bindOutput_ self output bindings = matchPair (tag payload :
    254   lazyBool (_ : ok output t)
    255     (_ : lazyBool (_ : lazyResult (_ _ : ok output t) (value _ : ok (S.outLiteral value) t) (S.capture bindings payload))
    256       (_ : lazyBool (_ : matchPair (left right : bindResult (self left bindings) (a _ : bindResult (self right bindings) (b _ : ok (S.outFork a b) t))) payload)
    257         (_ : lazyBool (_ : err "cannot bind state of recurrent consumer" t)
    258           (_ : lazyBool (_ : matchPair (worker more : matchPair (input continuation : matchPair (slot receiver : bindResult (self worker bindings) (w _ : bindResult (self input bindings) (i _ : bindResult (self receiver (withoutSlot bindings slot)) (r _ : ok (S.outCall w i slot r) t)))) continuation) more) payload)
    259             (_ : lazyBool (_ : bindResult (self payload bindings) (child _ : ok (S.outStem child) t))
    260               (_ : lazyBool (_ : matchPair (worker more : matchPair (input state : bindResult (self worker bindings) (w _ : bindResult (self input bindings) (i _ : bindResult (self state bindings) (s _ : ok (S.outBecome w i s) t)))) more) payload)
    261                 (_ : lazyBool (_ : matchPair (left right : bindResult (self left bindings) (a _ : bindResult (self right bindings) (b _ : ok (S.outEqual a b) t))) payload)
    262                   (_ : ok output t) (equal? tag 8)) (equal? tag 6)) (equal? tag 5)) (equal? tag 4)) (equal? tag 3)) (equal? tag 2)) (equal? tag 1)) (equal? tag 0)) output
    263 bindOutput output bindings = y bindOutput_ output bindings
    264 bindRules_ self rules state = lazyList (_ : ok t t) (rule rest : matchPair (inputPattern more : matchPair (statePattern output :
    265     lazyMaybe (_ : self rest state)
    266       (bindings : bindResult (bindOutput output bindings) (bound _ : bindResult (self rest state) (tail _ : ok (pair (S.makeRule inputPattern S.patAny bound) tail) t)))
    267       (S.matchPattern statePattern state t)) more) rule) rules
    268 bindState program state = bindResult (y bindRules_ (snd program) state) (rules _ : ok (S.makeConsumer t rules) t)
    269 compileBound program state = bindResult (bindState program state) (bound _ : ok (compileIndexed bound) t)