(;module: lux (lux (control ["p" parser]) (data [maybe] ["e" error] [number] [product] text/format (coll [list "list/" Functor Fold Monoid] [dict #+ Dict])) (meta [code] ["s" syntax])) (luxc ["&" base] (lang ["la" analysis] ["ls" synthesis] (synthesis [";S" case] [";S" function] [";S" loop]) [";L" variable #+ Variable]) )) (def: init-env (List Variable) (list)) (def: init-resolver (Dict Int Int) (dict;new number;Hash)) (def: (prepare-body inner-arity arity body) (-> ls;Arity ls;Arity ls;Synthesis ls;Synthesis) (if (functionS;nested? inner-arity) body (loopS;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 outer-arity inputA branchesA) (-> (-> la;Analysis ls;Synthesis) ls;Arity 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$ (if (functionS;nested? outer-arity) (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register) 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" (~ (caseS;path outer-arity pattern))) (`)))) pathS (list/fold caseS;weave (transform-branch lastP lastA) (list/map (product;uncurry transform-branch) prevsPA))] (` ("lux case" (~ inputS) (~ pathS)))) _ (undefined) ))) (def: (synthesize-apply synthesize outer-arity num-locals exprA) (-> (-> la;Analysis ls;Synthesis) ls;Arity Nat la;Analysis ls;Synthesis) (let [[funcA argsA] (functionS;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 (loopS;contains-self-reference? _bodyS))) [(s;run _env (p;some s;int)) (#e;Success _env)]) (let [register-offset (if (functionS;top? outer-arity) num-locals (|> outer-arity n.inc (n.+ num-locals)))] (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)] (~ (loopS;adjust _env register-offset _bodyS))))) (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))]) (call$ funcS' (list/compose argsS' argsS)) _ (call$ funcS argsS)))) (def: #export (synthesize expressionA) (-> la;Analysis ls;Synthesis) (loop [outer-arity +0 resolver init-resolver direct? false num-locals +0 expressionA expressionA] (case expressionA (^code [(~ _left) (~ _right)]) (` [(~@ (list/map (recur outer-arity resolver false num-locals) (la;unfold-tuple expressionA)))]) (^or (^code ("lux sum left" (~ _))) (^code ("lux sum right" (~ _)))) (let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))] (variant$ tag last? (recur outer-arity resolver false num-locals value))) (^code ((~ [_ (#;Int var)]))) (if (variableL;local? var) (if (functionS;nested? outer-arity) (if (variableL;self? var) (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity)) (list/map (|>. variableL;local code;int (~) () (`))))) (var$ (functionS;adjust-var outer-arity var))) (var$ var)) (var$ (maybe;default var (dict;get var resolver)))) (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)]))) (synthesize-case (recur outer-arity resolver false num-locals) outer-arity inputA branchesA) (^multi (^code ("lux function" [(~@ scope)] (~ bodyA))) [(s;run scope (p;some s;int)) (#e;Success raw-env)]) (let [inner-arity (if direct? (n.inc outer-arity) +1) env (list/map (function [closure] (case (dict;get closure resolver) (#;Some resolved) (if (and (variableL;local? resolved) (functionS;nested? outer-arity) (|> resolved variableL;local-register (n.>= outer-arity))) (functionS;adjust-var outer-arity resolved) resolved) #;None (if (and (variableL;local? closure) (functionS;nested? outer-arity)) (functionS;adjust-var outer-arity closure) closure))) raw-env) env-vars (: (List Variable) (case raw-env #;Nil (list) _ (|> (list;size raw-env) n.dec (list;n.range +0) (list/map variableL;captured)))) resolver' (if (and (functionS;nested? inner-arity) direct?) (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' true num-locals 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 (recur outer-arity resolver false num-locals) outer-arity num-locals expressionA) (^code ((~ [_ (#;Text name)]) (~@ args))) (procedure$ name (list/map (recur outer-arity resolver false num-locals) args)) _ expressionA)))