diff options
author | LuxLang | 2016-06-13 00:48:20 -0400 |
---|---|---|
committer | GitHub | 2016-06-13 00:48:20 -0400 |
commit | 3e93114cc950743dbcceb88919fd869c923777a4 (patch) | |
tree | 975a72cfc17fded0cc1817c0f49ff5246f93f487 | |
parent | efeacef0a2b98fd428a37b8b6b127bd909ac0e18 (diff) | |
parent | ade08bbd52acaf3bb51e1a3a1c1cd73bb1ba9948 (diff) |
Merge pull request #15 from LuxLang/pm_sharing
Pm sharing
Diffstat (limited to '')
-rw-r--r-- | src/lux/base.clj | 5 | ||||
-rw-r--r-- | src/lux/compiler.clj | 4 | ||||
-rw-r--r-- | src/lux/compiler/case.clj | 276 | ||||
-rw-r--r-- | src/lux/compiler/host.clj | 404 | ||||
-rw-r--r-- | src/lux/optimizer.clj | 247 |
5 files changed, 586 insertions, 350 deletions
diff --git a/src/lux/base.clj b/src/lux/base.clj index 73f032a9d..48eb00469 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -421,7 +421,10 @@ xs ($Cons x xs*) - ($Cons (f x) (|map f xs*)))) + ($Cons (f x) (|map f xs*)) + + _ + (assert false (prn-str '|map f (adt->text xs))))) (defn |empty? [xs] "(All [a] (-> (List a) Bool))" diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 69b3d4345..a17036b7e 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -85,8 +85,8 @@ (&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]) + (&&case/compile-case (partial compile-expression $begin) ?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..639883ac8 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,181 @@ MethodVisitor))) ;; [Utils] -(defn ^:private compile-match [^MethodVisitor writer ?match $target $else] - "(-> [MethodVisitor CaseAnalysis Label Label] Unit)" - (|case ?match - (&a-case/$NoTestAC) +(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 compile-pattern* [^MethodVisitor writer bodies stack-depth $else pm] + "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" + (|case 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/$PopPM) (doto writer - (.visitInsn Opcodes/POP) ;; Basically, a No-Op - (.visitJumpInsn Opcodes/GOTO $target)) - - (&a-case/$StoreTestAC ?idx) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) + + (&o/$BindPM _var-id) (doto writer - (.visitVarInsn Opcodes/ASTORE ?idx) - (.visitJumpInsn Opcodes/GOTO $target)) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE _var-id)) - (&a-case/$BoolTestAC ?value) + (&o/$BoolPM _value) (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Boolean" "booleanValue" "()Z") - (.visitLdcInsn ?value) - (.visitJumpInsn Opcodes/IF_ICMPNE $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (.visitLdcInsn _value) + (.visitJumpInsn Opcodes/IF_ICMPNE $else)) - (&a-case/$IntTestAC ?value) + (&o/$IntPM _value) (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.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)) + (.visitJumpInsn Opcodes/IFNE $else)) - (&a-case/$RealTestAC ?value) + (&o/$RealPM _value) (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.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)) + (.visitJumpInsn Opcodes/IFNE $else)) - (&a-case/$CharTestAC ?value) + (&o/$CharPM _value) (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Character" "charValue" "()C") - (.visitLdcInsn ?value) - (.visitJumpInsn Opcodes/IF_ICMPNE $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (.visitLdcInsn _value) + (.visitJumpInsn Opcodes/IF_ICMPNE $else)) - (&a-case/$TextTestAC ?value) + (&o/$TextPM _value) (doto writer (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?value) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitLdcInsn _value) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (.visitJumpInsn Opcodes/IFEQ $else)) + + (&o/$TuplePM _idx+) + (|let [[_idx is-tail?] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) - (&a-case/$TupleTestAC ?members) - (|case ?members - (&/$Nil) + (&/$Right _idx) + (&/T [_idx true]))] (doto writer + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int _idx)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + )) + + (&o/$VariantPM _idx+) + (|let [$success (new Label) + $fail (new Label) + [_idx is-last] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true])) + _ (doto writer + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.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;") + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $fail) + (.visitJumpInsn Opcodes/GOTO $success) + (.visitLabel $fail) (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $success) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) - (&/$Cons ?member (&/$Nil)) - (compile-match ?member $target $else) + (&o/$SeqPM _left-pm _right-pm) + (doto writer + (compile-pattern* bodies stack-depth $else _left-pm) + (compile-pattern* bodies stack-depth $else _right-pm)) - _ - (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)) + (&o/$AltPM _left-pm _right-pm) + (|let [$alt-else (new Label)] + (doto writer + (.visitInsn Opcodes/DUP) + (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm) + (.visitLabel $alt-else) + (.visitInsn Opcodes/POP) + (compile-pattern* bodies stack-depth $else _right-pm))) )) -(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 bodies pm $end] + (|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* bodies 1 $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)) - )) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_fail" "()V") + (.visitInsn Opcodes/ACONST_NULL) + (.visitJumpInsn Opcodes/GOTO $end)))) + +(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] +(defn compile-case [compile ?value ?pm ?bodies] (|do [^MethodVisitor *writer* &/get-writer - :let [$end (new Label)] + :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 [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + _ (compile-pattern *writer* bodies-labels ?pm $end)] + _ (compile-bodies *writer* compile bodies-labels ?bodies $end) :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 121374b37..bd3dbf00d 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -560,6 +560,223 @@ (&&/save-class! (second (string/split &&/function-class #"/")) (.toByteArray (doto =class .visitEnd))))) +(defn ^:private compile-LuxUtils-adt-methods [=class] + (|let [_ (let [$begin (new Label) + $not-rec (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size + (.visitInsn Opcodes/ISUB) ;; sub-index + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple + (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size + (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem + (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-rec) ;; tuple-size, index-last-elem + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $is-last (new Label) + $must-copy (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; + ;; Must recurse + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/DUP) ;; tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size + (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem + (.visitInsn Opcodes/AALOAD) ;; tuple-tail + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size + (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* + (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail + (.visitVarInsn Opcodes/ASTORE 0) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $must-copy) + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $is-last) ;; tuple-size, index-last-elem + (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $just-return (new Label) + $then (new Label) + $further (new Label) + $not-right (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 0) (to-array [])) + (.visitVarInsn Opcodes/ILOAD 1) ;; tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum + (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' + &&/unwrap-int ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $then) ;; tag, sum-tag + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? + (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) + (.visitJumpInsn Opcodes/GOTO $further) + (.visitLabel $just-return) + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitInsn Opcodes/POP2) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 2)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $further) ;; tag, sum-tag + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum + (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? + (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/ISUB) ;; sub-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum + (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx + (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-right) ;; tag, sum-tag + (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$is-null (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 3)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ILOAD 0) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 2)) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + (.visitFrame Opcodes/F_NEW (int 3) (to-array [Opcodes/INTEGER "java/lang/Object" "java/lang/Object"]) (int 0) (to-array [])) + (.visitLabel $is-null) + (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn "Can't create variant for null pointer") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)))] + nil)) + +(defn ^:private compile-LuxUtils-pm-methods [=class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) + (.visitCode) + (.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) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + nil)) + (def compile-LuxUtils-class (|do [_ (return nil) :let [full-name &&/lux-utils-class @@ -577,176 +794,23 @@ (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd)) - =product_getLeft-method (let [$begin (new Label) - $not-rec (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index - (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem - (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size - (.visitInsn Opcodes/ISUB) ;; sub-index - (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple - (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size - (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem - (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem - (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index - (.visitVarInsn Opcodes/ISTORE 1) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $not-rec) ;; tuple-size, index-last-elem - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index - (.visitInsn Opcodes/AALOAD) ;; elem - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - =product_getRight-method (let [$begin (new Label) - $is-last (new Label) - $must-copy (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index - (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem - (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; - ;; Must recurse - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/DUP) ;; tuple, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size - (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem - (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem - (.visitInsn Opcodes/AALOAD) ;; tuple-tail - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size - (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 - (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* - (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* - (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail - (.visitVarInsn Opcodes/ASTORE 0) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $must-copy) - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 0) (to-array [])) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $is-last) ;; tuple-size, index-last-elem - (.visitFrame Opcodes/F_NEW (int 2) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index - (.visitInsn Opcodes/AALOAD) ;; elem - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - =sum-get-method (let [$begin (new Label) - $just-return (new Label) - $then (new Label) - $further (new Label) - $not-right (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 0) (to-array [])) - (.visitVarInsn Opcodes/ILOAD 1) ;; tag - (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum - (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' - &&/unwrap-int ;; tag, sum-tag - (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag - (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag - (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag - (.visitInsn Opcodes/POP2) - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/ARETURN) - (.visitLabel $then) ;; tag, sum-tag - (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) - (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? - (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) - (.visitJumpInsn Opcodes/GOTO $further) - (.visitLabel $just-return) - (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) - (.visitInsn Opcodes/POP2) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 2)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - (.visitLabel $further) ;; tag, sum-tag - (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) - (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum - (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? - (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag - (.visitInsn Opcodes/ISUB) ;; sub-tag - (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum - (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx - (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag - (.visitVarInsn Opcodes/ISTORE 1) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $not-right) ;; tag, sum-tag - (.visitFrame Opcodes/F_NEW (int 3) (to-array ["[Ljava/lang/Object;" Opcodes/INTEGER Opcodes/INTEGER]) (int 2) (to-array [Opcodes/INTEGER Opcodes/INTEGER])) - (.visitInsn Opcodes/POP2) - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - =sum-make-method (let [$is-null (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitJumpInsn Opcodes/IFNULL $is-null) - (.visitLdcInsn (int 3)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ILOAD 0) - (&&/wrap-int) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 2)) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - (.visitFrame Opcodes/F_NEW (int 3) (to-array [Opcodes/INTEGER "java/lang/Object" "java/lang/Object"]) (int 0) (to-array [])) - (.visitLabel $is-null) - (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn "Can't create variant for null pointer") - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V") - (.visitInsn Opcodes/ATHROW) - (.visitMaxs 0 0) - (.visitEnd)))]] + _ (let [$end (new Label) + $else (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitLdcInsn "LOG: ") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (doto =class + (compile-LuxUtils-adt-methods) + (compile-LuxUtils-pm-methods))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 920fd21bc..24636bf16 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,17 +28,186 @@ ("loop" 1) ) +;; For pattern-matching +(defvariant + ("PopPM" 0) + ("BindPM" 1) + ("BoolPM" 1) + ("IntPM" 1) + ("RealPM" 1) + ("CharPM" 1) + ("TextPM" 1) + ("VariantPM" 1) + ("TuplePM" 1) + ("AltPM" 2) + ("SeqPM" 2) + ("ExecPM" 1)) + ;; [Utils] +(defn ^:private transform-pm* [test] + (|case test + (&a-case/$NoTestAC) + (&/|list $PopPM) + + (&a-case/$StoreTestAC _register) + (&/|list ($BindPM _register) + $PopPM) + + (&a-case/$BoolTestAC _value) + (&/|list ($BoolPM _value) + $PopPM) + + (&a-case/$IntTestAC _value) + (&/|list ($IntPM _value) + $PopPM) + + (&a-case/$RealTestAC _value) + (&/|list ($RealPM _value) + $PopPM) + + (&a-case/$CharTestAC _value) + (&/|list ($CharPM _value) + $PopPM) + + (&a-case/$TextTestAC _value) + (&/|list ($TextPM _value) + $PopPM) + + (&a-case/$VariantTestAC _idx _num-options _sub-test) + (&/|++ (&/|list ($VariantPM (if (= _idx (dec _num-options)) + (&/$Right _idx) + (&/$Left _idx)))) + (&/|++ (transform-pm* _sub-test) + (&/|list $PopPM))) + + (&a-case/$TupleTestAC _sub-tests) + (|case _sub-tests + (&/$Nil) + (&/|list $PopPM) + + (&/$Cons _only-test (&/$Nil)) + (transform-pm* _only-test) + + _ + (|let [tuple-size (&/|length _sub-tests)] + (&/|++ (&/flat-map (fn [idx+test*] + (|let [[idx test*] idx+test*] + (&/$Cons ($TuplePM (if (< idx (dec tuple-size)) + (&/$Left idx) + (&/$Right idx))) + (transform-pm* test*)))) + (&/zip2 (&/|range tuple-size) + _sub-tests)) + (&/|list $PopPM)))))) + +(defn ^:private clean-unnecessary-pops [steps] + (|case steps + (&/$Cons ($PopPM) _steps) + (clean-unnecessary-pops _steps) + + _ + steps)) + +(defn ^:private transform-pm [test body-id] + (&/fold (fn [right left] ($SeqPM left right)) + ($ExecPM body-id) + (clean-unnecessary-pops (&/|reverse (transform-pm* test))))) + +(defn ^:private fuse-pms [pre post] + (|case (&/T [pre post]) + [($PopPM) ($PopPM)] + $PopPM + + [($BindPM _pre-var-id) ($BindPM _post-var-id)] + (if (= _pre-var-id _post-var-id) + ($BindPM _pre-var-id) + ($AltPM pre post)) + + [($BoolPM _pre-value) ($BoolPM _post-value)] + (if (= _pre-value _post-value) + ($BoolPM _pre-value) + ($AltPM pre post)) + + [($IntPM _pre-value) ($IntPM _post-value)] + (if (= _pre-value _post-value) + ($IntPM _pre-value) + ($AltPM pre post)) + + [($RealPM _pre-value) ($RealPM _post-value)] + (if (= _pre-value _post-value) + ($RealPM _pre-value) + ($AltPM pre post)) + + [($CharPM _pre-value) ($CharPM _post-value)] + (if (= _pre-value _post-value) + ($CharPM _pre-value) + ($AltPM pre post)) + + [($TextPM _pre-value) ($TextPM _post-value)] + (if (= _pre-value _post-value) + ($TextPM _pre-value) + ($AltPM pre post)) + + [($TuplePM (&/$Left _pre-idx)) ($TuplePM (&/$Left _post-idx))] + (if (= _pre-idx _post-idx) + ($TuplePM (&/$Left _pre-idx)) + ($AltPM pre post)) + + [($TuplePM (&/$Right _pre-idx)) ($TuplePM (&/$Right _post-idx))] + (if (= _pre-idx _post-idx) + ($TuplePM (&/$Right _pre-idx)) + ($AltPM pre post)) + + [($VariantPM (&/$Left _pre-idx)) ($VariantPM (&/$Left _post-idx))] + (if (= _pre-idx _post-idx) + ($VariantPM (&/$Left _pre-idx)) + ($AltPM pre post)) + + [($VariantPM (&/$Right _pre-idx)) ($VariantPM (&/$Right _post-idx))] + (if (= _pre-idx _post-idx) + ($VariantPM (&/$Right _pre-idx)) + ($AltPM pre post)) + + [($SeqPM _pre-pre _pre-post) ($SeqPM _post-pre _post-post)] + (|case (fuse-pms _pre-pre _post-pre) + ($AltPM _ _) + ($AltPM pre post) + + fused-pre + ($SeqPM fused-pre (fuse-pms _pre-post _post-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 _body-id))) + (&/zip2 branches + bodies-ids))] + (|case (&/|reverse pms) + (&/$Nil) + (assert false) + + (&/$Cons _head-pm _tail-pms) + (&/T [(&/fold fuse-pms _head-pm _tail-pms) + bodies]) + ))) + (defn ^:private shift-pattern [pattern] (|case pattern - (&a-case/$StoreTestAC idx) - (&a-case/$StoreTestAC (inc idx)) + ($BindPM _var-id) + ($BindPM (inc _var-id)) - (&a-case/$TupleTestAC sub-tests) - (&a-case/$TupleTestAC (&/|map shift-pattern sub-tests)) + ($SeqPM _left-pm _right-pm) + ($SeqPM (shift-pattern _left-pm) (shift-pattern _right-pm)) - (&a-case/$VariantTestAC idx num-options sub-test) - (&a-case/$VariantTestAC (&/T [idx num-options (shift-pattern sub-test)])) + ($AltPM _left-pm _right-pm) + ($AltPM (shift-pattern _left-pm) (shift-pattern _right-pm)) _ pattern @@ -69,15 +237,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 +292,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 +317,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 +348,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 +387,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)]) _ |