diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/expression.lux | 202 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/function.lux | 29 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/loop.lux | 188 |
3 files changed, 0 insertions, 419 deletions
diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux deleted file mode 100644 index 3fa594086..000000000 --- a/new-luxc/source/luxc/lang/synthesis/expression.lux +++ /dev/null @@ -1,202 +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>] - (dictionary ["dict" unordered #+ Dict]))) - (macro [code] - ["s" syntax])) - (luxc (lang ["la" analysis] - ["ls" synthesis] - [".L" extension #+ Syntheses] - (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) - (-> 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 arity num-locals synthesize inputA branchesA) - (-> ls.Arity Nat (-> Nat la.Analysis ls.Synthesis) - la.Analysis (List [la.Pattern la.Analysis]) - ls.Synthesis) - (let [inputS (synthesize num-locals inputA)] - (case (list.reverse branchesA) - (^multi (^ (list [(^code ("lux case bind" (~ [_ (#.Nat input-register)]))) - (^code ((~ [_ (#.Int var)])))])) - (not (variableL.captured? var)) - (n/= input-register (variableL.local-register var))) - inputS - - (^ (list [(^code ("lux case bind" (~ [_ (#.Nat register)]))) bodyA])) - (let$ (if (functionS.nested? arity) - (n/+ (n/dec arity) register) - register) - inputS - (synthesize (n/inc num-locals) bodyA)) - - (^or (^ (list [(^code true) thenA] [(^code false) elseA])) - (^ (list [(^code false) elseA] [(^code true) thenA]))) - (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA)) - - (#.Cons [lastP lastA] prevsPA) - (let [transform-branch (: (-> la.Pattern la.Analysis ls.Path) - (caseS.path arity num-locals synthesize)) - 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 num-locals exprA) - (-> (-> la.Analysis ls.Synthesis) Nat la.Analysis ls.Synthesis) - (let [[funcA argsA] (functionS.unfold-apply exprA) - funcS (synthesize funcA) - argsS (list/map synthesize argsA)] - (case funcS - (^multi (^code ("lux function" (~ [_ (#.Nat _arity)]) [(~+ _env)] (~ _bodyS))) - (and (n/= _arity (list.size argsS)) - (not (loopS.contains-self-reference? _bodyS))) - [(s.run _env (p.some s.int)) (#e.Success _env)]) - (` ("lux loop" (~ (code.nat (n/inc num-locals))) [(~+ argsS)] - (~ (loopS.adjust _env num-locals _bodyS)))) - - (^code ("lux call" (~ funcS') (~+ argsS'))) - (call$ funcS' (list/compose argsS' argsS)) - - _ - (call$ funcS argsS)))) - -(def: #export (synthesize extensions expressionA) - (-> Syntheses la.Analysis ls.Synthesis) - (loop [arity +0 - resolver init-resolver - direct? false - num-locals +0 - expressionA expressionA] - (case expressionA - (^code [(~ _left) (~ _right)]) - (` [(~+ (list/map (recur 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 arity resolver false num-locals value))) - - (^code ((~ [_ (#.Int var)]))) - (if (variableL.local? var) - (if (functionS.nested? arity) - (if (variableL.self? var) - (call$ (var$ 0) (|> (list.n/range +1 (n/dec arity)) - (list/map (|>> variableL.local code.int (~) () (`))))) - (var$ (functionS.adjust-var arity var))) - (var$ var)) - (var$ (maybe.default var (dict.get var resolver)))) - - (^code ("lux case" (~ inputA) (~ [_ (#.Record branchesA)]))) - (synthesize-case arity num-locals (recur arity resolver false) inputA branchesA) - - (^multi (^code ("lux function" [(~+ scope)] (~ bodyA))) - [(s.run scope (p.some s.int)) (#e.Success raw-env)]) - (let [function-arity (if direct? - (n/inc arity) - +1) - env (list/map (function (_ closure) - (case (dict.get closure resolver) - (#.Some resolved) - (if (and (variableL.local? resolved) - (functionS.nested? arity) - (|> resolved variableL.local-register (n/>= arity))) - (functionS.adjust-var arity resolved) - resolved) - - #.None - (if (and (variableL.local? closure) - (functionS.nested? arity)) - (functionS.adjust-var 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? function-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 function-arity resolver' true function-arity bodyA) - (^ [_ (#.Form (list [_ (#.Text "lux function")] [_ (#.Nat unmerged-arity)] env' bodyS'))]) - (let [merged-arity (n/inc unmerged-arity)] - (function$ merged-arity env - (prepare-body function-arity merged-arity bodyS'))) - - bodyS - (function$ +1 env (prepare-body function-arity +1 bodyS)))) - - (^code ("lux apply" (~+ _))) - (synthesize-apply (recur arity resolver false num-locals) num-locals expressionA) - - (^code ((~ [_ (#.Text name)]) (~+ args))) - (case (dict.get name extensions) - #.None - (procedure$ name (list/map (recur arity resolver false num-locals) args)) - - (#.Some extension) - (extension (recur arity resolver false num-locals) args)) - - _ - expressionA))) diff --git a/new-luxc/source/luxc/lang/synthesis/function.lux b/new-luxc/source/luxc/lang/synthesis/function.lux deleted file mode 100644 index 25dd75aff..000000000 --- a/new-luxc/source/luxc/lang/synthesis/function.lux +++ /dev/null @@ -1,29 +0,0 @@ -(.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 deleted file mode 100644 index c00d5626b..000000000 --- a/new-luxc/source/luxc/lang/synthesis/loop.lux +++ /dev/null @@ -1,188 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["p" parser]) - (data [maybe] - (coll [list "list/" Functor<List>])) - (macro [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 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 - (^code ((~ [_ (#.Nat tag)]) (~ last?) (~ valueS))) - (` ((~ (code.nat tag)) (~ last?) (~ (recur valueS)))) - - (^code [(~+ members)]) - (` [(~+ (list/map recur members))]) - - (^code ("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"]) - - (^code ("lux case bind" (~ [_ (#.Nat register)]))) - (` ("lux case bind" (~ (code.nat (n/+ offset register))))) - - (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))]) - (` ("lux case exec" (~ (adjust' bodyS)))) - - _ - pathS)))))) - - (^code ("lux function" (~ arity) [(~+ environment)] (~ bodyS))) - (` ("lux function" (~ arity) - [(~+ (list/map (function (_ _var) - (case _var - (^ [_ (#.Form (list [_ (#.Int var)]))]) - (` ((~ (code.int (resolve-captured var))))) - - _ - _var)) - environment))] - (~ 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)))) - - (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ bodyS))) - (` ("lux let" (~ (code.nat (n/+ 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 loop-offset)] [_ (#.Tuple initsS)] bodyS))]) - (` ("lux loop" (~ (code.nat (n/+ offset loop-offset))) - [(~+ (list/map recur initsS))] - (~ (recur bodyS)))) - - (^ [_ (#.Form (list [_ (#.Int var)]))]) - (if (variableL.captured? var) - (` ((~ (code.int (resolve-captured var))))) - (` ((~ (code.int (|> offset nat-to-int (i/+ var))))))) - - (^ [_ (#.Form (list& [_ (#.Text procedure)] argsS))]) - (` ((~ (code.text procedure)) (~+ (list/map recur argsS)))) - - _ - exprS - )))) |