aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/case.lux74
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux19
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux33
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux91
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux25
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux25
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux48
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/synthesis.lux77
9 files changed, 281 insertions, 117 deletions
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux
index 7962ea991..573e9764b 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/case.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/case.lux
@@ -1,7 +1,7 @@
(.module:
[lux (#- Type if let case)
[abstract
- [monad (#+ do)]]
+ ["." monad (#+ do)]]
[control
["." function]
["ex" exception (#+ exception:)]]
@@ -98,33 +98,51 @@
(operation@wrap (|>> peekI
(_.ASTORE register)))
- (^ (synthesis.path/bit value))
- (operation@wrap (.let [jumpI (.if value _.IFEQ _.IFNE)]
- (|>> peekI
- (_.unwrap type.boolean)
- (jumpI @else))))
-
- (^ (synthesis.path/i64 value))
- (operation@wrap (|>> peekI
- (_.unwrap type.long)
- (_.long (.int value))
- _.LCMP
- (_.IFNE @else)))
-
- (^ (synthesis.path/f64 value))
- (operation@wrap (|>> peekI
- (_.unwrap type.double)
- (_.double value)
- _.DCMPL
- (_.IFNE @else)))
-
- (^ (synthesis.path/text value))
- (operation@wrap (|>> peekI
- (_.string value)
- (_.INVOKEVIRTUAL (type.class "java.lang.Object" (list))
- "equals"
- (type.method [(list //.$Value) type.boolean (list)]))
- (_.IFEQ @else)))
+ (#synthesis.Bit-Fork when thenP elseP)
+ (do phase.monad
+ [thenG (path' stack-depth @else @end phase archive thenP)
+ elseG (.case elseP
+ (#.Some elseP)
+ (path' stack-depth @else @end phase archive elseP)
+
+ #.None
+ (wrap (_.GOTO @else)))
+ #let [ifI (.if when _.IFEQ _.IFNE)]]
+ (wrap (<| _.with-label (function (_ @else))
+ (|>> peekI
+ (_.unwrap type.boolean)
+ (ifI @else)
+ thenG
+ (_.label @else)
+ elseG))))
+
+ (^template [<tag> <unwrap> <dup> <pop> <test> <comparison> <if>]
+ (<tag> cons)
+ (do {@ phase.monad}
+ [forkG (: (Operation Inst)
+ (monad.fold @ (function (_ [test thenP] elseG)
+ (do @
+ [thenG (path' stack-depth @else @end phase archive thenP)]
+ (wrap (<| _.with-label (function (_ @else))
+ (|>> <dup>
+ (<test> test)
+ <comparison>
+ (<if> @else)
+ <pop>
+ thenG
+ (_.label @else)
+ elseG)))))
+ (|>> <pop>
+ (_.GOTO @else))
+ (#.Cons cons)))]
+ (wrap (|>> peekI
+ <unwrap>
+ forkG))))
+ ([#synthesis.I64-Fork (_.unwrap type.long) _.DUP2 _.POP2 (|>> .int _.long) _.LCMP _.IFNE]
+ [#synthesis.F64-Fork (_.unwrap type.double) _.DUP2 _.POP2 _.double _.DCMPL _.IFNE]
+ [#synthesis.Text-Fork (|>) _.DUP _.POP _.string
+ (_.INVOKEVIRTUAL (type.class "java.lang.Object" (list)) "equals" (type.method [(list //.$Value) type.boolean (list)]))
+ _.IFEQ])
(#synthesis.Then bodyS)
(do phase.monad
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
index 482521e34..c25151bcf 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
@@ -11,7 +11,7 @@
["<s>" synthesis (#+ Parser)]]]
[data
["." product]
- ["." maybe]
+ ["." maybe ("#@." functor)]
["." text ("#@." equivalence)
["%" format (#+ format)]]
[number
@@ -830,9 +830,22 @@
(^ (<tag> value))
path)
([#synthesis.Pop]
- [#synthesis.Test]
[#synthesis.Bind]
- [#synthesis.Access]))))
+ [#synthesis.Access])
+
+ (#synthesis.Bit-Fork when then else)
+ (#synthesis.Bit-Fork when (recur then) (maybe@map recur else))
+
+ (^template [<tag>]
+ (<tag> [[test then] elses])
+ (<tag> [[test (recur then)]
+ (list@map (function (_ [else-test else-then])
+ [else-test (recur else-then)])
+ elses)]))
+ ([#synthesis.I64-Fork]
+ [#synthesis.F64-Fork]
+ [#synthesis.Text-Fork])
+ )))
(def: (normalize-method-body mapping)
(-> (Dictionary Variable Variable) Synthesis Synthesis)
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')]