diff options
Diffstat (limited to 'stdlib/source')
7 files changed, 219 insertions, 86 deletions
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux index 005563f1a..834a7bc07 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux @@ -863,9 +863,11 @@ (^ (<tag> value)) path) ([#//////synthesis.Pop] - [#//////synthesis.Test] [#//////synthesis.Bind] - [#//////synthesis.Access])))) + [#//////synthesis.Access]) + + _ + (undefined)))) (def: (normalize-method-body mapping) (-> (Dictionary Variable Variable) Synthesis Synthesis) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux index 0d94ac026..0f110b906 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux @@ -98,36 +98,6 @@ ..peek (_.astore register))) - (^ (synthesis.path/bit value)) - (operation@wrap (.let [jump (.if value _.ifeq _.ifne)] - ($_ _.compose - ..peek - (//value.unwrap type.boolean) - (jump @else)))) - - (^ (synthesis.path/i64 value)) - (operation@wrap ($_ _.compose - ..peek - (//value.unwrap type.long) - (..long value) - _.lcmp - (_.ifne @else))) - - (^ (synthesis.path/f64 value)) - (operation@wrap ($_ _.compose - ..peek - (//value.unwrap type.double) - (..double value) - _.dcmpl - (_.ifne @else))) - - (^ (synthesis.path/text value)) - (operation@wrap ($_ _.compose - ..peek - (_.string value) - (_.invokevirtual //type.text ..equals-name ..equals-type) - (_.ifeq @else))) - (#synthesis.Then bodyS) (do phase.monad [bodyG (phase archive bodyS)] @@ -221,6 +191,9 @@ (wrap ($_ _.compose left! right!))) + + _ + (undefined) )) (def: (path @end phase archive path) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux index 3c80060c2..5951cee48 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -10,6 +10,7 @@ ["." bit ("#@." equivalence)] ["." text ("#@." equivalence)] [number + ["." i64] ["n" nat] ["." frac ("#@." equivalence)]] [collection @@ -37,17 +38,22 @@ (case simple #///analysis.Unit thenC - - (^template [<from> <to>] - (<from> value) - (///@map (|>> (#/.Seq (#/.Test (|> value <to>)))) + + (#///analysis.Bit when) + (///@map (function (_ then) + (#/.Bit-Fork when then #.None)) + thenC) + + (^template [<from> <to> <conversion>] + (<from> test) + (///@map (function (_ then) + (<to> [(<conversion> test) then] (list))) thenC)) - ([#///analysis.Bit #/.Bit] - [#///analysis.Nat (<| #/.I64 .i64)] - [#///analysis.Int (<| #/.I64 .i64)] - [#///analysis.Rev (<| #/.I64 .i64)] - [#///analysis.Frac #/.F64] - [#///analysis.Text #/.Text])) + ([#///analysis.Nat #/.I64-Fork .i64] + [#///analysis.Int #/.I64-Fork .i64] + [#///analysis.Rev #/.I64-Fork .i64] + [#///analysis.Frac #/.F64-Fork |>] + [#///analysis.Text #/.Text-Fork |>])) (#///analysis.Bind register) (<| (:: ///.monad map (|>> (#/.Seq (#/.Bind register)))) @@ -86,6 +92,24 @@ (-> Archive Phase Pattern Analysis (Operation Path)) (path' pattern true (///@map (|>> #/.Then) (synthesize archive bodyA)))) +(def: (weave-branch weave equivalence [new-test new-then] [[old-test old-then] old-tail]) + (All [a] (-> (-> Path Path Path) (Equivalence a) [a Path] (/.Fork a Path) + (/.Fork a Path))) + (if (:: equivalence = new-test old-test) + [[old-test (weave new-then old-then)] old-tail] + [[old-test old-then] + (case old-tail + #.Nil + (list [new-test new-then]) + + (#.Cons old-cons) + (#.Cons (weave-branch weave equivalence [new-test new-then] old-cons)))])) + +(def: (weave-fork weave equivalence new-fork old-fork) + (All [a] (-> (-> Path Path Path) (Equivalence a) (/.Fork a Path) (/.Fork a Path) + (/.Fork a Path))) + (list@fold (..weave-branch weave equivalence) old-fork (#.Cons new-fork))) + (def: (weave new old) (-> Path Path Path) (with-expansions [<default> (as-is (#/.Alt old new))] @@ -107,17 +131,42 @@ [#/.Pop #/.Pop] old - (^template [<tag> <eq>] - [(#/.Test (<tag> newV)) - (#/.Test (<tag> oldV))] - (if (<eq> newV oldV) - old - <default>)) - ([#/.Bit bit@=] - [#/.I64 "lux i64 ="] - [#/.F64 frac@=] - [#/.Text text@=]) - + [(#/.Bit-Fork new-when new-then new-else) + (#/.Bit-Fork old-when old-then old-else)] + (if (bit@= new-when old-when) + (#/.Bit-Fork old-when + (weave new-then old-then) + (case [new-else old-else] + [#.None #.None] + #.None + + (^or [(#.Some woven-then) #.None] + [#.None (#.Some woven-then)]) + (#.Some woven-then) + + [(#.Some new-else) (#.Some old-else)] + (#.Some (weave new-else old-else)))) + (#/.Bit-Fork old-when + (case new-else + #.None + old-then + + (#.Some new-else) + (weave new-else old-then)) + (#.Some (case old-else + #.None + new-then + + (#.Some old-else) + (weave new-then old-else))))) + + (^template [<tag> <equivalence>] + [(<tag> new-fork) (<tag> old-fork)] + (<tag> (..weave-fork weave <equivalence> new-fork old-fork))) + ([#/.I64-Fork i64.equivalence] + [#/.F64-Fork frac.equivalence] + [#/.Text-Fork text.equivalence]) + (^template [<access> <side>] [(#/.Access (<access> (<side> newL))) (#/.Access (<access> (<side> oldL)))] diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux index 896ec2161..aa9d8f5a5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -103,6 +103,31 @@ right' (grow-path grow right)] (wrap (<tag> left' right')))) ([#/.Alt] [#/.Seq]) + + (#/.Bit-Fork when then else) + (do {@ phase.monad} + [then (grow-path grow then) + else (case else + (#.Some else) + (:: @ map (|>> #.Some) (grow-path grow else)) + + #.None + (wrap #.None))] + (wrap (#/.Bit-Fork when then else))) + + (^template [<tag>] + (<tag> [[test then] elses]) + (do {@ phase.monad} + [then (grow-path grow then) + elses (monad.map @ (function (_ [else-test else-then]) + (do @ + [else-then (grow-path grow else-then)] + (wrap [else-test else-then]))) + elses)] + (wrap (<tag> [[test then] elses])))) + ([#/.I64-Fork] + [#/.F64-Fork] + [#/.Text-Fork]) (#/.Then thenS) (|> thenS diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux index 9301292f8..ecd1889cb 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux @@ -53,6 +53,31 @@ right' (recur right)] (wrap (<tag> left' right')))) ([#/.Alt] [#/.Seq]) + + (#/.Bit-Fork when then else) + (do {@ maybe.monad} + [then (recur then) + else (case else + (#.Some else) + (:: @ map (|>> #.Some) (recur else)) + + #.None + (wrap #.None))] + (wrap (#/.Bit-Fork when then else))) + + (^template [<tag>] + (<tag> [[test then] elses]) + (do {@ maybe.monad} + [then (recur then) + elses (monad.map @ (function (_ [else-test else-then]) + (do @ + [else-then (recur else-then)] + (wrap [else-test else-then]))) + elses)] + (wrap (<tag> [[test then] elses])))) + ([#/.I64-Fork] + [#/.F64-Fork] + [#/.Text-Fork]) (#/.Then body) (|> body diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux index dd0d49608..1ba1388d6 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux @@ -7,7 +7,7 @@ ["." exception (#+ exception:)]] [data ["." product] - ["." maybe] + ["." maybe ("#@." functor)] [number ["n" nat]] ["." text @@ -68,8 +68,20 @@ ([#/.Seq] [#/.Alt]) + (#/.Bit-Fork when then else) + (#/.Bit-Fork when (recur then) (maybe@map recur else)) + + (^template [<tag>] + (<tag> [[test then] tail]) + (<tag> [[test (recur then)] + (list@map (function (_ [test' then']) + [test' (recur then')]) + tail)])) + ([#/.I64-Fork] + [#/.F64-Fork] + [#/.Text-Fork]) + (^or #/.Pop - (#/.Test _) (#/.Access _)) path @@ -180,7 +192,7 @@ (-> [Redundancy a] (Try [Redundancy a]))) (def: (list-optimization optimization) - (-> (Optimization Synthesis) (Optimization (List Synthesis))) + (All [a] (-> (Optimization a) (Optimization (List a)))) (function (recur [redundancy values]) (case values #.Nil @@ -234,10 +246,38 @@ (function (recur [redundancy path]) (case path (^or #/.Pop - (#/.Test _) (#/.Access _)) (#try.Success [redundancy path]) + + (#/.Bit-Fork when then else) + (do {@ try.monad} + [[redundancy then] (recur [redundancy then]) + [redundancy else] (case else + (#.Some else) + (:: @ map + (function (_ [redundancy else]) + [redundancy (#.Some else)]) + (recur [redundancy else])) + + #.None + (wrap [redundancy #.None]))] + (wrap [redundancy (#/.Bit-Fork when then else)])) + + (^template [<tag> <type>] + (<tag> [[test then] elses]) + (do {@ try.monad} + [[redundancy then] (recur [redundancy then]) + [redundancy elses] (..list-optimization (: (Optimization [<type> Path]) + (function (_ [redundancy [else-test else-then]]) + (do @ + [[redundancy else-then] (recur [redundancy else-then])] + (wrap [redundancy [else-test else-then]])))) + [redundancy elses])] + (wrap [redundancy (<tag> [[test then] elses])]))) + ([#/.I64-Fork (I64 Any)] + [#/.F64-Fork Frac] + [#/.Text-Fork Text]) (#/.Bind register) (do try.monad diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux index 590653281..4c3953efe 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux @@ -2,15 +2,17 @@ [lux (#- i64 Scope) [abstract [monad (#+ do)] - [equivalence (#+ Equivalence)]] + ["." equivalence (#+ Equivalence)]] [control ["." exception (#+ exception:)]] [data ["." sum] + ["." maybe] ["." bit ("#@." equivalence)] ["." text ("#@." equivalence) ["%" format (#+ Format format)]] [number + ["." i64] ["n" nat] ["i" int] ["f" frac]] @@ -60,11 +62,17 @@ (#Side Side) (#Member Member)) +(type: #export (Fork value next) + [[value next] (List [value next])]) + (type: #export (Path' s) #Pop - (#Test Primitive) (#Access Access) (#Bind Register) + (#Bit-Fork Bit (Path' s) (Maybe (Path' s))) + (#I64-Fork (Fork (I64 Any) (Path' s))) + (#F64-Fork (Fork Frac (Path' s))) + (#Text-Fork (Fork Text (Path' s))) (#Alt (Path' s) (Path' s)) (#Seq (Path' s) (Path' s)) (#Then s)) @@ -127,16 +135,6 @@ Path #Pop) -(template [<name> <tag>] - [(template: #export (<name> content) - (#..Test (<tag> content)))] - - [path/bit #..Bit] - [path/i64 #..I64] - [path/f64 #..F64] - [path/text #..Text] - ) - (template [<name> <kind>] [(template: #export (<name> content) (.<| #..Access @@ -259,23 +257,29 @@ (case value #Pop "_" - - (#Test primitive) - (format "(? " - (case primitive - (#Bit value) - (%.bit value) - - (#I64 value) - (%.int (.int value)) - - (#F64 value) - (%.frac value) - - (#Text value) - (%.text value)) + + (#Bit-Fork when then else) + (format "(?" + " " (%.bit when) " " (%path' %then then) + (case else + (#.Some else) + (format " " (%.bit (not when)) " " (%path' %then else)) + + #.None + "") ")") + (^template [<tag> <format>] + (<tag> cons) + (|> (#.Cons cons) + (list@map (function (_ [test then]) + (format (<format> test) " " (%path' %then then)))) + (text.join-with " ") + (text.enclose ["(? " ")"]))) + ([#I64-Fork (|>> .int %.int)] + [#F64-Fork %.frac] + [#Text-Fork %.text]) + (#Access access) (case access (#Side side) @@ -452,11 +456,26 @@ [#Pop #Pop] true + [(#Bit-Fork reference-when reference-then reference-else) + (#Bit-Fork sample-when sample-then sample-else)] + (and (bit@= reference-when sample-when) + (= reference-then sample-then) + (:: (maybe.equivalence =) = reference-else sample-else)) + + (^template [<tag> <equivalence>] + [(<tag> reference-cons) + (<tag> sample-cons)] + (:: (list.equivalence (equivalence.product <equivalence> =)) = + (#.Cons reference-cons) + (#.Cons sample-cons))) + ([#I64-Fork i64.equivalence] + [#F64-Fork f.equivalence] + [#Text-Fork text.equivalence]) + (^template [<tag> <equivalence>] [(<tag> reference') (<tag> sample')] (:: <equivalence> = reference' sample')) - ([#Test primitive-equivalence] - [#Access access-equivalence] + ([#Access ..access-equivalence] [#Then equivalence]) [(#Bind reference') (#Bind sample')] |