From c0acd75d41ed0e927ec318d4b12c0ec4f5f2e1d3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 2 Jul 2017 15:52:36 -0400 Subject: - Adjusted compiler to the new lack of Char type. - WIP: PM/case synthesis. --- new-luxc/source/luxc/synthesizer/case.lux | 91 +++++++++++++++++++++++ new-luxc/source/luxc/synthesizer/function.lux | 4 ++ new-luxc/source/luxc/synthesizer/variable.lux | 100 ++++++++++++++++++++++++++ 3 files changed, 195 insertions(+) create mode 100644 new-luxc/source/luxc/synthesizer/case.lux create mode 100644 new-luxc/source/luxc/synthesizer/variable.lux (limited to 'new-luxc/source/luxc/synthesizer') 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] + [text "T/" Eq] + [number] + (coll [list "L/" Functor Fold Monoid] + ["s" set]))) + (luxc (lang ["la" analysis] + ["ls" synthesis]) + (synthesizer ["&;" function]))) + +(def: #export (path pattern) + (-> la;Pattern ls;Path) + (case pattern + (^template [ ] + ( register) + ( 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 [ (as-is (#ls;AltP prevP nextP))] + (case [nextP prevP] + [#ls;UnitP #ls;UnitP] + #ls;UnitP + + (^template [ ] + [( next) ( prev)] + (if ( next prev) + prevP + )) + ([#ls;BindP n.=] + [#ls;BoolP B/=] + [#ls;NatP n.=] + [#ls;IntP i.=] + [#ls;DegP d.=] + [#ls;RealP r.=] + [#ls;TextP T/=]) + + (^template [ ] + [( ( next-idx) next-then) ( ( prev-idx) prev-then)] + (if (n.= next-idx prev-idx) + (weave next-then prev-then) + )) + ([#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 _ _) + + + weavedP + (#ls;SeqP weavedP (weave next-post prev-post))) + + _ + ))) 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] + [text "T/" Eq] + [number] + (coll [list "L/" Functor Fold Monoid] + ["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)) + +(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)])) -- cgit v1.2.3