diff options
Diffstat (limited to 'new-luxc/source/luxc/synthesizer.lux')
| -rw-r--r-- | new-luxc/source/luxc/synthesizer.lux | 145 |
1 files changed, 67 insertions, 78 deletions
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index e1eb67bd7..e6730c5a3 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -12,14 +12,14 @@ ["s" syntax])) (luxc ["&" base] (lang ["la" analysis] - ["ls" synthesis]) - (synthesizer ["&&;" structure] - ["&&;" case] + ["ls" synthesis] + [";L" variable #+ Variable]) + (synthesizer ["&&;" case] ["&&;" function] ["&&;" loop]) )) -(def: init-env (List ls;Variable) (list)) +(def: init-env (List Variable) (list)) (def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>)) (def: (prepare-body inner-arity arity body) @@ -28,10 +28,6 @@ body (&&loop;reify-recursion arity body))) -(def: (parse-environment env) - (-> (List Code) (e;Error (List ls;Variable))) - (s;run env (p;some s;int))) - (def: (let$ register inputS bodyS) (-> Nat ls;Synthesis ls;Synthesis ls;Synthesis) (` ("lux let" (~ (code;nat register)) (~ inputS) (~ bodyS)))) @@ -43,7 +39,7 @@ (~ elseS)))) (def: (function$ arity environment body) - (-> ls;Arity (List ls;Variable) ls;Synthesis ls;Synthesis) + (-> ls;Arity (List Variable) ls;Synthesis ls;Synthesis) (` ("lux function" (~ (code;nat arity)) [(~@ (list/map code;int environment))] (~ body)))) @@ -53,7 +49,7 @@ (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ valueS)))) (def: (var$ var) - (-> ls;Variable ls;Synthesis) + (-> Variable ls;Synthesis) (` ((~ (code;int var))))) (def: (procedure$ name argsS) @@ -70,16 +66,17 @@ ls;Synthesis) (let [inputS (synthesize inputA)] (case (list;reverse branchesA) - (^multi (^ (list [(#la;BindP input-register) - (#la;Variable (#;Local output-register))])) - (n.= input-register output-register)) + (^multi (^ (list [(^code ("lux case bind" (~ [_ (#;Nat input-register)]))) + (^code ((~ [_ (#;Int var)])))])) + (variableL;local? var) + (n.= input-register (int-to-nat var))) inputS - (^ (list [(#la;BindP register) bodyA])) + (^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA])) (let$ register inputS (synthesize bodyA)) - (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA])) - (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA]))) + (^or (^ (list [(^code true) thenA] [(^code false) elseA])) + (^ (list [(^code false) elseA] [(^code true) thenA]))) (if$ inputS (synthesize thenA) (synthesize elseA)) (#;Cons [lastP lastA] prevsPA) @@ -98,6 +95,28 @@ (undefined) ))) +(def: (synthesize-apply synthesize outer-arity num-locals exprA) + (-> (-> la;Analysis ls;Synthesis) ls;Arity Nat la;Analysis ls;Synthesis) + (let [[funcA argsA] (&&function;unfold-apply exprA) + funcS (synthesize funcA) + argsS (list/map synthesize argsA)] + (case funcS + (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))]) + (and (n.= _arity (list;size argsS)) + (not (&&loop;contains-self-reference? _bodyS))) + [(s;run _env (p;some s;int)) (#e;Success _env)]) + (let [register-offset (if (&&function;top? outer-arity) + num-locals + (|> outer-arity n.inc (n.+ num-locals)))] + (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)] + (~ (&&loop;adjust _env register-offset _bodyS))))) + + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))]) + (call$ funcS' (list/compose argsS' argsS)) + + _ + (call$ funcS argsS)))) + (def: #export (synthesize analysis) (-> la;Analysis ls;Synthesis) (loop [outer-arity +0 @@ -105,53 +124,39 @@ num-locals +0 exprA analysis] (case exprA - #la;Unit - (' []) - - (^template [<from> <to>] - (<from> value) - (<to> value)) - ([#la;Bool code;bool] - [#la;Nat code;nat] - [#la;Int code;int] - [#la;Deg code;deg] - [#la;Frac code;frac] - [#la;Text code;text] - [#la;Definition code;symbol]) - - (#la;Product _) - (` [(~@ (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))]) - - (#la;Sum choice) - (let [[tag last? value] (&&structure;unfold-variant choice)] + (^code [(~ _left) (~ _right)]) + (` [(~@ (list/map (recur +0 resolver num-locals) (la;unfold-tuple exprA)))]) + + (^or (^code ("lux sum left" (~ _))) + (^code ("lux sum right" (~ _)))) + (let [[tag last? value] (maybe;assume (la;unfold-variant exprA))] (variant$ tag last? (recur +0 resolver num-locals value))) - (#la;Variable ref) - (case ref - (#;Local register) - (if (&&function;nested? outer-arity) - (if (n.= +0 register) - (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity)) - (list/map (|>. &&function;to-local code;int (~) () (`))))) - (var$ (&&function;adjust-var outer-arity (&&function;to-local register)))) - (var$ (&&function;to-local register))) - - (#;Captured register) - (var$ (let [var (&&function;to-captured register)] - (maybe;default var (dict;get var resolver))))) - - (#la;Case inputA branchesA) + (^code ((~ [_ (#;Int var)]))) + (if (variableL;local? var) + (let [register (variableL;local-register var)] + (if (&&function;nested? outer-arity) + (if (n.= +0 register) + (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity)) + (list/map (|>. variableL;local code;int (~) () (`))))) + (var$ (&&function;adjust-var outer-arity (variableL;local register)))) + (var$ (variableL;local register)))) + (let [register (variableL;captured-register var)] + (var$ (let [var (variableL;captured register)] + (maybe;default var (dict;get var resolver)))))) + + (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)]))) (synthesize-case (recur +0 resolver num-locals) inputA branchesA) - - (#la;Function scope bodyA) + + (^multi (^code ("lux function" [(~@ scope)] (~ bodyA))) + [(s;run scope (p;some s;int)) (#e;Success raw-env)]) (let [inner-arity (n.inc outer-arity) - raw-env (&&function;environment scope) env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env) env-vars (let [env-size (list;size raw-env)] - (: (List ls;Variable) + (: (List Variable) (case env-size +0 (list) - _ (list/map &&function;to-captured (list;n.range +0 (n.dec env-size)))))) + _ (list/map variableL;captured (list;n.range +0 (n.dec env-size)))))) resolver' (if (&&function;nested? inner-arity) (list/fold (function [[from to] resolver'] (dict;put from to resolver')) @@ -169,27 +174,11 @@ bodyS (function$ +1 env (prepare-body inner-arity +1 bodyS)))) - (#la;Apply _) - (let [[funcA argsA] (&&function;unfold-apply exprA) - funcS (recur +0 resolver num-locals funcA) - argsS (list/map (recur +0 resolver num-locals) argsA)] - (case funcS - (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))]) - (and (n.= _arity (list;size argsS)) - (not (&&loop;contains-self-reference? _bodyS))) - [(parse-environment _env) (#e;Success _env)]) - (let [register-offset (if (&&function;top? outer-arity) - num-locals - (|> outer-arity n.inc (n.+ num-locals)))] - (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)] - (~ (&&loop;adjust _env register-offset _bodyS))))) - - (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))]) - (call$ funcS' (list/compose argsS' argsS)) - - _ - (call$ funcS argsS))) - - (#la;Procedure name args) + (^code ("lux apply" (~@ _))) + (synthesize-apply synthesize outer-arity num-locals exprA) + + (^code ((~ [_ (#;Text name)]) (~@ args))) (procedure$ name (list/map (recur +0 resolver num-locals) args)) - ))) + + _ + exprA))) |