diff options
Diffstat (limited to 'new-luxc/source/luxc/lang')
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/case.lux | 70 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/expression.lux | 184 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/function.lux | 29 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/loop.lux | 185 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/variable.lux | 98 |
5 files changed, 566 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux new file mode 100644 index 000000000..15cb6eca3 --- /dev/null +++ b/new-luxc/source/luxc/lang/synthesis/case.lux @@ -0,0 +1,70 @@ +(;module: + lux + (lux (data [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>] + [number] + (coll [list "list/" Fold<List>])) + (meta [code "code/" Eq<Code>])) + (luxc (lang ["la" analysis] + ["ls" synthesis]))) + +(def: #export (path pattern) + (-> la;Pattern ls;Path) + (case pattern + (^code [(~@ membersP)]) + (case (list;reverse membersP) + #;Nil + (' ("lux case pop")) + + (#;Cons singletonP #;Nil) + (path singletonP) + + (#;Cons lastP prevsP) + (let [length (list;size membersP) + last-idx (n.dec length) + [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]] + [(n.dec current-idx) + (` ("lux case seq" + ("lux case tuple left" (~ (code;nat current-idx)) (~ (path current-pattern))) + (~ next-path)))]) + [(n.dec last-idx) + (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))] + prevsP)] + tuple-path)) + + (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) + (if (n.= (n.dec num-tags) tag) + (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP)))) + (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP))))) + + _ + pattern)) + +(def: #export (weave leftP rightP) + (-> ls;Path ls;Path ls;Path) + (with-expansions [<default> (as-is (` ("lux case alt" (~ leftP) (~ rightP))))] + (case [leftP rightP] + (^template [<special>] + (^ [[_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat left-idx)] left-then))] + [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat right-idx)] right-then))]]) + (if (n.= left-idx right-idx) + (` (<special> (~ (code;nat left-idx)) (~ (weave left-then right-then)))) + <default>)) + (["lux case tuple left"] + ["lux case tuple right"] + ["lux case variant left"] + ["lux case variant right"]) + + (^ [[_ (#;Form (list [_ (#;Text "lux case seq")] left-pre left-post))] + [_ (#;Form (list [_ (#;Text "lux case seq")] right-pre right-post))]]) + (case (weave left-pre right-pre) + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] _ _))]) + <default> + + weavedP + (` ("lux case seq" (~ weavedP) (~ (weave left-post right-post))))) + + _ + (if (code/= leftP rightP) + leftP + <default>)))) diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux new file mode 100644 index 000000000..05b99923b --- /dev/null +++ b/new-luxc/source/luxc/lang/synthesis/expression.lux @@ -0,0 +1,184 @@ +(;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] + (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<Int>)) + +(def: (prepare-body inner-arity arity body) + (-> Nat Nat 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 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" (~ (caseS;path pattern))) + (`))))] + (` ("lux case" (~ inputS) + (~ (list/fold caseS;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] (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 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 (functionS;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$ (functionS;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 (functionS;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))) diff --git a/new-luxc/source/luxc/lang/synthesis/function.lux b/new-luxc/source/luxc/lang/synthesis/function.lux new file mode 100644 index 000000000..52aee9a49 --- /dev/null +++ b/new-luxc/source/luxc/lang/synthesis/function.lux @@ -0,0 +1,29 @@ +(;module: + lux + (luxc (lang ["la" analysis] + ["ls" synthesis] + [";L" variable #+ Variable]))) + +(do-template [<name> <comp> <ref>] + [(def: #export (<name> arity) + (-> ls;Arity Bool) + (<comp> <ref> arity))] + + [nested? n.> +1] + [top? n.= +0] + ) + +(def: #export (adjust-var outer var) + (-> ls;Arity Variable Variable) + (|> outer n.dec nat-to-int (i.+ var))) + +(def: #export (unfold-apply apply) + (-> la;Analysis [la;Analysis (List la;Analysis)]) + (loop [apply apply + args (list)] + (case apply + (^code ("lux apply" (~ arg) (~ func))) + (recur func (#;Cons arg args)) + + _ + [apply args]))) diff --git a/new-luxc/source/luxc/lang/synthesis/loop.lux b/new-luxc/source/luxc/lang/synthesis/loop.lux new file mode 100644 index 000000000..0070fcd5d --- /dev/null +++ b/new-luxc/source/luxc/lang/synthesis/loop.lux @@ -0,0 +1,185 @@ +(;module: + lux + (lux (control [monad #+ do] + ["p" parser]) + (data [maybe] + (coll [list "list/" Functor<List>])) + (meta [code] + [syntax])) + (luxc (lang ["ls" synthesis] + [";L" variable #+ Variable Register]))) + +(def: #export (contains-self-reference? exprS) + (-> ls;Synthesis Bool) + (case exprS + (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] memberS))]) + (contains-self-reference? memberS) + + [_ (#;Tuple membersS)] + (list;any? contains-self-reference? membersS) + + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (variableL;self? var) + + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (or (contains-self-reference? inputS) + (loop [pathS pathS] + (case pathS + (^or (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))])) + (or (recur leftS) + (recur rightS)) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (contains-self-reference? bodyS) + + _ + false))) + + (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (list;any? (function [captured] + (case captured + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (variableL;self? var) + + _ + false)) + environment) + + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) + (or (contains-self-reference? funcS) + (list;any? contains-self-reference? argsS)) + + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) + (or (contains-self-reference? inputS) + (contains-self-reference? bodyS)) + + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (or (contains-self-reference? inputS) + (contains-self-reference? thenS) + (contains-self-reference? elseS)) + + (^ [_ (#;Form (list [_ (#;Text "lux loop")] offset [_ (#;Tuple initsS)] bodyS))]) + (or (list;any? contains-self-reference? initsS) + (contains-self-reference? bodyS)) + + (^or (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])) + (list;any? contains-self-reference? argsS) + + _ + false + )) + +(def: #export (reify-recursion arity exprS) + (-> Nat ls;Synthesis ls;Synthesis) + (loop [exprS exprS] + (case exprS + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (` ("lux case" (~ inputS) + (~ (let [reify-recursion' recur] + (loop [pathS pathS] + (case pathS + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) + (` ("lux case alt" (~ (recur leftS)) (~ (recur rightS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))]) + (` ("lux case seq" (~ leftS) (~ (recur rightS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (` ("lux case exec" (~ (reify-recursion' bodyS)))) + + _ + pathS)))))) + + (^multi (^ [_ (#;Form (list& [_ (#;Text "lux call")] + [_ (#;Form (list [_ (#;Int 0)]))] + argsS))]) + (n.= arity (list;size argsS))) + (` ("lux recur" (~@ argsS))) + + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) + (` ("lux let" (~ register) (~ inputS) (~ (recur bodyS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (` ("lux if" (~ inputS) (~ (recur thenS)) (~ (recur elseS)))) + + _ + exprS + ))) + +(def: #export (adjust env outer-offset exprS) + (-> (List Variable) Register ls;Synthesis ls;Synthesis) + (let [resolve-captured (: (-> Variable Variable) + (function [var] + (let [idx (|> var (i.* -1) int-to-nat n.dec)] + (|> env (list;nth idx) maybe;assume))))] + (loop [exprS exprS] + (case exprS + (^ [_ (#;Form (list [_ (#;Nat tag)] last? valueS))]) + (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS)))) + + [_ (#;Tuple members)] + [_ (#;Tuple (list/map recur members))] + + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (` ("lux case" (~ (recur inputS)) + (~ (let [adjust' recur] + (loop [pathS pathS] + (case pathS + (^template [<pattern>] + (^ [_ (#;Form (list [_ (#;Text <pattern>)] leftS rightS))]) + (` (<pattern> (~ (recur leftS)) (~ (recur rightS))))) + (["lux case alt"] + ["lux case seq"]) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (` ("lux case exec" (~ (adjust' bodyS)))) + + _ + pathS)))))) + + (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (` ("lux function" (~ arity) + (~ [_ (#;Tuple (list/map (function [_var] + (case _var + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (` ((~ (code;int (resolve-captured var))))) + + _ + _var)) + environment))]) + (~ (recur bodyS)))) + + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) + (` ("lux call" (~ (recur funcS)) (~@ (list/map recur argsS)))) + + (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) + (` ("lux recur" (~@ (list/map recur argsS)))) + + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) + (` ((~ (code;text procedure)) (~@ (list/map recur argsS)))) + + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (if (variableL;captured? var) + (` ((~ (code;int (resolve-captured var))))) + (` ((~ (code;int (|> outer-offset nat-to-int (i.+ var))))))) + + (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS bodyS))]) + (` ("lux let" (~ (code;nat (n.+ outer-offset register))) + (~ (recur inputS)) + (~ (recur bodyS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (` ("lux if" (~ (recur inputS)) + (~ (recur thenS)) + (~ (recur elseS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat inner-offset)] [_ (#;Tuple initsS)] bodyS))]) + (` ("lux loop" (~ (code;nat (n.+ outer-offset inner-offset))) + [(~@ (list/map recur initsS))] + (~ (recur bodyS)))) + + _ + exprS + )))) diff --git a/new-luxc/source/luxc/lang/synthesis/variable.lux b/new-luxc/source/luxc/lang/synthesis/variable.lux new file mode 100644 index 000000000..3ce9f2678 --- /dev/null +++ b/new-luxc/source/luxc/lang/synthesis/variable.lux @@ -0,0 +1,98 @@ +(;module: + lux + (lux (data [number] + (coll [list "list/" Fold<List> Monoid<List>] + ["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 (nat-to-int register)) + + (^or (#ls;SeqP pre post) (#ls;AltP pre post)) + (list/compose (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/compose (path-bodies pre) (path-bodies post)) + + _ + (list))) + +(def: (non-arg? arity var) + (-> ls;Arity Variable Bool) + (and (variableL;local? var) + (n.> arity (int-to-nat var)))) + +(type: Tracker (s;Set Variable)) + +(def: init-tracker Tracker (s;new number;Hash<Int>)) + +(def: (unused-vars current-arity bound exprS) + (-> ls;Arity (List Variable) ls;Synthesis (List Variable)) + (let [tracker (loop [exprS exprS + tracker (list/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) + (list/fold recur tracker membersS) + + (#ls;Call funcS argsS) + (list/fold recur (recur funcS tracker) argsS) + + (^or (#ls;Recur argsS) + (#ls;Procedure name argsS)) + (list/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 (list/fold recur tracker initsS)) + + (#ls;Case inputS outputPS) + (let [tracker' (list/fold s;add + (recur inputS tracker) + (bound-vars outputPS))] + (list/fold recur tracker' (path-bodies outputPS))) + + (#ls;Function arity env bodyS) + (list/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)])) |