- [WIP] sharing tests during pattern-matching.

4 files changed, 402 insertions, 177 deletions

diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 69b3d4345..8732bd31c 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -80,13 +80,16 @@
         (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args)
 
         (&o/$loop ?args)
-        (&&lux/compile-loop (partial compile-expression $begin) $begin ?args)
+        (&&lux/compile-loop (partial compile-expression $begin) (&/|first $begin) ?args)
 
         (&o/$variant ?tag ?tail ?members)
         (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members)
 
-        (&o/$case ?value ?match)
-        (&&case/compile-case (partial compile-expression $begin) ?value ?match)
+        (&o/$case ?value [?pm ?bodies])
+        (|let [func-class-name+arity (if $begin
+                                       (&/|second $begin)
+                                       (&/T ["" 0]))]
+          (&&case/compile-case (partial compile-expression $begin) func-class-name+arity ?value ?pm ?bodies))
 
         (&o/$function ?arity ?scope ?env ?body)
         (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body)
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index aa5e1ed72..c07222196 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -13,7 +13,8 @@
                  [lexer :as &lexer]
                  [parser :as &parser]
                  [analyser :as &analyser]
-                 [host :as &host])
+                 [host :as &host]
+                 [optimizer :as &o])
             [lux.analyser.case :as &a-case]
             [lux.compiler.base :as &&])
   (:import (org.objectweb.asm Opcodes
@@ -22,176 +23,224 @@
                               MethodVisitor)))
 
 ;; [Utils]
-(defn ^:private compile-match [^MethodVisitor writer ?match $target $else]
-  "(-> [MethodVisitor CaseAnalysis Label Label] Unit)"
-  (|case ?match
-    (&a-case/$NoTestAC)
-    (doto writer
-      (.visitInsn Opcodes/POP) ;; Basically, a No-Op
-      (.visitJumpInsn Opcodes/GOTO $target))
-    
-    (&a-case/$StoreTestAC ?idx)
+(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth]
+  (cond (= 0 stack-depth)
+        writer
+
+        (= 1 stack-depth)
+        (doto writer
+          (.visitInsn Opcodes/POP))
+        
+        (= 2 stack-depth)
+        (doto writer
+          (.visitInsn Opcodes/POP2))
+        
+        :else ;; > 2
+        (doto writer
+          (.visitInsn Opcodes/POP2)
+          (pop-alt-stack (- stack-depth 2)))))
+
+(defn ^:private add-jump-frame [^MethodVisitor writer func-class-name arity stack-size]
+  writer
+  ;; (if (= 0 arity)
+  ;;   (doto writer
+  ;;     (.visitFrame Opcodes/F_NEW
+  ;;                  (int 0) (to-array [])
+  ;;                  (int stack-size) (to-array (repeat stack-size "java/lang/Object"))))
+  ;;   (doto writer
+  ;;     (.visitFrame Opcodes/F_NEW
+  ;;                  (int (inc arity)) (to-array (cons func-class-name (repeat arity "java/lang/Object")))
+  ;;                  (int stack-size) (to-array (repeat stack-size "java/lang/Object")))))
+  )
+
+(defn ^:private compile-pattern* [^MethodVisitor writer in-tuple? func-class-name arity stack-size bodies stack-depth $else pm]
+  "(-> MethodVisitor Case-Pattern (List Label) stack-depth Label MethodVisitor)"
+  (|case pm
+    (&o/$AltPM _left-pm _right-pm)
+    (|let [$alt-else (new Label)]
+      (doto writer
+        (.visitInsn Opcodes/DUP)
+        (compile-pattern* in-tuple? func-class-name arity (inc stack-size) bodies (inc stack-depth) $alt-else _left-pm)
+        (.visitLabel $alt-else)
+        (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _right-pm)))
+
+    (&o/$ExecPM _body-idx)
+    (|case (&/|at _body-idx bodies)
+      (&/$Some $body)
+      (doto writer
+        (pop-alt-stack stack-depth)
+        (.visitJumpInsn Opcodes/GOTO $body))
+
+      (&/$None)
+      (assert false))
+
+    (&o/$BindPM _var-id _next-pm)
     (doto writer
-      (.visitVarInsn Opcodes/ASTORE ?idx)
-      (.visitJumpInsn Opcodes/GOTO $target))
+      (.visitVarInsn Opcodes/ASTORE _var-id)
+      (compile-pattern* in-tuple? func-class-name (inc arity) stack-size bodies stack-depth $else _next-pm))
 
-    (&a-case/$BoolTestAC ?value)
+    (&o/$BoolPM _value _next-pm)
     (doto writer
       (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean")
-      (.visitInsn Opcodes/DUP)
       (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Boolean" "booleanValue" "()Z")
-      (.visitLdcInsn ?value)
+      (.visitLdcInsn _value)
       (.visitJumpInsn Opcodes/IF_ICMPNE $else)
-      (.visitInsn Opcodes/POP)
-      (.visitJumpInsn Opcodes/GOTO $target))
+      (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm))
 
-    (&a-case/$IntTestAC ?value)
+    (&o/$IntPM _value _next-pm)
     (doto writer
       (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long")
-      (.visitInsn Opcodes/DUP)
       (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J")
-      (.visitLdcInsn (long ?value))
+      (.visitLdcInsn (long _value))
       (.visitInsn Opcodes/LCMP)
       (.visitJumpInsn Opcodes/IFNE $else)
-      (.visitInsn Opcodes/POP)
-      (.visitJumpInsn Opcodes/GOTO $target))
+      (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm))
 
-    (&a-case/$RealTestAC ?value)
+    (&o/$RealPM _value _next-pm)
     (doto writer
       (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double")
-      (.visitInsn Opcodes/DUP)
       (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D")
-      (.visitLdcInsn (double ?value))
+      (.visitLdcInsn (double _value))
       (.visitInsn Opcodes/DCMPL)
       (.visitJumpInsn Opcodes/IFNE $else)
-      (.visitInsn Opcodes/POP)
-      (.visitJumpInsn Opcodes/GOTO $target))
+      (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm))
 
-    (&a-case/$CharTestAC ?value)
+    (&o/$CharPM _value _next-pm)
     (doto writer
       (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character")
-      (.visitInsn Opcodes/DUP)
       (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Character" "charValue" "()C")
-      (.visitLdcInsn ?value)
+      (.visitLdcInsn _value)
       (.visitJumpInsn Opcodes/IF_ICMPNE $else)
-      (.visitInsn Opcodes/POP)
-      (.visitJumpInsn Opcodes/GOTO $target))
+      (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm))
 
-    (&a-case/$TextTestAC ?value)
+    (&o/$TextPM _value _next-pm)
     (doto writer
-      (.visitInsn Opcodes/DUP)
-      (.visitLdcInsn ?value)
+      (.visitLdcInsn _value)
       (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
       (.visitJumpInsn Opcodes/IFEQ $else)
+      (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm))
+
+    (&o/$UnitPM _next-pm)
+    (doto writer
       (.visitInsn Opcodes/POP)
-      (.visitJumpInsn Opcodes/GOTO $target))
+      (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm))
+
+    (&o/$InnerPM _next-pm)
+    (doto writer
+      (.visitInsn Opcodes/POP)
+      (compile-pattern* false func-class-name arity stack-size bodies stack-depth $else _next-pm))
+
+    ;; (&o/$TuplePM _idx+ _next-pm)
+    ;; (|let [$tuple-else (new Label)
+    ;;        [_idx is-tail?] (|case _idx+
+    ;;                          (&/$Left _idx)
+    ;;                          (&/T [_idx false])
 
-    (&a-case/$TupleTestAC ?members)
-    (|case ?members
-      (&/$Nil)
+    ;;                          (&/$Right _idx)
+    ;;                          (&/T [_idx true]))
+    ;;        _ (prn 'is-tail? is-tail?)]
+    ;;   (doto writer
+    ;;     (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+    ;;     (.visitInsn Opcodes/DUP)
+    ;;     (.visitLdcInsn (int _idx))
+    ;;     (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;")
+    ;;     ;; (compile-pattern* in-tuple? func-class-name arity (inc stack-size) bodies stack-depth $else _next-pm)
+    ;;     (compile-pattern* true func-class-name arity (inc stack-size) bodies stack-depth (if is-tail?
+    ;;                                                                                        $tuple-else
+    ;;                                                                                        $else) _next-pm)
+    ;;     (-> (doto (.visitLabel $tuple-else)
+    ;;           ;; (add-jump-frame func-class-name arity stack-size)
+    ;;           (.visitInsn Opcodes/POP)
+    ;;           (.visitJumpInsn Opcodes/GOTO $else))
+    ;;         (->> (when is-tail?)))
+    ;;     ))
+
+    (&o/$TuplePM _next-pm)
+    (|let [$tuple-else (new Label)]
       (doto writer
+        (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+        (compile-pattern* true func-class-name arity (inc stack-size) bodies stack-depth $tuple-else _next-pm)
+        (.visitLabel $tuple-else)
         (.visitInsn Opcodes/POP)
-        (.visitJumpInsn Opcodes/GOTO $target))
+        (.visitJumpInsn Opcodes/GOTO $else)
+        ))
 
-      (&/$Cons ?member (&/$Nil))
-      (compile-match ?member $target $else)
+    (&o/$SeqPM _idx+ _next-pm)
+    (|let [$tuple-else (new Label)
+           [_idx is-tail?] (|case _idx+
+                             (&/$Left _idx)
+                             (&/T [_idx false])
 
-      _
-      (let [num-members (&/|length ?members)]
-        (doto writer
-          (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
-          (-> (doto (.visitInsn Opcodes/DUP)
-                (.visitLdcInsn (int idx))
-                (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;")
-                (compile-match test $next $sub-else)
-                (.visitLabel $sub-else)
-                (.visitInsn Opcodes/POP)
-                (.visitJumpInsn Opcodes/GOTO $else)
-                (.visitLabel $next))
-              (->> (|let [[idx test] idx+member
-                          $next (new Label)
-                          $sub-else (new Label)
-                          is-tail? (= (dec num-members) idx)])
-                   (doseq [idx+member (->> ?members &/enumerate &/->seq)])))
-          (.visitInsn Opcodes/POP)
-          (.visitJumpInsn Opcodes/GOTO $target))))
-
-    (&a-case/$VariantTestAC ?tag ?count ?test)
-    (if (= 1 ?count)
-      (compile-match ?test $target $else)
-      (let [is-last (= ?tag (dec ?count))
-            $variant-else (new Label)
-            _ (doto writer
-                (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
-                (.visitInsn Opcodes/DUP)
-                (.visitLdcInsn (int ?tag)))
-            _ (if is-last
-                (.visitLdcInsn writer "")
-                (.visitInsn writer Opcodes/ACONST_NULL))
-            _ (doto writer
-                (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;")
-                (.visitInsn Opcodes/DUP)
-                (.visitInsn Opcodes/ACONST_NULL)
-                (.visitJumpInsn Opcodes/IF_ACMPEQ $variant-else)
-                (-> (doto (compile-match ?test $value-then $value-else)
-                      (.visitLabel $value-then)
-                      (.visitInsn Opcodes/POP)
-                      (.visitJumpInsn Opcodes/GOTO $target)
-                      (.visitLabel $value-else)
-                      (.visitInsn Opcodes/POP)
-                      (.visitJumpInsn Opcodes/GOTO $else))
-                    (->> (let [$value-then (new Label)
-                               $value-else (new Label)])))
-                (.visitLabel $variant-else)
-                (.visitInsn Opcodes/POP)
-                (.visitJumpInsn Opcodes/GOTO $else))]
-        writer))
+                             (&/$Right _idx)
+                             (&/T [_idx true]))]
+      (doto writer
+        (.visitInsn Opcodes/DUP)
+        (.visitLdcInsn (int _idx))
+        (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;")
+        (compile-pattern* true func-class-name arity (inc stack-size) bodies stack-depth $else _next-pm)
+        ))
+
+    (&o/$VariantPM _idx+ _next-pm)
+    (|let [;; _ (prn 'IN-VARIANT arity stack-size)
+           $variant-else (new Label)
+           [_idx is-last] (|case _idx+
+                            (&/$Left _idx)
+                            (&/T [_idx false])
+
+                            (&/$Right _idx)
+                            (&/T [_idx true]))
+           _ (doto writer
+               (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+               (.visitLdcInsn (int _idx)))
+           _ (if is-last
+               (.visitLdcInsn writer "")
+               (.visitInsn writer Opcodes/ACONST_NULL))]
+      (doto writer
+        (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;")
+        ;; (add-jump-frame func-class-name arity stack-size)
+        (.visitInsn Opcodes/DUP)
+        (.visitInsn Opcodes/ACONST_NULL)
+        ;; (add-jump-frame func-class-name arity (+ 2 stack-size))
+        (.visitJumpInsn Opcodes/IF_ACMPEQ $variant-else)
+        (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm)
+        (.visitLabel $variant-else)
+        ;; (add-jump-frame func-class-name arity stack-size)
+        (.visitInsn Opcodes/POP)
+        (.visitJumpInsn Opcodes/GOTO $else)))
     ))
 
-(defn ^:private separate-bodies [patterns]
-  (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body]
-                                          (|let [[$id mappings =matches] $id+mappings+=matches
-                                                 [pattern body] pattern+body]
-                                            (&/T [(inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)])))
-                                        (&/T [0 (&/|table) (&/|table)])
-                                        patterns)]
-    (&/T [mappings (&/|reverse patterns*)])))
-
-(defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end]
-  (let [entries (&/|map (fn [?branch+?body]
-                          (|let [[?branch ?body] ?branch+?body
-                                 label (new Label)]
-                            (&/T [(&/T [?branch label])
-                                  (&/T [label ?body])])))
-                        mappings)
-        mappings* (&/|map &/|first entries)]
+(defn ^:private compile-pattern [^MethodVisitor writer func-class-name arity bodies pm]
+  ;; (compile-pattern* writer false func-class-name arity 1 bodies 0 nil pm)
+  (|let [$else (new Label)]
     (doto writer
-      (-> (doto (compile-match ?match (&/|get ?body mappings*) $else)
-            (.visitLabel $else))
-          (->> (|let [[?body ?match] ?body+?match])
-               (doseq [?body+?match (&/->seq patterns)
-                       :let [$else (new Label)]])))
+      (compile-pattern* false func-class-name arity 1 bodies 0 $else pm)
+      (.visitLabel $else)
       (.visitInsn Opcodes/POP)
       (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
       (.visitInsn Opcodes/DUP)
       (.visitLdcInsn "Invalid expression for pattern-matching.")
       (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V")
-      (.visitInsn Opcodes/ATHROW))
-    (&/map% (fn [?label+?body]
-              (|let [[?label ?body] ?label+?body]
-                (|do [:let [_ (.visitLabel writer ?label)]
-                      ret (compile ?body)
-                      :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]]
-                  (return ret))))
-            (&/|map &/|second entries))
-    ))
+      (.visitInsn Opcodes/ATHROW)))
+  )
+
+(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end]
+  (&/map% (fn [label+body]
+            (|let [[_label _body] label+body]
+              (|do [:let [_ (.visitLabel writer _label)]
+                    _ (compile _body)
+                    :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]]
+                (return nil))))
+          (&/zip2 bodies-labels ?bodies)))
 
 ;; [Resources]
-(defn compile-case [compile ?value ?matches]
-  (|do [^MethodVisitor *writer* &/get-writer
-        :let [$end (new Label)]
+(defn compile-case [compile func-class-name+arity ?value ?pm ?bodies]
+  (|do [:let [[func-class-name arity] func-class-name+arity]
+        ^MethodVisitor *writer* &/get-writer
+        :let [$end (new Label)
+              bodies-labels (&/|map (fn [_] (new Label)) ?bodies)]
         _ (compile ?value)
-        _ (|let [[mappings patterns] (separate-bodies ?matches)]
-            (compile-pattern-matching *writer* compile mappings patterns $end))
+        :let [_ (prn 'compile-pattern* (&/adt->text ?pm))
+              _ (compile-pattern *writer* func-class-name arity bodies-labels ?pm)]
+        _ (compile-bodies *writer* compile bodies-labels ?bodies $end)
         :let [_ (.visitLabel *writer* $end)]]
     (return nil)))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index f51edc507..f14c8b68f 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -118,7 +118,7 @@
                        (.visitCode)
                        (.visitLabel $begin))
         (|do [^MethodVisitor *writer* &/get-writer
-              ret (compile $begin impl-body)
+              ret (compile (&/T [$begin (&/T [class-name arity])]) impl-body)
               :let [_ (doto *writer*
                         (.visitInsn Opcodes/ARETURN)
                         (.visitMaxs 0 0)
@@ -230,7 +230,7 @@
                        (.visitCode)
                        (.visitLabel $begin))
         (|do [^MethodVisitor *writer* &/get-writer
-              ret (compile $begin impl-body)
+              ret (compile (&/T [$begin (&/T [class-name arity])]) impl-body)
               :let [_ (doto *writer*
                         (.visitInsn Opcodes/ARETURN)
                         (.visitMaxs 0 0)
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index 920fd21bc..bf640c642 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -3,9 +3,8 @@
 ;;  If a copy of the MPL was not distributed with this file,
 ;;  You can obtain one at http://mozilla.org/MPL/2.0/.
 (ns lux.optimizer
-  (:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]]
-                 [analyser :as &analyser])
-            (lux.analyser [base :as &-base]
+  (:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]])
+            (lux.analyser [base :as &a]
                           [case :as &a-case])))
 
 ;; [Tags]
@@ -29,20 +28,199 @@
   ("loop" 1)
   )
 
+;; For pattern-matching
+(defvariant
+  ("ExecPM" 1)
+  ("AltPM" 2)
+  ("BindPM" 2)
+  ("BoolPM" 2)
+  ("IntPM" 2)
+  ("RealPM" 2)
+  ("CharPM" 2)
+  ("TextPM" 2)
+  ("UnitPM" 1)
+  ("VariantPM" 2)
+  ("TuplePM" 1)
+  ("SeqPM" 2)
+  ("InnerPM" 1))
+
 ;; [Utils]
+(defn ^:private transform-pm [test next-pm]
+  (|case test
+    (&a-case/$NoTestAC)
+    ($UnitPM next-pm)
+
+    (&a-case/$StoreTestAC _register)
+    ($BindPM _register next-pm)
+
+    (&a-case/$BoolTestAC _value)
+    ($BoolPM _value next-pm)
+
+    (&a-case/$IntTestAC _value)
+    ($IntPM _value next-pm)
+
+    (&a-case/$RealTestAC _value)
+    ($RealPM _value next-pm)
+
+    (&a-case/$CharTestAC _value)
+    ($CharPM _value next-pm)
+
+    (&a-case/$TextTestAC _value)
+    ($TextPM _value next-pm)
+
+    (&a-case/$VariantTestAC _idx _num-options _sub-test)
+    (|let [idx+ (if (= _idx (dec _num-options))
+                  (&/$Right _idx)
+                  (&/$Left _idx))]
+      ($VariantPM idx+ (transform-pm _sub-test next-pm)))
+
+    (&a-case/$TupleTestAC _sub-tests)
+    (|case _sub-tests
+      (&/$Nil)
+      ($UnitPM next-pm)
+
+      (&/$Cons _only-test (&/$Nil))
+      (transform-pm _only-test next-pm)
+
+      _
+      (|let [tuple-size (&/|length _sub-tests)]
+        ($TuplePM (&/fold (fn [next-pm* idx+test*]
+                            (|let [[idx test*] idx+test*]
+                              ($SeqPM (if (< idx (dec tuple-size))
+                                        (&/$Left idx)
+                                        (&/$Right idx))
+                                      (transform-pm test* next-pm*))))
+                          ($InnerPM next-pm)
+                          (&/zip2 (&/|reverse (&/|range tuple-size))
+                                  (&/|reverse _sub-tests))))))
+    ))
+
+(defn ^:private fuse-pms [pre post]
+  (|case (&/T [pre post])
+    [($UnitPM _pre) ($UnitPM _post)]
+    ($UnitPM (fuse-pms _pre _post))
+
+    [($InnerPM _pre) ($InnerPM _post)]
+    ($InnerPM (fuse-pms _pre _post))
+
+    [($BindPM _pre-var-id _pre-next-pm) ($BindPM _post-var-id _post-next-pm)]
+    (if (= _pre-var-id _post-var-id)
+      ($BindPM _pre-var-id (fuse-pms _pre-next-pm _post-next-pm))
+      ($AltPM pre post))
+
+    [($BoolPM _pre-value _pre-next) ($BoolPM _post-value _post-next)]
+    (if (= _pre-value _post-value)
+      ($BoolPM _pre-value (fuse-pms _pre-next _post-next))
+      ($AltPM pre post))
+
+    [($IntPM _pre-value _pre-next) ($IntPM _post-value _post-next)]
+    (if (= _pre-value _post-value)
+      ($IntPM _pre-value (fuse-pms _pre-next _post-next))
+      ($AltPM pre post))
+
+    [($RealPM _pre-value _pre-next) ($RealPM _post-value _post-next)]
+    (if (= _pre-value _post-value)
+      ($RealPM _pre-value (fuse-pms _pre-next _post-next))
+      ($AltPM pre post))
+
+    [($CharPM _pre-value _pre-next) ($CharPM _post-value _post-next)]
+    (if (= _pre-value _post-value)
+      ($CharPM _pre-value (fuse-pms _pre-next _post-next))
+      ($AltPM pre post))
+
+    [($TextPM _pre-value _pre-next) ($TextPM _post-value _post-next)]
+    (if (= _pre-value _post-value)
+      ($TextPM _pre-value (fuse-pms _pre-next _post-next))
+      ($AltPM pre post))
+
+    [($TuplePM _pre-next-pm) ($TuplePM _post-next-pm)]
+    ($TuplePM (fuse-pms _pre-next-pm _post-next-pm))
+    
+    [($SeqPM (&/$Left _pre-idx) _pre-next-pm) ($SeqPM (&/$Left _post-idx) _post-next-pm)]
+    (if (= _pre-idx _post-idx)
+      ($SeqPM (&/$Left _pre-idx) (fuse-pms _pre-next-pm _post-next-pm))
+      ($AltPM pre post))
+
+    [($SeqPM (&/$Right _pre-idx) _pre-next-pm) ($SeqPM (&/$Right _post-idx) _post-next-pm)]
+    (if (= _pre-idx _post-idx)
+      ($SeqPM (&/$Right _pre-idx) (fuse-pms _pre-next-pm _post-next-pm))
+      ($AltPM pre post))
+
+    [($VariantPM (&/$Left _pre-idx) _pre-next-pm) ($VariantPM (&/$Left _post-idx) _post-next-pm)]
+    (if (= _pre-idx _post-idx)
+      ($VariantPM (&/$Left _pre-idx) (fuse-pms _pre-next-pm _post-next-pm))
+      ($AltPM pre post))
+
+    [($VariantPM (&/$Right _pre-idx) _pre-next-pm) ($VariantPM (&/$Right _post-idx) _post-next-pm)]
+    (if (= _pre-idx _post-idx)
+      ($VariantPM (&/$Right _pre-idx) (fuse-pms _pre-next-pm _post-next-pm))
+      ($AltPM pre post))
+    
+    _
+    ($AltPM pre post)
+    ))
+
+(defn ^:private optimize-pm [branches]
+  (|let [;; branches (&/|reverse branches*)
+         bodies (&/|map &/|second branches)
+         bodies-ids (&/|range (&/|length bodies))
+         pms (&/|map (fn [branch]
+                       (|let [[[_pattern _] _body-id] branch]
+                         (transform-pm _pattern ($ExecPM _body-id))))
+                     (&/zip2 branches
+                             bodies-ids))
+         _ (prn 'pms (&/|length bodies) (&/->seq bodies-ids))
+         _ (&/|map (comp prn &/adt->text) pms)]
+    (|case (&/|reverse pms)
+      (&/$Nil)
+      (assert false)
+
+      (&/$Cons _head-pm _tail-pms)
+      (do (prn 'pms-FUSED (&/adt->text (&/fold fuse-pms _head-pm _tail-pms)))
+        (&/T [(&/fold fuse-pms _head-pm _tail-pms)
+              bodies]))
+
+      ;; (&/$Cons _last-pm _rev-pms)
+      ;; (do (prn 'pms-FUSED (&/adt->text (&/fold (fn [post pre] (fuse-pms pre post)) _last-pm _rev-pms)))
+      ;;   (&/T [(&/fold (fn [post pre] (fuse-pms pre post)) _last-pm _rev-pms)
+      ;;         bodies]))
+      )))
+
 (defn ^:private shift-pattern [pattern]
   (|case pattern
-    (&a-case/$StoreTestAC idx)
-    (&a-case/$StoreTestAC (inc idx))
+    ($UnitPM _next-pm)
+    ($UnitPM (shift-pattern _next-pm))
 
-    (&a-case/$TupleTestAC sub-tests)
-    (&a-case/$TupleTestAC (&/|map shift-pattern sub-tests))
+    ($InnerPM _next-pm)
+    ($InnerPM (shift-pattern _next-pm))
 
-    (&a-case/$VariantTestAC idx num-options sub-test)
-    (&a-case/$VariantTestAC (&/T [idx num-options (shift-pattern sub-test)]))
+    ($BindPM _var-id _next-pm)
+    ($BindPM (inc _var-id) (shift-pattern _next-pm))
 
-    _
-    pattern
+    ($BoolPM _value _next-pm)
+    ($BoolPM _value (shift-pattern _next-pm))
+
+    ($IntPM _value _next-pm)
+    ($IntPM _value (shift-pattern _next-pm))
+
+    ($RealPM _value _next-pm)
+    ($RealPM _value (shift-pattern _next-pm))
+
+    ($CharPM _value _next-pm)
+    ($CharPM _value (shift-pattern _next-pm))
+
+    ($TextPM _value _next-pm)
+    ($TextPM _value (shift-pattern _next-pm))
+
+    ($TuplePM _idx+ _next-pm)
+    ($TuplePM _idx+ (shift-pattern _next-pm))
+
+    ($VariantPM _idx+ _next-pm)
+    ($VariantPM _idx+ (shift-pattern _next-pm))
+    
+    ($AltPM _left-pm _right-pm)
+    ($AltPM (shift-pattern _left-pm) (shift-pattern _right-pm))
+    
     ))
 
 (defn ^:private drop-scope [source]
@@ -69,15 +247,12 @@
       ($tuple elems)
       (&/T [meta ($tuple (&/|map (partial shift-function-body own-body?) elems))])
       
-      ($case value branches)
+      ($case value [_pm _bodies])
       (&/T [meta ($case (shift-function-body own-body? value)
-                        (&/|map (fn [branch]
-                                  (|let [[_pattern _body] branch]
-                                    (&/T [(if own-body?
-                                            (shift-pattern _pattern)
-                                            _pattern)
-                                          (shift-function-body own-body? _body)])))
-                                branches))])
+                        (&/T [(if own-body?
+                                (shift-pattern _pm)
+                                _pm)
+                              (&/|map (partial shift-function-body own-body?) _bodies)]))])
       
       ($function arity scope captured body*)
       (&/T [meta ($function arity
@@ -127,8 +302,7 @@
           source
 
           _
-          (&/T [meta ($captured (de-scope scope) idx (shift-function-body own-body? source))]))
-        )
+          (&/T [meta ($captured (de-scope scope) idx (shift-function-body own-body? source))])))
       
       ($proc proc-ident args special-args)
       (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body own-body?) args) special-args)])
@@ -153,12 +327,11 @@
       (&/T [meta ($apply (optimize-loop -1 func)
                          (&/|map (partial optimize-loop -1) args))])
 
-      ($case _value _branches)
+      ($case _value [_pattern _bodies])
       (&/T [meta ($case _value
-                        (&/|map (fn [branch]
-                                  (|let [[_pattern _body] branch]
-                                    (&/T [_pattern (optimize-loop arity _body)])))
-                                _branches))])
+                        (&/T [_pattern
+                              (&/|map (partial optimize-loop arity)
+                                      _bodies)]))])
 
       ($function _arity _scope _captured _body)
       (&/T [meta ($function _arity _scope _captured (optimize-loop _arity _body))])
@@ -185,38 +358,38 @@
     "(-> Analysis Optimized)"
     (|let [[meta analysis-] analysis]
       (|case analysis-
-        (&-base/$bool value)
+        (&a/$bool value)
         (&/T [meta ($bool value)])
         
-        (&-base/$int value)
+        (&a/$int value)
         (&/T [meta ($int value)])
         
-        (&-base/$real value)
+        (&a/$real value)
         (&/T [meta ($real value)])
         
-        (&-base/$char value)
+        (&a/$char value)
         (&/T [meta ($char value)])
         
-        (&-base/$text value)
+        (&a/$text value)
         (&/T [meta ($text value)])
         
-        (&-base/$variant idx is-last? value)
+        (&a/$variant idx is-last? value)
         (&/T [meta ($variant idx is-last? (pass-0 value))])
         
-        (&-base/$tuple elems)
+        (&a/$tuple elems)
         (&/T [meta ($tuple (&/|map pass-0 elems))])
         
-        (&-base/$apply func args)
+        (&a/$apply func args)
         (&/T [meta ($apply (pass-0 func) (&/|map pass-0 args))])
         
-        (&-base/$case value branches)
+        (&a/$case value branches)
         (&/T [meta ($case (pass-0 value)
-                          (&/|map (fn [branch]
-                                    (|let [[_pattern _body] branch]
-                                      (&/T [_pattern (pass-0 _body)])))
-                                  branches))])
+                          (optimize-pm (&/|map (fn [branch]
+                                                 (|let [[_pattern _body] branch]
+                                                   (&/T [_pattern (pass-0 _body)])))
+                                               branches)))])
         
-        (&-base/$lambda scope captured body)
+        (&a/$lambda scope captured body)
         (|case (pass-0 body)
           [_ ($function _arity _scope _captured _body)]
           (&/T [meta ($function (inc _arity) scope (optimize-closure pass-0 captured) (shift-function-body true _body))])
@@ -224,16 +397,16 @@
           =body
           (&/T [meta ($function 1 scope (optimize-closure pass-0 captured) =body)]))
         
-        (&-base/$ann value-expr type-expr type-type)
+        (&a/$ann value-expr type-expr type-type)
         (&/T [meta ($ann (pass-0 value-expr) type-expr type-type)])
         
-        (&-base/$var var-kind)
+        (&a/$var var-kind)
         (&/T [meta ($var var-kind)])
         
-        (&-base/$captured scope idx source)
+        (&a/$captured scope idx source)
         (&/T [meta ($captured scope idx (pass-0 source))])
 
-        (&-base/$proc proc-ident args special-args)
+        (&a/$proc proc-ident args special-args)
         (&/T [meta ($proc proc-ident (&/|map pass-0 args) special-args)])
         
         _