aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorEduardo Julian2016-06-06 09:51:19 -0400
committerEduardo Julian2016-06-06 09:51:19 -0400
commitd1b3bcae841adf1e51af5469cf04b29e7cd01649 (patch)
tree258231c860e464fe365370f8921374857d51097a /src
parentefeacef0a2b98fd428a37b8b6b127bd909ac0e18 (diff)
- [WIP] sharing tests during pattern-matching.
Diffstat (limited to 'src')
-rw-r--r--src/lux/compiler.clj9
-rw-r--r--src/lux/compiler/case.clj305
-rw-r--r--src/lux/compiler/lambda.clj4
-rw-r--r--src/lux/optimizer.clj261
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)])
_