stagingExperiment.tri (7360B)
1 !import prelude * 2 !import source_pattern as P 3 !import source_compile as K 4 !import source_core as C 5 !import source_staging_experiment as S 6 !export * 7 -- Explicit IR specifications: no proposed surface syntax or compiler rewrites. 8 -- Replaced with an immutable manifest pin by test/staging_experiment.py. 9 10 lit = P.spLit 11 var = P.spVar 12 app = P.spApp 13 app2 = P.spApp2 14 lam = P.spLam 15 branch = S.stageBranch 16 recur = S.stageRecur 17 18 -- Formatter acceptance: the supplied payload is its cells/suffix pair. 19 acceptSpec = lam (lam (branch (var 1) (app (lit just) (var 0)) (lit nothing))) 20 acceptReference condition payload = lazyBool (_ : just payload) (_ : nothing) condition 21 22 -- Counted slice step sees only head/state. The compiler supplies the original 23 -- tail to recur, guards the list before inspecting counters, and owns y. 24 start = app (lit fst) (var 0) 25 end = app (lit snd) (var 0) 26 nextEnd = app (lit pred) end 27 sliceStep = (branch (app (lit isZero_?) start) 28 (branch (app (lit isZero_?) end) (lit []) 29 (app2 (lit pair) (var 1) (recur (app2 (lit pair) (lit 0) nextEnd)))) 30 (recur (app2 (lit pair) (app (lit pred) start) nextEnd))) 31 sliceSpec = S.stageList (lit []) sliceStep 32 sliceWorker self input start end = (triage [] (_ : []) 33 (head tail : lazyBool 34 (_ : lazyBool (_ : []) (_ : pair head (self tail 0 (pred end))) (isZero_? end)) 35 (_ : self tail (pred start) (pred end)) (isZero_? start)) input) 36 sliceReference input state = y sliceWorker input (fst state) (snd state) 37 38 -- Known controls remain known during function construction. This is the 39 -- concrete case that a control-driven worker could otherwise unfold early. 40 knownSliceSpec = (lazyResult (problem rest : err problem rest) 41 (core rest : ok (lam (app2 (P.spShift core) (var 0) (lit (pair 0 3)))) t) sliceSpec) 42 knownSliceReference input = sliceReference input (pair 0 3) 43 44 -- Divergence depends on a runtime tree, so exporting this function is safe. 45 spin self input = triage 7 (_ : 7) (left right : self input) input 46 loop input = y spin input 47 lazySpec = lam (lam (branch (var 1) (app (lit loop) (var 0)) (lit 23))) 48 lazyReference condition input = lazyBool (_ : loop input) (_ : 23) condition 49 closedSpec = lam (branch (var 0) (app (lit loop) (lit [1])) (lit 23)) 50 closedReference condition = 23 51 -- A generated thunk must preserve both an outer variable and a nested binder. 52 closureSpec = lam (lam (branch (var 1) (lam (app2 (lit pair) (var 1) (var 0))) (lam (var 0)))) 53 closureReference condition saved = lazyBool (_ : fresh : pair saved fresh) (_ : fresh : fresh) condition 54 -- Hidden self/tail insertion must also preserve binders inside a step body. 55 nestedStep = app (lam (recur (app2 (lit pair) (var 2) (var 0)))) (var 0) 56 nestedSpec = S.stageList (var 0) nestedStep 57 nestedWorker self input state = lazyList (_ : state) (head tail : self tail (pair head state)) input 58 nestedReference input state = y nestedWorker input state 59 outerListSpec = S.stageList (lit []) (app2 (lit pair) (var 2) (recur (var 0))) 60 outerSpec = lazyResult (problem rest : err problem rest) (core rest : ok (lam core) t) outerListSpec 61 outerReference saved input state = map (_ : saved) input 62 -- Even the next-state expression is branch work: the compiler must delay it. 63 deferredStep = branch (app (lit isZero_?) (var 0)) (lit 0) (recur (app (lit loop) (var 1))) 64 deferredSpec = S.stageList (var 0) deferredStep 65 deferredWorker self input state = (lazyList (_ : state) 66 (head tail : lazyBool (_ : 0) (_ : self tail (loop head)) (isZero_? state)) input) 67 deferredReference input state = y deferredWorker input state 68 69 -- The comparator receives the entire core specification at runtime. It must 70 -- actually execute both experimental lowering and the canonical core compiler. 71 -- Fixture = (mode, (spec, (arguments, (reference, expected result)))). 72 compileSpec mode spec = (lazyBool 73 (_ : K.sourceCompileCore (S.stageBody spec)) 74 (_ : lazyResult (problem rest : err problem rest) 75 (core rest : K.sourceCompileCore core) spec) (equal? mode 0)) 76 runFixture fixture = (let mode = fst fixture in let rest = snd fixture in 77 let spec = fst rest in let arguments = fst (snd rest) in 78 lazyResult (problem rest : err problem rest) 79 (function rest : ok (foldl (f argument : f argument) function arguments) t) 80 (compileSpec mode spec)) 81 matchesFixture fixture = (and? 82 (equal? (runFixture fixture) (snd (snd (snd (snd fixture))))) 83 (equal? (runFixture fixture) 84 (ok (foldl (f argument : f argument) (fst (snd (snd (snd fixture)))) 85 (fst (snd (snd fixture)))) t))) 86 87 fixture mode spec arguments reference expected = pair mode (pair spec (pair arguments (pair reference (ok expected t)))) 88 fixtureAccept = fixture 0 acceptSpec [true (pair ["f" "_"] "= t")] acceptReference (just (pair ["f" "_"] "= t")) 89 fixtureReject = fixture 0 acceptSpec [false (pair ["f"] "= t")] acceptReference nothing 90 fixtureSlice = fixture 1 sliceSpec ["abcdef" (pair 1 4)] sliceReference "bcd" 91 fixtureZero = fixture 1 sliceSpec ["abcdef" (pair 0 0)] sliceReference "" 92 fixtureEmpty = fixture 1 sliceSpec ["" (pair 0 5)] sliceReference "" 93 fixtureMalformed = fixture 1 sliceSpec [(t t) (pair 0 3)] sliceReference [] 94 -- Explicit Unicode scalar cells preserve the reference fixture tree across 95 -- source-file byte transport; this checks slicing characters, not UTF-8 bytes. 96 fixtureUnicode = fixture 1 sliceSpec [[955 29483 97 98 99] (pair 1 4)] sliceReference [29483 97 98] 97 fixturePastEnd = fixture 1 sliceSpec ["abc" (pair 8 10)] sliceReference "" 98 fixtureTruncate = fixture 1 sliceSpec ["abc" (pair 1 9)] sliceReference "bc" 99 fixtureReversed = fixture 1 sliceSpec ["abcdef" (pair 4 2)] sliceReference "" 100 fixtureKnown = fixture 1 knownSliceSpec ["abcdef"] knownSliceReference "abc" 101 fixtureUnselected = fixture 0 lazySpec [false [1]] lazyReference 23 102 fixtureClosedUnselected = fixture 0 closedSpec [false] closedReference 23 103 fixtureClosedDiverge = fixture 0 closedSpec [true] closedReference t 104 fixtureSelectedFinite = fixture 0 lazySpec [true t] lazyReference 7 105 fixtureClosure = fixture 0 closureSpec [true 11 12] closureReference (pair 11 12) 106 fixtureClosureFalse = fixture 0 closureSpec [false 11 12] closureReference 12 107 fixtureNested = fixture 1 nestedSpec [[1 2 3] []] nestedReference [3 2 1] 108 fixtureOuter = fixture 1 outerSpec [11 [1 2] 0] outerReference [11 11] 109 fixtureDeferredGate = fixture 1 deferredSpec [[] 1] deferredReference 1 110 fixtureDeferredBranch = fixture 1 deferredSpec [[[1]] 0] deferredReference 0 111 fixtureDeferredFinite = fixture 1 deferredSpec [[t] 1] deferredReference 7 112 fixtureRecurDiverge = fixture 1 deferredSpec [[[1]] 1] deferredReference t 113 fixtureWrong = fixture 0 acceptSpec [false t] acceptReference (just t) 114 fixtureDiverge = fixture 0 lazySpec [true [1]] lazyReference t 115 116 -- These exports force actual candidate construction independently of runtime 117 -- fixture equality. They also support size/intensional/cost comparisons. 118 compiledAccept = lazyResult (_ _ : t) (tree _ : tree) (compileSpec 0 acceptSpec) 119 compiledSlice = lazyResult (_ _ : t) (tree _ : tree) (compileSpec 1 sliceSpec) 120 compiledKnown = lazyResult (_ _ : t) (tree _ : tree) (compileSpec 1 knownSliceSpec) 121 compiledLazy = lazyResult (_ _ : t) (tree _ : tree) (compileSpec 0 lazySpec) 122 compiledClosed = lazyResult (_ _ : t) (tree _ : tree) (compileSpec 0 closedSpec) 123 acceptTreeEqual = equal? compiledAccept acceptReference 124 sliceTreeEqual = equal? compiledSlice sliceReference