aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/synthesizer
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/synthesizer')
-rw-r--r--new-luxc/source/luxc/synthesizer/case.lux91
-rw-r--r--new-luxc/source/luxc/synthesizer/function.lux4
-rw-r--r--new-luxc/source/luxc/synthesizer/variable.lux100
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)]))