diff options
Diffstat (limited to 'new-luxc/source')
| -rw-r--r-- | new-luxc/source/luxc/generator/case.jvm.lux | 162 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/expr.jvm.lux | 57 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/common.jvm.lux | 5 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/host.jvm.lux | 33 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis.lux | 38 | ||||
| -rw-r--r-- | new-luxc/source/luxc/synthesizer.lux | 167 | ||||
| -rw-r--r-- | new-luxc/source/luxc/synthesizer/case.lux | 96 | ||||
| -rw-r--r-- | new-luxc/source/luxc/synthesizer/loop.lux | 224 |
8 files changed, 408 insertions, 374 deletions
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux index f20c83f6e..a619768bb 100644 --- a/new-luxc/source/luxc/generator/case.jvm.lux +++ b/new-luxc/source/luxc/generator/case.jvm.lux @@ -1,8 +1,11 @@ (;module: lux - (lux (control [monad #+ do]) + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data text/format) [meta "meta/" Monad<Meta>]) - (luxc [";L" host] + (luxc ["_" base] + [";L" host] (lang ["ls" synthesis]) (generator (host ["$" jvm] (jvm ["$t" type] @@ -49,50 +52,52 @@ (list)) false))) -(def: (generate-pattern' generate stack-depth @else @end path) +(exception: #export Unrecognized-Path) + +(def: (generate-path' generate stack-depth @else @end path) (-> (-> ls;Synthesis (Meta $;Inst)) Nat $;Label $;Label ls;Path (Meta $;Inst)) (case path - (#ls;ExecP bodyS) + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (do meta;Monad<Meta> [bodyI (generate bodyS)] (wrap (|>. (pop-altI stack-depth) bodyI ($i;GOTO @end)))) - #ls;UnitP + (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))]) (meta/wrap popI) - (#ls;BindP register) + (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))]) (meta/wrap (|>. peekI ($i;ASTORE register) popI)) - (#ls;BoolP value) + [_ (#;Bool value)] (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] (|>. peekI ($i;unwrap #$;Boolean) (jumpI @else)))) (^template [<tag> <prep>] - (<tag> value) + [_ (<tag> value)] (meta/wrap (|>. peekI ($i;unwrap #$;Long) ($i;long (|> value <prep>)) $i;LCMP ($i;IFNE @else)))) - ([#ls;NatP (:! Int)] - [#ls;IntP (: Int)] - [#ls;DegP (:! Int)]) + ([#;Nat (:! Int)] + [#;Int (: Int)] + [#;Deg (:! Int)]) - (#ls;FracP value) + [_ (#;Frac value)] (meta/wrap (|>. peekI ($i;unwrap #$;Double) ($i;double value) $i;DCMPL ($i;IFNE @else))) - (#ls;TextP value) + [_ (#;Text value)] (meta/wrap (|>. peekI ($i;string value) ($i;INVOKEVIRTUAL "java.lang.Object" @@ -103,95 +108,88 @@ false) ($i;IFEQ @else))) - (#ls;TupleP idx subP) - (do meta;Monad<Meta> - [subI (generate-pattern' generate stack-depth @else @end subP) - #let [[idx tail?] (case idx - (#;Left idx) - [idx false] - - (#;Right idx) - [idx true])]] - (wrap (case idx - +0 - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) - ($i;int 0) - $i;AALOAD - pushI - subI) - - _ - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) - ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC hostL;runtime-class - (if tail? "pm_right" "pm_left") - ($t;method (list ../runtime;$Tuple $t;int) - (#;Some $Object) - (list)) - false) - pushI - subI)))) - - (#ls;VariantP idx subP) - (do meta;Monad<Meta> - [subI (generate-pattern' generate stack-depth @else @end subP) - #let [[idx last?] (case idx - (#;Left idx) - [idx false] - - (#;Right idx) - [idx true]) - flagI (if last? - ($i;string "") - $i;NULL)]] - (wrap (<| $i;with-label (function [@success]) - $i;with-label (function [@fail]) + (^template [<special> <method>] + (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))]) + (do meta;Monad<Meta> + [subI (generate-path' generate stack-depth @else @end subP)] + (wrap (case idx + +0 + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int 0) + $i;AALOAD + pushI + subI) + + _ (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) ($i;int (nat-to-int idx)) - flagI - ($i;INVOKESTATIC hostL;runtime-class "pm_variant" - ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) - (#;Some ../runtime;$Datum) + ($i;INVOKESTATIC hostL;runtime-class + <method> + ($t;method (list ../runtime;$Tuple $t;int) + (#;Some $Object) (list)) false) - $i;DUP - ($i;IFNULL @fail) - ($i;GOTO @success) - ($i;label @fail) - $i;POP - ($i;GOTO @else) - ($i;label @success) pushI - subI)))) - - (#ls;SeqP leftP rightP) + subI))))) + (["lux case tuple left" "pm_left"] + ["lux case tuple right" "pm_right"]) + + (^template [<special> <flag>] + (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))]) + (do meta;Monad<Meta> + [subI (generate-path' generate stack-depth @else @end subP)] + (wrap (<| $i;with-label (function [@success]) + $i;with-label (function [@fail]) + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) + ($i;int (nat-to-int idx)) + <flag> + ($i;INVOKESTATIC hostL;runtime-class "pm_variant" + ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) + (#;Some ../runtime;$Datum) + (list)) + false) + $i;DUP + ($i;IFNULL @fail) + ($i;GOTO @success) + ($i;label @fail) + $i;POP + ($i;GOTO @else) + ($i;label @success) + pushI + subI))))) + (["lux case variant left" $i;NULL] + ["lux case variant right" ($i;string "")]) + + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))]) (do meta;Monad<Meta> - [leftI (generate-pattern' generate stack-depth @else @end leftP) - rightI (generate-pattern' generate stack-depth @else @end rightP)] + [leftI (generate-path' generate stack-depth @else @end leftP) + rightI (generate-path' generate stack-depth @else @end rightP)] (wrap (|>. leftI rightI))) - (#ls;AltP leftP rightP) + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))]) (do meta;Monad<Meta> [@alt-else $i;make-label - leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP) - rightI (generate-pattern' generate stack-depth @else @end rightP)] + leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP) + rightI (generate-path' generate stack-depth @else @end rightP)] (wrap (|>. $i;DUP leftI ($i;label @alt-else) $i;POP rightI))) - )) -(def: (generate-pattern generate path @end) + _ + (_;throw Unrecognized-Path (%code path)))) + +(def: (generate-path generate path @end) (-> (-> ls;Synthesis (Meta $;Inst)) ls;Path $;Label (Meta $;Inst)) (do meta;Monad<Meta> [@else $i;make-label - pathI (generate-pattern' generate +1 @else @end path)] + pathI (generate-path' generate +1 @else @end path)] (wrap (|>. pathI ($i;label @else) $i;POP @@ -208,7 +206,7 @@ (do meta;Monad<Meta> [@end $i;make-label valueI (generate valueS) - pathI (generate-pattern generate path @end)] + pathI (generate-path generate path @end)] (wrap (|>. valueI $i;NULL $i;SWAP diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux index 685bf2335..b439ff17a 100644 --- a/new-luxc/source/luxc/generator/expr.jvm.lux +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -1,9 +1,12 @@ (;module: lux (lux (control monad - ["ex" exception #+ exception:]) - (data text/format) - [meta #+ Monad<Meta> "Meta/" Monad<Meta>]) + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + text/format) + [meta] + (meta ["s" syntax])) (luxc ["&" base] (lang ["ls" synthesis]) ["&;" analyser] @@ -24,48 +27,52 @@ (def: #export (generate synthesis) (-> ls;Synthesis (Meta $;Inst)) (case synthesis - #ls;Unit + [_ (#;Tuple #;Nil)] &primitive;generate-unit + (^ [_ (#;Tuple (list singleton))]) + (generate singleton) + (^template [<tag> <generator>] - (<tag> value) + [_ (<tag> value)] (<generator> value)) - ([#ls;Bool &primitive;generate-bool] - [#ls;Nat &primitive;generate-nat] - [#ls;Int &primitive;generate-int] - [#ls;Deg &primitive;generate-deg] - [#ls;Frac &primitive;generate-frac] - [#ls;Text &primitive;generate-text]) + ([#;Bool &primitive;generate-bool] + [#;Nat &primitive;generate-nat] + [#;Int &primitive;generate-int] + [#;Deg &primitive;generate-deg] + [#;Frac &primitive;generate-frac] + [#;Text &primitive;generate-text]) - (#ls;Variant tag tail? member) - (&structure;generate-variant generate tag tail? member) + (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] valueS))]) + (&structure;generate-variant generate tag last? valueS) - (#ls;Tuple members) + [_ (#;Tuple members)] (&structure;generate-tuple generate members) - (#ls;Variable var) + (^ [_ (#;Form (list [_ (#;Int var)]))]) (if (functionS;captured? var) (&reference;generate-captured var) (&reference;generate-variable var)) - (#ls;Definition definition) + [_ (#;Symbol definition)] (&reference;generate-definition definition) - (#ls;Let register inputS exprS) + (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS exprS))]) (caseG;generate-let generate register inputS exprS) - (#ls;Case inputS pathPS) + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathPS))]) (caseG;generate-case generate inputS pathPS) - (#ls;Function arity env body) - (&function;generate-function generate env arity body) + (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity)] [_ (#;Tuple environment)] bodyS))]) + [(s;run environment (p;some s;int)) (#e;Success environment)]) + (&function;generate-function generate environment arity bodyS) - (#ls;Call args function) - (&function;generate-call generate function args) + (^ [_ (#;Form (list& [_ (#;Text "lux call")] functionS argsS))]) + (&function;generate-call generate functionS argsS) - (#ls;Procedure name args) - (&procedure;generate-procedure generate name args) + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) + (&procedure;generate-procedure generate procedure argsS) _ - (&;throw Unrecognized-Synthesis "") + (&;throw Unrecognized-Synthesis (%code synthesis)) )) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index fd76082a6..7ae471c64 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -146,6 +146,10 @@ ($i;CHECKCAST hostL;function-class) ($i;INVOKESTATIC hostL;runtime-class "try" try-method false))) +(def: (lux//noop valueI) + Unary + valueI) + ## [[Bits]] (do-template [<name> <op>] [(def: (<name> [inputI maskI]) @@ -536,6 +540,7 @@ (def: lux-procs Bundle (|> (dict;new text;Hash<Text>) + (install "lux noop" (unary lux//noop)) (install "lux is" (binary lux//is)) (install "lux try" (unary lux//try)))) diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index fc6bdd01b..44da5744d 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -37,6 +37,7 @@ [L2S (|>. $i;L2I $i;I2S)] [L2B (|>. $i;L2I $i;I2B)] + [L2C (|>. $i;L2I $i;I2C)] ) (do-template [<name> <unwrap> <conversion> <wrap>] @@ -68,6 +69,7 @@ [convert//long-to-int #$;Long $i;L2I #$;Int] [convert//long-to-short #$;Long L2S #$;Short] [convert//long-to-byte #$;Long L2B #$;Byte] + [convert//long-to-char #$;Long L2C #$;Char] [convert//char-to-byte #$;Char $i;I2B #$;Byte] [convert//char-to-short #$;Char $i;I2S #$;Short] [convert//char-to-int #$;Char $i;NOP #$;Int] @@ -97,6 +99,7 @@ (@;install "long-to-int" (@;unary convert//long-to-int)) (@;install "long-to-short" (@;unary convert//long-to-short)) (@;install "long-to-byte" (@;unary convert//long-to-byte)) + (@;install "long-to-char" (@;unary convert//long-to-char)) (@;install "char-to-byte" (@;unary convert//char-to-byte)) (@;install "char-to-short" (@;unary convert//char-to-short)) (@;install "char-to-int" (@;unary convert//char-to-int)) @@ -278,7 +281,7 @@ (def: (array//new proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Nat level) (#ls;Text class) lengthS)) + (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS)) (do meta;Monad<Meta> [lengthI (generate lengthS) #let [arrayJT ($t;array level (case class @@ -302,7 +305,7 @@ (def: (array//read proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) idxS arrayS)) + (^ (list [_ (#;Text class)] idxS arrayS)) (do meta;Monad<Meta> [arrayI (generate arrayS) idxI (generate idxS) @@ -328,7 +331,7 @@ (def: (array//write proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) idxS valueS arrayS)) + (^ (list [_ (#;Text class)] idxS valueS arrayS)) (do meta;Monad<Meta> [arrayI (generate arrayS) idxI (generate idxS) @@ -397,7 +400,7 @@ (def: (object//class proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class))) + (^ (list [_ (#;Text class)])) (do meta;Monad<Meta> [] (wrap (|>. ($i;string class) @@ -413,7 +416,7 @@ (def: (object//instance? proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) objectS)) + (^ (list [_ (#;Text class)] objectS)) (do meta;Monad<Meta> [objectI (generate objectS)] (wrap (|>. objectI @@ -450,7 +453,7 @@ (def: (static//get proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed))) + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)])) (do meta;Monad<Meta> [] (case (dict;get unboxed primitives) @@ -477,7 +480,7 @@ (def: (static//put proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS)) + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS)) (do meta;Monad<Meta> [valueI (generate valueS)] (case (dict;get unboxed primitives) @@ -509,7 +512,7 @@ (def: (virtual//get proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) objectS)) + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS)) (do meta;Monad<Meta> [objectI (generate objectS)] (case (dict;get unboxed primitives) @@ -540,7 +543,7 @@ (def: (virtual//put proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS objectS)) + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS)) (do meta;Monad<Meta> [valueI (generate valueS) objectI (generate objectS)] @@ -632,7 +635,7 @@ #;Nil (meta/wrap #;Nil) - (^ (list& [(#ls;Tuple (list (#ls;Text argD) argS))] tail)) + (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail)) (do meta;Monad<Meta> [argT (generate-type argD) argI (:: @ map (prepare-input argT) (generate argS)) @@ -669,8 +672,8 @@ (def: (invoke//static proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list& (#ls;Text class) (#ls;Text method) - (#ls;Text unboxed) argsS)) + (^ (list& [_ (#;Text class)] [_ (#;Text method)] + [_ (#;Text unboxed)] argsS)) (do meta;Monad<Meta> [argsTI (generate-args generate argsS) returnT (method-return-type unboxed) @@ -687,8 +690,8 @@ [(def: (<name> proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list& (#ls;Text class) (#ls;Text method) - (#ls;Text unboxed) objectS argsS)) + (^ (list& [_ (#;Text class)] [_ (#;Text method)] + [_ (#;Text unboxed)] objectS argsS)) (do meta;Monad<Meta> [objectI (generate objectS) argsTI (generate-args generate argsS) @@ -712,7 +715,7 @@ (def: (invoke//constructor proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list& (#ls;Text class) argsS)) + (^ (list& [_ (#;Text class)] argsS)) (do meta;Monad<Meta> [argsTI (generate-args generate argsS)] (wrap (|>. ($i;NEW class) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux index dab2d84e6..96053edc0 100644 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ b/new-luxc/source/luxc/lang/synthesis.lux @@ -5,40 +5,6 @@ (def: #export Register Nat) (def: #export Variable Int) -(type: #export (Path' s) - #UnitP - (#BoolP Bool) - (#NatP Nat) - (#IntP Int) - (#DegP Deg) - (#FracP Frac) - (#TextP Text) - (#VariantP (Either Nat Nat) (Path' s)) - (#TupleP (Either Nat Nat) (Path' s)) - (#BindP Nat) - (#AltP (Path' s) (Path' s)) - (#SeqP (Path' s) (Path' s)) - (#ExecP s)) +(type: #export Synthesis Code) -(type: #export #rec Synthesis - #Unit - (#Bool Bool) - (#Nat Nat) - (#Int Int) - (#Deg Deg) - (#Frac Frac) - (#Text Text) - (#Variant Nat Bool Synthesis) - (#Tuple (List Synthesis)) - (#Case Synthesis (Path' Synthesis)) - (#Function Arity (List Variable) Synthesis) - (#Call (List Synthesis) Synthesis) - (#Recur (List Synthesis)) - (#Procedure Text (List Synthesis)) - (#Variable Variable) - (#Definition Ident) - (#Let Register Synthesis Synthesis) - (#If Synthesis Synthesis Synthesis) - (#Loop Register (List Synthesis) Synthesis)) - -(type: #export Path (Path' Synthesis)) +(type: #export Path Code) diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 011dfd8ae..e1eb67bd7 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -1,11 +1,15 @@ (;module: lux - (lux (data [maybe] + (lux (control ["p" parser]) + (data [maybe] + ["e" error] [number] [product] text/format (coll [list "list/" Functor<List> Fold<List> Monoid<List>] - [dict #+ Dict]))) + [dict #+ Dict])) + (meta [code] + ["s" syntax])) (luxc ["&" base] (lang ["la" analysis] ["ls" synthesis]) @@ -24,6 +28,76 @@ 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)))) + +(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 ls;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) + (-> ls;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 [(#la;BindP input-register) + (#la;Variable (#;Local output-register))])) + (n.= input-register output-register)) + inputS + + (^ (list [(#la;BindP 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]))) + (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: #export (synthesize analysis) (-> la;Analysis ls;Synthesis) (loop [outer-arity +0 @@ -31,71 +105,43 @@ num-locals +0 exprA analysis] (case exprA + #la;Unit + (' []) + (^template [<from> <to>] (<from> value) (<to> value)) - ([#la;Unit #ls;Unit] - [#la;Bool #ls;Bool] - [#la;Nat #ls;Nat] - [#la;Int #ls;Int] - [#la;Deg #ls;Deg] - [#la;Frac #ls;Frac] - [#la;Text #ls;Text] - [#la;Definition #ls;Definition]) + ([#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 _) - (#ls;Tuple (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA))) + (` [(~@ (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))]) (#la;Sum choice) (let [[tag last? value] (&&structure;unfold-variant choice)] - (#ls;Variant tag last? (recur +0 resolver num-locals value))) + (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) - (#ls;Call (|> (list;n.range +1 (n.dec outer-arity)) - (list/map (|>. &&function;to-local #ls;Variable))) - (#ls;Variable 0)) - (#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register)))) - (#ls;Variable (&&function;to-local 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) - (#ls;Variable (let [var (&&function;to-captured register)] - (maybe;default var (dict;get var resolver))))) + (var$ (let [var (&&function;to-captured register)] + (maybe;default var (dict;get var resolver))))) (#la;Case inputA branchesA) - (let [inputS (recur +0 resolver num-locals inputA)] - (case (list;reverse branchesA) - (^multi (^ (list [(#la;BindP input-register) - (#la;Variable (#;Local output-register))])) - (n.= input-register output-register)) - inputS - - (^ (list [(#la;BindP register) bodyA])) - (#ls;Let register inputS (recur +0 resolver num-locals bodyA)) - - (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA])) - (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA]))) - (#ls;If inputS - (recur +0 resolver num-locals thenA) - (recur +0 resolver num-locals elseA)) - - (#;Cons [lastP lastA] prevsPA) - (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) - (function [pattern expr] - (|> (recur +0 resolver num-locals expr) - #ls;ExecP - (#ls;SeqP (&&case;path pattern)))))] - (#ls;Case inputS - (list/fold &&case;weave - (transform-branch lastP lastA) - (list/map (product;uncurry transform-branch) prevsPA)))) - - _ - (undefined) - )) + (synthesize-case (recur +0 resolver num-locals) inputA branchesA) (#la;Function scope bodyA) (let [inner-arity (n.inc outer-arity) @@ -116,33 +162,34 @@ init-resolver env-vars))] (case (recur inner-arity resolver' +0 bodyA) - (#ls;Function arity' env' bodyS') + (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))]) (let [arity (n.inc arity')] - (#ls;Function arity env (prepare-body inner-arity arity bodyS'))) + (function$ arity env (prepare-body inner-arity arity bodyS'))) bodyS - (#ls;Function +1 env (prepare-body inner-arity +1 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 (#ls;Function _arity _env _bodyS) + (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))]) (and (n.= _arity (list;size argsS)) - (not (&&loop;contains-self-reference? _bodyS)))) + (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)))] - (#ls;Loop register-offset argsS - (&&loop;adjust _env register-offset _bodyS))) + (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)] + (~ (&&loop;adjust _env register-offset _bodyS))))) - (#ls;Call argsS' funcS') - (#ls;Call (list/compose argsS' argsS) funcS') + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))]) + (call$ funcS' (list/compose argsS' argsS)) _ - (#ls;Call argsS funcS))) + (call$ funcS argsS))) (#la;Procedure name args) - (#ls;Procedure name (list/map (recur +0 resolver num-locals) args)) + (procedure$ name (list/map (recur +0 resolver num-locals) args)) ))) diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux index 02b1bfba5..91f339bdf 100644 --- a/new-luxc/source/luxc/synthesizer/case.lux +++ b/new-luxc/source/luxc/synthesizer/case.lux @@ -1,10 +1,10 @@ (;module: lux - (lux (data [bool "B/" Eq<Bool>] - [text "T/" Eq<Text>] + (lux (data [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>] [number] - (coll [list "L/" Functor<List> Fold<List> Monoid<List>] - ["s" set]))) + (coll [list "list/" Fold<List>])) + (meta [code "code/" Eq<Code>])) (luxc (lang ["la" analysis] ["ls" synthesis]) (synthesizer ["&;" function]))) @@ -12,21 +12,23 @@ (def: #export (path pattern) (-> la;Pattern ls;Path) (case pattern + (#la;BindP register) + (` ("lux case bind" (~ (code;nat register)))) + (^template [<from> <to>] - (<from> register) - (<to> register)) - ([#la;BindP #ls;BindP] - [#la;BoolP #ls;BoolP] - [#la;NatP #ls;NatP] - [#la;IntP #ls;IntP] - [#la;DegP #ls;DegP] - [#la;FracP #ls;FracP] - [#la;TextP #ls;TextP]) + (<from> value) + (<to> value)) + ([#la;BoolP code;bool] + [#la;NatP code;nat] + [#la;IntP code;int] + [#la;DegP code;deg] + [#la;FracP code;frac] + [#la;TextP code;text]) (#la;TupleP membersP) (case (list;reverse membersP) #;Nil - #ls;UnitP + (' ("lux case pop")) (#;Cons singletonP #;Nil) (path singletonP) @@ -34,58 +36,46 @@ (#;Cons lastP prevsP) (let [length (list;size membersP) last-idx (n.dec length) - last-path (#ls;TupleP (#;Right last-idx) (path lastP)) - [_ tuple-path] (L/fold (function [current-pattern [current-idx next-path]] - [(n.dec current-idx) - (#ls;SeqP (#ls;TupleP (#;Left current-idx) - (path current-pattern)) - next-path)]) - [(n.dec last-idx) last-path] - prevsP)] + [_ 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)) (#la;VariantP tag num-tags memberP) - (let [last? (n.= (n.dec num-tags) tag)] - (#ls;VariantP (if last? (#;Right tag) (#;Left tag)) - (path 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))))))) (def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) - (with-expansions [<default> (as-is (#ls;AltP leftP rightP))] + (with-expansions [<default> (as-is (` ("lux case alt" (~ leftP) (~ rightP))))] (case [leftP rightP] - [#ls;UnitP #ls;UnitP] - #ls;UnitP - - (^template [<tag> <test>] - [(<tag> left) (<tag> right)] - (if (<test> left right) - leftP - <default>)) - ([#ls;BindP n.=] - [#ls;BoolP B/=] - [#ls;NatP n.=] - [#ls;IntP i.=] - [#ls;DegP d.=] - [#ls;FracP f.=] - [#ls;TextP T/=]) - - (^template [<tag> <side>] - [(<tag> (<side> left-idx) left-then) (<tag> (<side> right-idx) right-then)] + (^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) - (weave left-then right-then) + (` (<special> (~ (code;nat left-idx)) (~ (weave left-then right-then)))) <default>)) - ([#ls;TupleP #;Left] - [#ls;TupleP #;Right] - [#ls;VariantP #;Left] - [#ls;VariantP #;Right]) + (["lux case tuple left"] + ["lux case tuple right"] + ["lux case variant left"] + ["lux case variant right"]) - [(#ls;SeqP left-pre left-post) (#ls;SeqP right-pre right-post)] + (^ [[_ (#;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) - (#ls;AltP _ _) + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] _ _))]) <default> weavedP - (#ls;SeqP weavedP (weave left-post right-post))) + (` ("lux case seq" (~ weavedP) (~ (weave left-post right-post))))) _ - <default>))) + (if (code/= leftP rightP) + leftP + <default>)))) diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux index ad4504f41..8599db981 100644 --- a/new-luxc/source/luxc/synthesizer/loop.lux +++ b/new-luxc/source/luxc/synthesizer/loop.lux @@ -1,61 +1,71 @@ (;module: lux - (lux (data [maybe] - text/format - (coll [list "L/" Functor<List>]))) + (lux (control [monad #+ do] + ["p" parser]) + (data [maybe] + (coll [list "list/" Functor<List>])) + (meta [code] + [syntax])) (luxc (lang ["ls" synthesis]) (synthesizer ["&&;" function]))) (def: #export (contains-self-reference? exprS) (-> ls;Synthesis Bool) (case exprS - (#ls;Variant tag last? memberS) + (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] memberS))]) (contains-self-reference? memberS) - (#ls;Tuple membersS) + [_ (#;Tuple membersS)] (list;any? contains-self-reference? membersS) - (#ls;Case inputS pathS) + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (&&function;self? var) + + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) (or (contains-self-reference? inputS) (loop [pathS pathS] (case pathS - (^or (#ls;AltP leftS rightS) - (#ls;SeqP leftS rightS)) + (^or (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))])) (or (recur leftS) (recur rightS)) - - (#ls;ExecP bodyS) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (contains-self-reference? bodyS) _ false))) - (#ls;Function arity environment bodyS) - (list;any? &&function;self? environment) - - (#ls;Call argsS funcS) + (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (list;any? (function [captured] + (case captured + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (&&function;self? var) + + _ + false)) + environment) + + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) (or (contains-self-reference? funcS) (list;any? contains-self-reference? argsS)) - - (^or (#ls;Recur argsS) - (#ls;Procedure name argsS)) - (list;any? contains-self-reference? argsS) - - (#ls;Variable idx) - (&&function;self? idx) - (#ls;Let register inputS bodyS) + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) (or (contains-self-reference? inputS) (contains-self-reference? bodyS)) - (#ls;If inputS thenS elseS) + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) (or (contains-self-reference? inputS) (contains-self-reference? thenS) (contains-self-reference? elseS)) - (#ls;Loop offset argsS bodyS) - (or (list;any? contains-self-reference? argsS) + (^ [_ (#;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 @@ -65,37 +75,34 @@ (-> Nat ls;Synthesis ls;Synthesis) (loop [exprS exprS] (case exprS - (#ls;Case inputS pathS) - (#ls;Case inputS - (let [reify-recursion' recur] - (loop [pathS pathS] - (case pathS - (#ls;AltP leftS rightS) - (#ls;AltP (recur leftS) (recur rightS)) - - (#ls;SeqP leftS rightS) - (#ls;SeqP leftS (recur rightS)) - - (#ls;ExecP bodyS) - (#ls;ExecP (reify-recursion' bodyS)) - - _ - pathS)))) - - (^multi (#ls;Call argsS (#ls;Variable 0)) + (^ [_ (#;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))) - (#ls;Recur argsS) + (` ("lux recur" (~@ argsS))) - (#ls;Call argsS (#ls;Variable var)) - exprS + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) + (` ("lux let" (~ register) (~ inputS) (~ (recur bodyS)))) - (#ls;Let register inputS bodyS) - (#ls;Let register inputS (recur bodyS)) - - (#ls;If inputS thenS elseS) - (#ls;If inputS - (recur thenS) - (recur elseS)) + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (` ("lux if" (~ inputS) (~ (recur thenS)) (~ (recur elseS)))) _ exprS @@ -109,58 +116,69 @@ (|> env (list;nth idx) maybe;assume))))] (loop [exprS exprS] (case exprS - (#ls;Variant tag last? valueS) - (#ls;Variant tag last? (recur valueS)) + (^ [_ (#;Form (list [_ (#;Nat tag)] last? valueS))]) + (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS)))) - (#ls;Tuple members) - (#ls;Tuple (L/map recur members)) - - (#ls;Case inputS pathS) - (#ls;Case (recur inputS) - (let [adjust' recur] - (loop [pathS pathS] - (case pathS - (^template [<tag>] - (<tag> leftS rightS) - (<tag> (recur leftS) (recur rightS))) - ([#ls;AltP] - [#ls;SeqP]) - - (#ls;ExecP bodyS) - (#ls;ExecP (adjust' bodyS)) - - _ - pathS)))) - - (#ls;Function arity scope bodyS) - (#ls;Function arity - (L/map resolve-captured scope) - (recur bodyS)) - - (#ls;Call argsS funcS) - (#ls;Call (L/map recur argsS) (recur funcS)) - - (#ls;Recur argsS) - (#ls;Recur (L/map recur argsS)) - - (#ls;Procedure name argsS) - (#ls;Procedure name (L/map recur argsS)) - - (#ls;Variable var) - (if (&&function;captured? var) - (#ls;Variable (resolve-captured var)) - (#ls;Variable (|> outer-offset nat-to-int (i.+ var)))) - - (#ls;Let register inputS bodyS) - (#ls;Let (n.+ outer-offset register) (recur inputS) (recur bodyS)) - - (#ls;If inputS thenS elseS) - (#ls;If (recur inputS) (recur thenS) (recur elseS)) + [_ (#;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)))) - (#ls;Loop inner-offset argsS bodyS) - (#ls;Loop (n.+ outer-offset inner-offset) - (L/map recur argsS) - (recur bodyS)) + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (if (&&function;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 |