diff options
Diffstat (limited to 'new-luxc/source/luxc/synthesizer')
| -rw-r--r-- | new-luxc/source/luxc/synthesizer/case.lux | 91 | ||||
| -rw-r--r-- | new-luxc/source/luxc/synthesizer/function.lux | 4 | ||||
| -rw-r--r-- | new-luxc/source/luxc/synthesizer/variable.lux | 100 |
3 files changed, 195 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux new file mode 100644 index 000000000..ee2ef84b0 --- /dev/null +++ b/new-luxc/source/luxc/synthesizer/case.lux @@ -0,0 +1,91 @@ +(;module: + lux + (lux (data [bool "B/" Eq<Bool>] + [text "T/" Eq<Text>] + [number] + (coll [list "L/" Functor<List> Fold<List> Monoid<List>] + ["s" set]))) + (luxc (lang ["la" analysis] + ["ls" synthesis]) + (synthesizer ["&;" function]))) + +(def: #export (path pattern) + (-> la;Pattern ls;Path) + (case pattern + (^template [<from> <to>] + (<from> register) + (<to> register)) + ([#la;BindP #ls;BindP] + [#la;BoolP #ls;BoolP] + [#la;NatP #ls;NatP] + [#la;IntP #ls;IntP] + [#la;DegP #ls;DegP] + [#la;RealP #ls;RealP] + [#la;TextP #ls;TextP]) + + (#la;TupleP membersP) + (case (list;reverse membersP) + #;Nil + #ls;UnitP + + (#;Cons singletonP #;Nil) + (path singletonP) + + (#;Cons lastP prevsP) + (let [length (list;size membersP) + last-idx (n.dec length) + last-path (#ls;TupleP (#;Right last-idx) (path lastP)) + [_ tuple-path] (L/fold (function [current-pattern [current-idx next-path]] + [(n.dec current-idx) + (#ls;SeqP (#ls;TupleP (#;Left current-idx) + (path current-pattern)) + next-path)]) + [(n.dec last-idx) last-path] + prevsP)] + tuple-path)) + + (#la;VariantP tag num-tags memberP) + (let [last? (n.= (n.dec num-tags) tag)] + (#ls;VariantP (if last? (#;Right tag) (#;Left tag)) + (path memberP))))) + +(def: #export (weave nextP prevP) + (-> ls;Path ls;Path ls;Path) + (with-expansions [<default> (as-is (#ls;AltP prevP nextP))] + (case [nextP prevP] + [#ls;UnitP #ls;UnitP] + #ls;UnitP + + (^template [<tag> <test>] + [(<tag> next) (<tag> prev)] + (if (<test> next prev) + prevP + <default>)) + ([#ls;BindP n.=] + [#ls;BoolP B/=] + [#ls;NatP n.=] + [#ls;IntP i.=] + [#ls;DegP d.=] + [#ls;RealP r.=] + [#ls;TextP T/=]) + + (^template [<tag> <side>] + [(<tag> (<side> next-idx) next-then) (<tag> (<side> prev-idx) prev-then)] + (if (n.= next-idx prev-idx) + (weave next-then prev-then) + <default>)) + ([#ls;TupleP #;Left] + [#ls;TupleP #;Right] + [#ls;VariantP #;Left] + [#ls;VariantP #;Right]) + + [(#ls;SeqP next-pre next-post) (#ls;SeqP prev-pre prev-post)] + (case (weave next-pre prev-pre) + (#ls;AltP _ _) + <default> + + weavedP + (#ls;SeqP weavedP (weave next-post prev-post))) + + _ + <default>))) diff --git a/new-luxc/source/luxc/synthesizer/function.lux b/new-luxc/source/luxc/synthesizer/function.lux index 42aa7a6cd..e8b2a7ec4 100644 --- a/new-luxc/source/luxc/synthesizer/function.lux +++ b/new-luxc/source/luxc/synthesizer/function.lux @@ -44,6 +44,10 @@ (-> Nat Int) (|> idx n.inc nat-to-int (i.* -1))) +(def: #export (captured-idx idx) + (-> Int Nat) + (|> idx (i.* -1) int-to-nat n.dec)) + (def: #export (to-local idx) (-> Nat Int) (nat-to-int idx)) diff --git a/new-luxc/source/luxc/synthesizer/variable.lux b/new-luxc/source/luxc/synthesizer/variable.lux new file mode 100644 index 000000000..3a48cb3f2 --- /dev/null +++ b/new-luxc/source/luxc/synthesizer/variable.lux @@ -0,0 +1,100 @@ +(;module: + lux + (lux (data [bool "B/" Eq<Bool>] + [text "T/" Eq<Text>] + [number] + (coll [list "L/" Functor<List> Fold<List> Monoid<List>] + ["s" set]))) + (luxc (lang ["la" analysis] + ["ls" synthesis]) + (synthesizer ["&;" function]))) + +(def: (bound-vars path) + (-> ls;Path (List ls;Variable)) + (case path + (#ls;BindP register) + (list (nat-to-int register)) + + (^or (#ls;SeqP pre post) (#ls;AltP pre post)) + (L/append (bound-vars pre) (bound-vars post)) + + _ + (list))) + +(def: (path-bodies path) + (-> ls;Path (List ls;Synthesis)) + (case path + (#ls;ExecP body) + (list body) + + (#ls;SeqP pre post) + (path-bodies post) + + (#ls;AltP pre post) + (L/append (path-bodies pre) (path-bodies post)) + + _ + (list))) + +(def: (non-arg? arity var) + (-> ls;Arity ls;Variable Bool) + (and (&function;local? var) + (n.> arity (int-to-nat var)))) + +(type: Tracker (s;Set ls;Variable)) + +(def: init-tracker Tracker (s;new number;Hash<Int>)) + +(def: (unused-vars current-arity bound exprS) + (-> ls;Arity (List ls;Variable) ls;Synthesis (List ls;Variable)) + (let [tracker (loop [exprS exprS + tracker (L/fold s;add init-tracker bound)] + (case exprS + (#ls;Variable var) + (if (non-arg? current-arity var) + (s;remove var tracker) + tracker) + + (#ls;Variant tag last? memberS) + (recur memberS tracker) + + (#ls;Tuple membersS) + (L/fold recur tracker membersS) + + (#ls;Call funcS argsS) + (L/fold recur (recur funcS tracker) argsS) + + (^or (#ls;Recur argsS) + (#ls;Procedure name argsS)) + (L/fold recur tracker argsS) + + (#ls;Let offset inputS outputS) + (|> tracker (recur inputS) (recur outputS)) + + (#ls;If testS thenS elseS) + (|> tracker (recur testS) (recur thenS) (recur elseS)) + + (#ls;Loop offset initsS bodyS) + (recur bodyS (L/fold recur tracker initsS)) + + (#ls;Case inputS outputPS) + (let [tracker' (L/fold s;add + (recur inputS tracker) + (bound-vars outputPS))] + (L/fold recur tracker' (path-bodies outputPS))) + + (#ls;Function arity env bodyS) + (L/fold s;remove tracker env) + + _ + tracker + ))] + (s;to-list tracker))) + +## (def: (optimize-register-use current-arity [pathS bodyS]) +## (-> ls;Arity [ls;Path ls;Synthesis] [ls;Path ls;Synthesis]) +## (let [bound (bound-vars pathS) +## unused (unused-vars current-arity bound bodyS) +## adjusted (adjust-vars unused bound)] +## [(|> pathS (clean-pattern adjusted) simplify-pattern) +## (clean-expression adjusted bodyS)])) |