aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lux/base.clj5
-rw-r--r--src/lux/compiler.clj4
-rw-r--r--src/lux/compiler/case.clj276
-rw-r--r--src/lux/compiler/host.clj404
-rw-r--r--src/lux/optimizer.clj247
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)])
_
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-12 22:41:53 +0000