(.module: lux (lux (data [number] (coll [list "list/" Mix Monoid] ["s" set]))) (luxc (lang ["la" analysis] ["ls" synthesis] [".L" variable #+ Variable]))) (def: (bound-vars path) (-> ls.Path (List Variable)) (case path (#ls.BindP register) (list (.int register)) (^or (#ls.SeqP pre post) (#ls.AltP pre post)) (list/composite (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) (list/composite (path-bodies pre) (path-bodies post)) _ (list))) (def: (non-arg? arity var) (-> ls.Arity Variable Bit) (and (variableL.local? var) (n/> arity (.nat var)))) (type: Tracker (s.Set Variable)) (def: init-tracker Tracker (s.new number.Hash)) (def: (unused-vars current-arity bound exprS) (-> ls.Arity (List Variable) ls.Synthesis (List Variable)) (let [tracker (loop [exprS exprS tracker (list/mix s.has init-tracker bound)] (case exprS (#ls.Variable var) (if (non-arg? current-arity var) (s.lacks var tracker) tracker) (#ls.Variant tag last? memberS) (recur memberS tracker) (#ls.Tuple membersS) (list/mix recur tracker membersS) (#ls.Call funcS argsS) (list/mix recur (recur funcS tracker) argsS) (^or (#ls.Recur argsS) (#ls.Procedure name argsS)) (list/mix 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 (list/mix recur tracker initsS)) (#ls.Case inputS outputPS) (let [tracker' (list/mix s.has (recur inputS tracker) (bound-vars outputPS))] (list/mix recur tracker' (path-bodies outputPS))) (#ls.Function arity env bodyS) (list/mix s.lacks 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)]))