Optimizing tests for bit/i64/f64/text literals during pattern-matching.

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')]