diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/base.clj | 5 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 7 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 187 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 404 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 4 | ||||
| -rw-r--r-- | src/lux/optimizer.clj | 192 |
6 files changed, 401 insertions, 398 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 8732bd31c..a17036b7e 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -80,16 +80,13 @@ (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args) (&o/$loop ?args) - (&&lux/compile-loop (partial compile-expression $begin) (&/|first $begin) ?args) + (&&lux/compile-loop (partial compile-expression $begin) $begin ?args) (&o/$variant ?tag ?tail ?members) (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members) (&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)) + (&&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 c07222196..639883ac8 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -40,30 +40,9 @@ (.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)" +(defn ^:private compile-pattern* [^MethodVisitor writer bodies stack-depth $else pm] + "(-> MethodVisitor Case-Pattern (List Label) Int 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) @@ -74,100 +53,64 @@ (&/$None) (assert false)) - (&o/$BindPM _var-id _next-pm) + (&o/$PopPM) (doto writer - (.visitVarInsn Opcodes/ASTORE _var-id) - (compile-pattern* in-tuple? func-class-name (inc arity) stack-size bodies stack-depth $else _next-pm)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) - (&o/$BoolPM _value _next-pm) + (&o/$BindPM _var-id) (doto writer + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE _var-id)) + + (&o/$BoolPM _value) + (doto writer + (.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) - (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm)) + (.visitJumpInsn Opcodes/IF_ICMPNE $else)) - (&o/$IntPM _value _next-pm) + (&o/$IntPM _value) (doto writer + (.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)) (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else) - (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm)) + (.visitJumpInsn Opcodes/IFNE $else)) - (&o/$RealPM _value _next-pm) + (&o/$RealPM _value) (doto writer + (.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)) (.visitInsn Opcodes/DCMPL) - (.visitJumpInsn Opcodes/IFNE $else) - (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm)) + (.visitJumpInsn Opcodes/IFNE $else)) - (&o/$CharPM _value _next-pm) + (&o/$CharPM _value) (doto writer + (.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) - (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm)) + (.visitJumpInsn Opcodes/IF_ICMPNE $else)) - (&o/$TextPM _value _next-pm) + (&o/$TextPM _value) (doto writer + (.visitInsn Opcodes/DUP) + (.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) - (compile-pattern* in-tuple? func-class-name arity stack-size bodies stack-depth $else _next-pm)) + (.visitJumpInsn Opcodes/IFEQ $else)) - (&o/$UnitPM _next-pm) - (doto writer - (.visitInsn Opcodes/POP) - (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]) - - ;; (&/$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 $else) - )) - - (&o/$SeqPM _idx+ _next-pm) - (|let [$tuple-else (new Label) - [_idx is-tail?] (|case _idx+ + (&o/$TuplePM _idx+) + (|let [[_idx is-tail?] (|case _idx+ (&/$Left _idx) (&/T [_idx false]) @@ -175,14 +118,16 @@ (&/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;") - (compile-pattern* true func-class-name arity (inc stack-size) bodies stack-depth $else _next-pm) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") )) - (&o/$VariantPM _idx+ _next-pm) - (|let [;; _ (prn 'IN-VARIANT arity stack-size) - $variant-else (new Label) + (&o/$VariantPM _idx+) + (|let [$success (new Label) + $fail (new Label) [_idx is-last] (|case _idx+ (&/$Left _idx) (&/T [_idx false]) @@ -190,6 +135,8 @@ (&/$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 @@ -197,31 +144,39 @@ (.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) + (.visitJumpInsn Opcodes/IFNULL $fail) + (.visitJumpInsn Opcodes/GOTO $success) + (.visitLabel $fail) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $success) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxUtils" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) + + (&o/$SeqPM _left-pm _right-pm) + (doto writer + (compile-pattern* bodies stack-depth $else _left-pm) + (compile-pattern* bodies stack-depth $else _right-pm)) + + (&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) - (.visitJumpInsn Opcodes/GOTO $else))) + (compile-pattern* bodies stack-depth $else _right-pm))) )) -(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) +(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end] (|let [$else (new Label)] (doto writer - (compile-pattern* false func-class-name arity 1 bodies 0 $else pm) + (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))) - ) + (.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] @@ -233,14 +188,16 @@ (&/zip2 bodies-labels ?bodies))) ;; [Resources] -(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 +(defn compile-case [compile ?value ?pm ?bodies] + (|do [^MethodVisitor *writer* &/get-writer :let [$end (new Label) bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] _ (compile ?value) - :let [_ (prn 'compile-pattern* (&/adt->text ?pm)) - _ (compile-pattern *writer* func-class-name arity bodies-labels ?pm)] + :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/compiler/lambda.clj b/src/lux/compiler/lambda.clj index f14c8b68f..f51edc507 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 (&/T [$begin (&/T [class-name arity])]) impl-body) + ret (compile $begin 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 (&/T [$begin (&/T [class-name arity])]) impl-body) + ret (compile $begin impl-body) :let [_ (doto *writer* (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index bf640c642..8c3380b0a 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -30,132 +30,144 @@ ;; For pattern-matching (defvariant - ("ExecPM" 1) - ("AltPM" 2) - ("BindPM" 2) - ("BoolPM" 2) - ("IntPM" 2) - ("RealPM" 2) - ("CharPM" 2) - ("TextPM" 2) - ("UnitPM" 1) - ("VariantPM" 2) + ("PopPM" 0) + ("BindPM" 1) + ("BoolPM" 1) + ("IntPM" 1) + ("RealPM" 1) + ("CharPM" 1) + ("TextPM" 1) + ("VariantPM" 1) ("TuplePM" 1) + ("AltPM" 2) ("SeqPM" 2) - ("InnerPM" 1)) + ("ExecPM" 1)) ;; [Utils] -(defn ^:private transform-pm [test next-pm] +(defn ^:private transform-pm* [test] (|case test (&a-case/$NoTestAC) - ($UnitPM next-pm) + (&/|list $PopPM) (&a-case/$StoreTestAC _register) - ($BindPM _register next-pm) + (&/|list ($BindPM _register) + $PopPM) (&a-case/$BoolTestAC _value) - ($BoolPM _value next-pm) + (&/|list ($BoolPM _value) + $PopPM) (&a-case/$IntTestAC _value) - ($IntPM _value next-pm) + (&/|list ($IntPM _value) + $PopPM) (&a-case/$RealTestAC _value) - ($RealPM _value next-pm) + (&/|list ($RealPM _value) + $PopPM) (&a-case/$CharTestAC _value) - ($CharPM _value next-pm) + (&/|list ($CharPM _value) + $PopPM) (&a-case/$TextTestAC _value) - ($TextPM _value next-pm) + (&/|list ($TextPM _value) + $PopPM) (&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))) + (&/|++ (&/|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) - ($UnitPM next-pm) + (&/|list $PopPM) (&/$Cons _only-test (&/$Nil)) - (transform-pm _only-test next-pm) + (transform-pm* _only-test) _ (|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)))))) - )) + (&/|++ (&/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 transform-pm [test body-id] + (|case (&/|reverse (&/|++ (transform-pm* test) (&/|list ($ExecPM body-id)))) + (&/$Cons _last _prevs) + (&/fold (fn [right left] ($SeqPM left right)) _last _prevs))) (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)) + [($PopPM) ($PopPM)] + $PopPM - [($BindPM _pre-var-id _pre-next-pm) ($BindPM _post-var-id _post-next-pm)] + [($BindPM _pre-var-id) ($BindPM _post-var-id)] (if (= _pre-var-id _post-var-id) - ($BindPM _pre-var-id (fuse-pms _pre-next-pm _post-next-pm)) + ($BindPM _pre-var-id) ($AltPM pre post)) - [($BoolPM _pre-value _pre-next) ($BoolPM _post-value _post-next)] + [($BoolPM _pre-value) ($BoolPM _post-value)] (if (= _pre-value _post-value) - ($BoolPM _pre-value (fuse-pms _pre-next _post-next)) + ($BoolPM _pre-value) ($AltPM pre post)) - [($IntPM _pre-value _pre-next) ($IntPM _post-value _post-next)] + [($IntPM _pre-value) ($IntPM _post-value)] (if (= _pre-value _post-value) - ($IntPM _pre-value (fuse-pms _pre-next _post-next)) + ($IntPM _pre-value) ($AltPM pre post)) - [($RealPM _pre-value _pre-next) ($RealPM _post-value _post-next)] + [($RealPM _pre-value) ($RealPM _post-value)] (if (= _pre-value _post-value) - ($RealPM _pre-value (fuse-pms _pre-next _post-next)) + ($RealPM _pre-value) ($AltPM pre post)) - [($CharPM _pre-value _pre-next) ($CharPM _post-value _post-next)] + [($CharPM _pre-value) ($CharPM _post-value)] (if (= _pre-value _post-value) - ($CharPM _pre-value (fuse-pms _pre-next _post-next)) + ($CharPM _pre-value) ($AltPM pre post)) - [($TextPM _pre-value _pre-next) ($TextPM _post-value _post-next)] + [($TextPM _pre-value) ($TextPM _post-value)] (if (= _pre-value _post-value) - ($TextPM _pre-value (fuse-pms _pre-next _post-next)) + ($TextPM _pre-value) ($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)] + [($TuplePM (&/$Left _pre-idx)) ($TuplePM (&/$Left _post-idx))] (if (= _pre-idx _post-idx) - ($SeqPM (&/$Left _pre-idx) (fuse-pms _pre-next-pm _post-next-pm)) + ($TuplePM (&/$Left _pre-idx)) ($AltPM pre post)) - [($SeqPM (&/$Right _pre-idx) _pre-next-pm) ($SeqPM (&/$Right _post-idx) _post-next-pm)] + [($TuplePM (&/$Right _pre-idx)) ($TuplePM (&/$Right _post-idx))] (if (= _pre-idx _post-idx) - ($SeqPM (&/$Right _pre-idx) (fuse-pms _pre-next-pm _post-next-pm)) + ($TuplePM (&/$Right _pre-idx)) ($AltPM pre post)) - [($VariantPM (&/$Left _pre-idx) _pre-next-pm) ($VariantPM (&/$Left _post-idx) _post-next-pm)] + [($VariantPM (&/$Left _pre-idx)) ($VariantPM (&/$Left _post-idx))] (if (= _pre-idx _post-idx) - ($VariantPM (&/$Left _pre-idx) (fuse-pms _pre-next-pm _post-next-pm)) + ($VariantPM (&/$Left _pre-idx)) ($AltPM pre post)) - [($VariantPM (&/$Right _pre-idx) _pre-next-pm) ($VariantPM (&/$Right _post-idx) _post-next-pm)] + [($VariantPM (&/$Right _pre-idx)) ($VariantPM (&/$Right _post-idx))] (if (= _pre-idx _post-idx) - ($VariantPM (&/$Right _pre-idx) (fuse-pms _pre-next-pm _post-next-pm)) + ($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) )) @@ -166,61 +178,31 @@ bodies-ids (&/|range (&/|length bodies)) pms (&/|map (fn [branch] (|let [[[_pattern _] _body-id] branch] - (transform-pm _pattern ($ExecPM _body-id)))) + (transform-pm _pattern _body-id))) (&/zip2 branches - bodies-ids)) - _ (prn 'pms (&/|length bodies) (&/->seq bodies-ids)) - _ (&/|map (comp prn &/adt->text) pms)] + bodies-ids))] (|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])) + (&/T [(&/fold fuse-pms _head-pm _tail-pms) + bodies]) ))) (defn ^:private shift-pattern [pattern] (|case pattern - ($UnitPM _next-pm) - ($UnitPM (shift-pattern _next-pm)) - - ($InnerPM _next-pm) - ($InnerPM (shift-pattern _next-pm)) + ($BindPM _var-id) + ($BindPM (inc _var-id)) - ($BindPM _var-id _next-pm) - ($BindPM (inc _var-id) (shift-pattern _next-pm)) + ($SeqPM _left-pm _right-pm) + ($SeqPM (shift-pattern _left-pm) (shift-pattern _right-pm)) - ($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)) - + + _ + pattern )) (defn ^:private drop-scope [source] |