diff options
Diffstat (limited to 'new-luxc/source/luxc/synthesizer.lux')
| -rw-r--r-- | new-luxc/source/luxc/synthesizer.lux | 184 |
1 files changed, 0 insertions, 184 deletions
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux deleted file mode 100644 index c43958890..000000000 --- a/new-luxc/source/luxc/synthesizer.lux +++ /dev/null @@ -1,184 +0,0 @@ -(;module: - lux - (lux (control ["p" parser]) - (data [maybe] - ["e" error] - [number] - [product] - text/format - (coll [list "list/" Functor<List> Fold<List> Monoid<List>] - [dict #+ Dict])) - (meta [code] - ["s" syntax])) - (luxc ["&" base] - (lang ["la" analysis] - ["ls" synthesis] - [";L" variable #+ Variable]) - (synthesizer ["&&;" case] - ["&&;" function] - ["&&;" loop]) - )) - -(def: init-env (List Variable) (list)) -(def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>)) - -(def: (prepare-body inner-arity arity body) - (-> Nat Nat ls;Synthesis ls;Synthesis) - (if (&&function;nested? inner-arity) - body - (&&loop;reify-recursion arity body))) - -(def: (let$ register inputS bodyS) - (-> Nat ls;Synthesis ls;Synthesis ls;Synthesis) - (` ("lux let" (~ (code;nat register)) (~ inputS) (~ bodyS)))) - -(def: (if$ testS thenS elseS) - (-> ls;Synthesis ls;Synthesis ls;Synthesis ls;Synthesis) - (` ("lux if" (~ testS) - (~ thenS) - (~ elseS)))) - -(def: (function$ arity environment body) - (-> ls;Arity (List Variable) ls;Synthesis ls;Synthesis) - (` ("lux function" (~ (code;nat arity)) - [(~@ (list/map code;int environment))] - (~ body)))) - -(def: (variant$ tag last? valueS) - (-> Nat Bool ls;Synthesis ls;Synthesis) - (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ valueS)))) - -(def: (var$ var) - (-> Variable ls;Synthesis) - (` ((~ (code;int var))))) - -(def: (procedure$ name argsS) - (-> Text (List ls;Synthesis) ls;Synthesis) - (` ((~ (code;text name)) (~@ argsS)))) - -(def: (call$ funcS argsS) - (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis) - (` ("lux call" (~ funcS) (~@ argsS)))) - -(def: (synthesize-case synthesize inputA branchesA) - (-> (-> la;Analysis ls;Synthesis) - la;Analysis (List [la;Pattern la;Analysis]) - ls;Synthesis) - (let [inputS (synthesize inputA)] - (case (list;reverse branchesA) - (^multi (^ (list [(^code ("lux case bind" (~ [_ (#;Nat input-register)]))) - (^code ((~ [_ (#;Int var)])))])) - (not (variableL;captured? var)) - (n.= input-register (int-to-nat var))) - inputS - - (^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA])) - (let$ register inputS (synthesize bodyA)) - - (^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) - (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) - (function [pattern expr] - (|> (synthesize expr) - (~) ("lux case exec") - ("lux case seq" (~ (&&case;path pattern))) - (`))))] - (` ("lux case" (~ inputS) - (~ (list/fold &&case;weave - (transform-branch lastP lastA) - (list/map (product;uncurry transform-branch) prevsPA)))))) - - _ - (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 - resolver init-resolver - num-locals +0 - exprA analysis] - (case exprA - (^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))) - - (^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) - - (^multi (^code ("lux function" [(~@ scope)] (~ bodyA))) - [(s;run scope (p;some s;int)) (#e;Success raw-env)]) - (let [inner-arity (n.inc outer-arity) - env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env) - env-vars (let [env-size (list;size raw-env)] - (: (List Variable) - (case env-size - +0 (list) - _ (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')) - init-resolver - (list;zip2 env-vars env)) - (list/fold (function [var resolver'] - (dict;put var var resolver')) - init-resolver - env-vars))] - (case (recur inner-arity resolver' +0 bodyA) - (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))]) - (let [arity (n.inc arity')] - (function$ arity env (prepare-body inner-arity arity bodyS'))) - - bodyS - (function$ +1 env (prepare-body inner-arity +1 bodyS)))) - - (^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))) |