aboutsummaryrefslogtreecommitdiff
path: root/src/lux/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/lux/compiler')
-rw-r--r--src/lux/compiler/case.clj568
-rw-r--r--src/lux/compiler/host.clj194
-rw-r--r--src/lux/compiler/lambda.clj176
3 files changed, 938 insertions, 0 deletions
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
new file mode 100644
index 000000000..8f35ec2c0
--- /dev/null
+++ b/src/lux/compiler/case.clj
@@ -0,0 +1,568 @@
+
+(let [+tag-sig+ (->type-signature "java.lang.String")
+ variant-class* (->class +variant-class+)
+ tuple-class* (->class +tuple-class+)
+ +variant-field-sig+ (->type-signature "java.lang.Object")
+ oclass (->class "java.lang.Object")
+ equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
+ (defn ^:private compile-decision-tree [writer mappings default-label decision-tree]
+ (match decision-tree
+ [::test-bool ?pairs]
+ (compile-compare-bools writer mappings default-label ?pairs)
+
+ [::test-int ?pairs]
+ (compile-compare-ints writer mappings default-label ?pairs)
+
+ [::test-real ?pairs]
+ (compile-compare-reals writer mappings default-label ?pairs)
+
+ [::test-char ?pairs]
+ (compile-compare-chars writer mappings default-label ?pairs)
+
+ [::test-text ?pairs]
+ (compile-compare-texts writer mappings default-label ?pairs)
+
+ [::store ?idx $body]
+ (doto writer
+ (.visitVarInsn Opcodes/ASTORE ?idx)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body)))
+
+ [::test-tuple ?branches ?cases]
+ (let [[_ ?subcases] (first ?cases)
+ arity (-> ?subcases first (nth 2) count)
+ tuple-class** (str tuple-class* arity)]
+ (doto writer
+ ;; object
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple
+ (do (doseq [subcase ?subcases
+ :let [next-subcase (new Label)]]
+ (match subcase
+ [::subcase $body ?subseq]
+ (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
+ :let [sub-next-elem (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; tuple, tuple
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; tuple, object
+ (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple
+ (.visitLabel sub-next-elem)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel next-subcase)))
+ )))
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+
+ [::test-variant ?branches ?cases]
+ (doto writer
+ ;; object
+ (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag
+ (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag
+ (.visitLdcInsn ?tag) ;; variant, tag, tag, text
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B
+ (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag
+ (.visitInsn Opcodes/POP) ;; variant
+ (do (let [arity (-> ?subcases first (nth 2) count)
+ variant-class** (str variant-class* arity)]
+ (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN
+ (doseq [subcase ?subcases
+ :let [next-subcase (new Label)]]
+ (match subcase
+ [::subcase $body ?subseq]
+ (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
+ :let [sub-next-elem (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; variant, object
+ (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; variant
+ (.visitLabel sub-next-elem)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel next-subcase)))
+ ))
+ ))
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)
+ ;; variant, tag ->
+ (.visitLabel tag-else-label))
+ (->> (doseq [[?tag ?subcases] ?cases
+ :let [tag-else-label (new Label)]])))
+ ;; variant, tag ->
+ (.visitInsn Opcodes/POP) ;; variant ->
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+ ))
+
+(defn ^:private map-branches [idx mappings patterns]
+ (reduce (fn [[idx mappings patterns*] [test body]]
+ [(inc idx)
+ (assoc mappings idx body)
+ (cons [test idx] patterns*)])
+ [idx mappings (list)]
+ patterns))
+
+(defn ^:private map-bodies [pm-struct]
+ (match pm-struct
+ [::BoolPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::BoolPM patterns* defaults*]])
+
+ [::IntPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::IntPM patterns* defaults*]])
+
+ [::RealPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::RealPM patterns* defaults*]])
+
+ [::CharPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::CharPM patterns* defaults*]])
+
+ [::TextPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::TextPM patterns* defaults*]])
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::TuplePM ?num-elems patterns* defaults*]])
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::VariantPM ?tags patterns* defaults*]])
+
+ [::?PM ?defaults]
+ (let [[_ mappings defaults*] (map-branches 0 {} ?defaults)]
+ [mappings [::?PM defaults*]])))
+
+(defn ^:private get-default [pm-struct]
+ (match pm-struct
+ [::BoolPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::IntPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::RealPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::CharPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::TextPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (first ?defaults)
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (first ?defaults)
+
+ [::?PM ?defaults]
+ (first ?defaults)
+ ))
+
+(do-template [<name> <wrapper-class> <value-method> <method-sig>]
+ (defn <name> [writer mappings $default ?patterns]
+ (doseq [[?token $body] ?patterns
+ :let [$else (new Label)]]
+ (doto writer
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>)
+ (.visitLdcInsn ?token)
+ (.visitJumpInsn Opcodes/IF_ICMPNE $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel $else)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $default)))
+
+ ^:private compile-bool-pm "java.lang.Boolean" "booleanValue" "()Z"
+ ^:private compile-char-pm "java.lang.Character" "charValue" "()C"
+ )
+
+(do-template [<name> <wrapper-class> <value-method> <method-sig> <cmp-op>]
+ (defn <name> [writer mappings $default ?patterns]
+ (doseq [[?token $body] ?patterns
+ :let [$else (new Label)]]
+ (doto writer
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>)
+ (.visitLdcInsn ?token)
+ (.visitInsn <cmp-op>)
+ (.visitJumpInsn Opcodes/IFNE $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel $else)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $default)))
+
+ ^:private compile-int-pm "java.lang.Long" "longValue" "()J" Opcodes/LCMP
+ ^:private compile-real-pm "java.lang.Double" "doubleValue" "()D" Opcodes/DCMPL
+ )
+
+(defn ^:private compile-text-pm [writer mappings $default ?patterns]
+ (doseq [[?token $body] ?patterns
+ :let [$else (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn ?token)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Object") "equals" (str "(" (->type-signature "java.lang.Object") ")Z"))
+ (.visitJumpInsn Opcodes/IFEQ $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel $else)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $default)))
+
+(defn ^:private compile-tuple-pm [writer mapping $default ?num-elems ?patterns]
+ (let [sub-patterns (map (fn [idx]
+ (map (fn [tup body]
+ [(nth tup idx) body])
+ ?patterns))
+ (range ?num-elems))
+ subpm-structs (map group-patterns sub-patterns)
+ [pat-h & pat-t] subpm-structs
+ (for [(get-branches pat-h)
+ (cull pat-t)]
+ )
+ (reduce (fn [branches pattern]
+ ( (group-patterns pattern)))
+ (get-branches pat-h)
+ pat-t)
+ (sequence-tests sub-patterns)]
+ ))
+
+(defn ^:private compile-pm [writer mapping pm-struct]
+ (match pm-struct
+ [::BoolPM ?patterns ?defaults]
+ (compile-bool-pm writer mapping $default ?patterns)
+
+ [::IntPM ?patterns ?defaults]
+ (compile-int-pm writer mapping $default ?patterns)
+
+ [::RealPM ?patterns ?defaults]
+ (compile-real-pm writer mapping $default ?patterns)
+
+ [::CharPM ?patterns ?defaults]
+ (compile-char-pm writer mapping $default ?patterns)
+
+ [::TextPM ?patterns ?defaults]
+ (compile-text-pm writer mapping $default ?patterns)
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (compile-tuple-pm writer mapping $default ?num-elems ?patterns)
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (first ?defaults)
+
+ [::?PM ?defaults]
+ (first ?defaults)
+ ))
+
+(do-template [<name> <pm-tag>]
+ (defn <name> [pm value body]
+ (match pm
+ [<pm-tag> ?branches ?defaults]
+ (return [<pm-tag> (cons [value body] ?branches) ?defaults])
+
+ [::?PM ?defaults]
+ (return [<pm-tag> (list [value body]) ?defaults])
+
+ _
+ (fail "Can't match pattern!")))
+
+ ^:private group-bool-pm ::BoolPM
+ ^:private group-int-pm ::IntPM
+ ^:private group-real-pm ::RealPM
+ ^:private group-char-pm ::CharPM
+ ^:private group-text-pm ::textPM
+ )
+
+(defn ^:private group-branch [pm [pattern body]]
+ (match pattern
+ [::&parser/Bool ?value]
+ (group-bool-pm pm ?value body)
+
+ [::&parser/Int ?value]
+ (group-int-pm pm ?value body)
+
+ [::&parser/Real ?value]
+ (group-real-pm pm ?value body)
+
+ [::&parser/Char ?value]
+ (group-char-pm pm ?value body)
+
+ [::&parser/Text ?value]
+ (group-text-pm pm ?value body)
+
+ [::&parser/Tuple ?members]
+ (match pm
+ [::TuplePM ?num-elems ?branches ?defaults]
+ (exec [_ (assert! (= ?num-elems (count ?members))
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " (count ?members)))]
+ (return [::TuplePM ?num-elems (cons [?members body] ?branches) ?defaults]))
+
+ [::?PM ?defaults]
+ (return [::TuplePM (count ?members) (list [?members body]) ?defaults])
+
+ _
+ (fail "Can't match pattern!"))
+
+ [::&parser/Tag ?tag]
+ (let [members (list)
+ num-members (count members)]
+ (match pm
+ [::VariantPM ?variants ?branches ?defaults]
+ (exec [variants* (if-let [?num-elems (get ?variants ?tag)]
+ (exec [_ (assert! (= ?num-elems num-members)
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
+ (return ?variants))
+ (return (assoc ?variants ?tag num-members)))]
+ (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults]))
+
+ [::?PM ?defaults]
+ (return [::VariantPM {?tag num-members} (list [[?tag members] body]) ?defaults])
+
+ _
+ (fail "Can't match pattern!")))
+
+ [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)]
+ (let [members ?members
+ num-members (count members)]
+ (match pm
+ [::VariantPM ?variants ?branches ?defaults]
+ (exec [variants* (if-let [?num-elems (get ?variants ?tag)]
+ (exec [_ (assert! (= ?num-elems num-members)
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
+ (return ?variants))
+ (return (assoc ?variants ?tag num-members)))]
+ (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults]))
+
+ [::?PM ?defaults]
+ (return [::VariantPM {?tag num-members} (list [[?tag members] body]) ?defaults])
+
+ _
+ (fail "Can't match pattern!")))
+
+ [::&parser/Ident ?name]
+ (match pm
+ [::BoolPM ?patterns ?defaults]
+ (return [::BoolPM ?patterns (conj ?defaults [?name body])])
+
+ [::IntPM ?patterns ?defaults]
+ (return [::IntPM ?patterns (conj ?defaults [?name body])])
+
+ [::RealPM ?patterns ?defaults]
+ (return [::RealPM ?patterns (conj ?defaults [?name body])])
+
+ [::CharPM ?patterns ?defaults]
+ (return [::CharPM ?patterns (conj ?defaults [?name body])])
+
+ [::TextPM ?patterns ?defaults]
+ (return [::TextPM ?patterns (conj ?defaults [?name body])])
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (return [::TuplePM ?num-elems ?patterns (conj ?defaults [?name body])])
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (return [::VariantPM ?tags ?patterns (conj ?defaults [?name body])])
+
+ [::?PM ?defaults]
+ (return [::?PM (conj ?defaults [?name body])]))
+ ))
+
+(defn ^:private valid-paths [group]
+ (set (match group
+ [::BoolPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::IntPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::RealPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::CharPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::TextPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::?PM ?defaults]
+ (map second ?defaults))))
+
+(defn ^:private sequence-multi-pm [sequence-pm prev-paths groups]
+ (match groups
+ ([head & tail] :seq)
+ (for [:let [curr-paths (set/intersection prev-paths (valid-paths head))]
+ [head-paths head-test] (sequence-pm curr-paths head)]
+ [:multi-test head-test head-paths (sequence-multi-pm sequence-pm head-paths tail)])
+
+ _
+ (list (list))))
+
+(do-template [<name> <pm> <test>]
+ (defn <name> [prev-paths group]
+ (match group
+ [<pm> ?patterns ?defaults]
+ (return (concat (for [[value $body] ?patterns
+ :when (contains? prev-paths $body)]
+ [<test> value #{$body}])
+ (match ?defaults
+ ([[default-register $body] & _] :seq)
+ (list [<test> default-register #{$body}])
+
+ :else
+ (list))))
+
+ :else
+ (fail "")))
+
+ ^:private sequence-bool ::BoolPM ::test-bool
+ ^:private sequence-int ::IntPM ::test-int
+ ^:private sequence-real ::RealPM ::test-real
+ ^:private sequence-char ::CharPM ::test-char
+ ^:private sequence-text ::TextPM ::test-text
+ )
+
+(defn ^:private sequence-? [group]
+ [::?PM ([[default-register $body] & _] :seq)]
+ (return (list [<test> default-register #{$body}]))
+
+ :else
+ (fail ""))
+
+(defn ^:private sequence-pm [group]
+ (match group
+ [::BoolPM _ _]
+ (sequence-bool group)
+
+ [::IntPM _ _]
+ (sequence-int group)
+
+ [::RealPM _ _]
+ (sequence-real group)
+
+ [::CharPM _ _]
+ (sequence-char group)
+
+ [::TextPM _ _]
+ (sequence-text group)
+
+ [::?PM _]
+ (sequence-? group)
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (exec [:let [sub-patterns (map (fn [idx]
+ (map (fn [[tup body]]
+ [(nth tup idx) body])
+ ?patterns))
+ (range ?num-elems))]
+ groups (map-m #(reduce-m group-branch [::?PM (list)] %) sub-patterns)
+ tuple-paths (valid-paths group)
+ sub-seqs (sequence-multi-pm sequence-pm tuple-paths groups)]
+ (return (cons [::test-tuple ?num-elems sub-seqs]
+ (match ?defaults
+ ([[default-register $body] & _] :seq)
+ (list [<test> default-register #{$body}])
+
+ :else
+ (list)))))
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (map-m (fn [tag]
+ (exec [:let [members+bodies (mapcat (fn [[ptag pmembers pbody]]
+ (if (= ptag tag)
+ (list [pmembers pbody])
+ (list)))
+ ?patterns)
+ sub-patterns (map (fn [idx]
+ (map (fn [[tup body]]
+ [(nth tup idx) body])
+ members+bodies))
+ (range ?num-elems))]
+ groups (map-m #(reduce-m group-branch [::?PM (list)] %) sub-patterns)
+ tag-paths (set (map second members+bodies))
+ sub-seqs (sequence-multi-pm sequence-pm tag-paths groups)]
+ (cons [::test-variant tag ?num-elems sub-seqs]
+ (match ?defaults
+ ([[default-register $body] & _] :seq)
+ (list [<test> default-register #{$body}])
+
+ :else
+ (list)))))
+ (keys ?tags))
+ ))
+
+(defn ^:private decision-tree [branches]
+ (exec [group (reduce-m group-branch [::?PM (list)] branches)
+ :let [[mappings group*] (map-bodies group)
+ paths (valid-paths group*)]]
+ (sequence-pm paths group*)))
+
+(let [ex-class (->class "java.lang.IllegalStateException")]
+ (defn ^:private compile-case [compile *type* ?variant ?base-register ?num-registers ?branches]
+ (exec [*writer* &util/get-writer
+ :let [$start (new Label)
+ $end (new Label)
+ _ (dotimes [offset ?num-registers]
+ (let [idx (+ ?base-register offset)]
+ (.visitLocalVariable *writer* (str +local-prefix+ idx) (->java-sig [::&type/Any]) nil $start $end idx)))]
+ _ (compile ?variant)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitLabel $start))]
+ :let [[mapping tree] (decision-tree ?branches)]
+
+ :let [[mappings pm-struct*] (map-bodies pm-struct)
+ entries (for [[?branch ?body] mappings
+ :let [label (new Label)]]
+ [[?branch label]
+ [label ?body]])
+ mappings* (into {} (map first entries))
+ ]
+ :let [$default (new Label)
+ _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts ?pm-struct))]
+ (if (get-default pm-struct)
+ (butlast pieces)
+ pieces))]
+ (compile-decision-tree *writer* mappings* $default decision-tree))
+ (.visitLabel *writer* $default)
+ (if-let [[?idx ?body] (get-default pm-struct)]
+ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitVarInsn Opcodes/ASTORE ?idx)
+ (.visitJumpInsn Opcodes/GOTO (get mappings* ?body)))
+ (doto *writer*
+ (.visitInsn Opcodes/POP)
+ (.visitTypeInsn Opcodes/NEW ex-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+ (.visitInsn Opcodes/ATHROW))))]
+ _ (map-m (fn [[?label ?body]]
+ (exec [:let [_ (do (.visitLabel *writer* ?label)
+ (.visitInsn *writer* Opcodes/POP))]
+ ret (compile ?body)
+ :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]]
+ (return ret)))
+ (map second entries))
+ :let [_ (.visitLabel *writer* $end)]]
+ (return nil))))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
new file mode 100644
index 000000000..dfe67eece
--- /dev/null
+++ b/src/lux/compiler/host.clj
@@ -0,0 +1,194 @@
+
+(let [class+metthod+sig {"boolean" [(->class "java.lang.Boolean") "booleanValue" "()Z"]
+ "byte" [(->class "java.lang.Byte") "byteValue" "()B"]
+ "short" [(->class "java.lang.Short") "shortValue" "()S"]
+ "int" [(->class "java.lang.Integer") "intValue" "()I"]
+ "long" [(->class "java.lang.Long") "longValue" "()J"]
+ "float" [(->class "java.lang.Float") "floatValue" "()F"]
+ "double" [(->class "java.lang.Double") "doubleValue" "()D"]
+ "char" [(->class "java.lang.Character") "charValue" "()C"]}]
+ (defn ^:private prepare-arg! [*writer* class-name]
+ (if-let [[class method sig] (get class+metthod+sig class-name)]
+ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST class)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig))
+ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name)))))
+
+;; (let [boolean-class "java.lang.Boolean"
+;; integer-class "java.lang.Integer"
+;; char-class "java.lang.Character"]
+;; (defn prepare-return! [*writer* *type*]
+;; (match *type*
+;; ::&type/nothing
+;; (.visitInsn *writer* Opcodes/ACONST_NULL)
+
+;; [::&type/primitive "char"]
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class)))
+
+;; [::&type/primitive "int"]
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class)))
+
+;; [::&type/primitive "boolean"]
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class)))
+
+;; [::&type/Data ?oclass]
+;; nil)))
+
+
+(defn ^:private compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
+ (exec [*writer* &util/get-writer
+ :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
+ _ (map-m (fn [[class-name arg]]
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
+ :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class ?class) ?method method-sig)
+ ;; (prepare-return! *writer* *type*)
+ )]]
+ (return nil)))
+
+(defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args]
+ (exec [*writer* &util/get-writer
+ :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
+ _ (compile ?object)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
+ _ (map-m (fn [[class-name arg]]
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
+ :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig)
+ ;; (prepare-return! *writer* *type*)
+ )]]
+ (return nil)))
+
+(defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args]
+ (exec [*writer* &util/get-writer
+ :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V")
+ class* (->class ?class)
+ _ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW class*)
+ (.visitInsn Opcodes/DUP))]
+ _ (map-m (fn [[class-name arg]]
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-new-array [compile *type* ?class ?length]
+ (exec [*writer* &util/get-writer
+ :let [_ (doto *writer*
+ (.visitLdcInsn (int ?length))
+ (.visitTypeInsn Opcodes/ANEWARRAY (->class ?class)))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem]
+ (exec [*writer* &util/get-writer
+ _ (compile ?array)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int ?idx)))]
+ _ (compile ?elem)
+ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
+ (return nil)))
+
+(defn ^:private compile-jvm-aaload [compile *type* ?array ?idx]
+ (exec [*writer* &util/get-writer
+ _ (compile ?array)
+ :let [_ (doto *writer*
+ (.visitLdcInsn (int ?idx))
+ (.visitInsn Opcodes/AALOAD))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-getstatic [compile *type* ?class ?field]
+ (exec [*writer* &util/get-writer
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?class) ?field (->java-sig *type*))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-getfield [compile *type* ?class ?field ?object]
+ (exec [*writer* &util/get-writer
+ _ (compile ?object)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (->class ?class) ?field (->java-sig *type*))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods]
+ (let [parent-dir (->package ?package)
+ full-name (str parent-dir "/" ?name)
+ super-class* (->class ?super-class)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ full-name nil super-class* nil))
+ _ (do (doseq [[field props] ?fields]
+ (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil)
+ (.visitEnd)))
+ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL super-class* "<init>" "()V")
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ (.visitEnd =class)
+ (.mkdirs (java.io.File. (str "output/" parent-dir))))]
+ (save-class! full-name (.toByteArray =class))))
+
+(defn ^:private compile-jvm-interface [compile *type* ?package ?name ?fields ?methods]
+ (let [parent-dir (->package ?package)
+ full-name (str parent-dir "/" ?name)
+ =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE)
+ full-name nil "java/lang/Object" nil))
+ _ (do (doseq [[?method ?props] ?methods
+ :let [[?args ?return] (:type ?props)
+ signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]]
+ (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil))
+ (.visitEnd =interface)
+ (.mkdirs (java.io.File. (str "output/" parent-dir))))]
+ (save-class! full-name (.toByteArray =interface))))
+
+(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>]
+ (defn <name> [compile *type* ?x ?y]
+ (exec [:let [+wrapper-class+ (->class <wrapper-class>)]
+ *writer* &util/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
+ _ (doto *writer*
+ (.visitInsn <opcode>)
+ (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (->type-signature <wrapper-class>))))]]
+ (return nil)))
+
+ ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+
+ ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+
+ ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+
+ ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ )
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
new file mode 100644
index 000000000..b3bfc4860
--- /dev/null
+++ b/src/lux/compiler/lambda.clj
@@ -0,0 +1,176 @@
+(ns lux.compiler.lambda)
+
+;; [Utils]
+(def ^:private clo-field-sig (->type-signature "java.lang.Object"))
+(def ^:private lambda-return-sig (->type-signature "java.lang.Object"))
+(def ^:private <init>-return "V")
+(def ^:private counter-sig "I")
+(def ^:private +datum-sig+ (->type-signature "java.lang.Object"))
+
+(defn ^:private lambda-impl-signature [args]
+ (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig))
+
+(defn ^:private lambda-<init>-signature [closed-over args]
+ (let [num-args (count args)]
+ (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig))
+ (if (> num-args 1)
+ (reduce str counter-sig (repeat (dec num-args) clo-field-sig)))
+ ")"
+ <init>-return)))
+
+(defn ^:private add-lambda-<init> [class class-name closed-over args init-signature]
+ (let [num-args (count args)
+ num-mappings (count closed-over)]
+ (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD ?captured-id)
+ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
+ (->> (let [captured-name (str +closure-prefix+ ?captured-id)])
+ (match (:form ?captured)
+ [::&analyser/captured ?closure-id ?captured-id ?source])
+ (doseq [[?name ?captured] closed-over])))
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ICONST_0)
+ (.visitFieldInsn Opcodes/PUTFIELD class-name "_counter" counter-sig)
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset))
+ (.visitFieldInsn Opcodes/PUTFIELD class-name field-name clo-field-sig))
+ (->> (let [field-name (str +partial-prefix+ clo_idx)]
+ (doto (.visitField class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil)
+ (.visitEnd)))
+ (dotimes [clo_idx (dec num-args)])
+ (let [offset (+ 2 num-mappings)]))))
+ (->> (when (> num-args 1))))
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
+(do-template [<name> <prefix>]
+ (defn <name> [writer class-name vars]
+ (dotimes [idx (count vars)]
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name (str <prefix> idx) clo-field-sig))))
+
+ ^:private add-closure-vars +closure-prefix+
+ ^:private add-partial-vars +partial-prefix+
+ )
+
+(defn ^:private add-nulls [writer amount]
+ (dotimes [_ amount]
+ (.visitInsn writer Opcodes/ACONST_NULL)))
+
+(defn ^:private add-lambda-apply [class class-name closed-over args impl-signature init-signature]
+ (let [num-args (count args)
+ num-captured (dec num-args)
+ default-label (new Label)
+ branch-labels (for [_ (range num-captured)]
+ (new Label))]
+ (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil)
+ (.visitCode)
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig)
+ (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
+ (-> (doto (.visitLabel branch-label)
+ (.visitTypeInsn Opcodes/NEW class-name)
+ (.visitInsn Opcodes/DUP)
+ (add-closure-vars class-name closed-over)
+ (.visitLdcInsn (int current-captured))
+ (add-partial-vars class-name (take current-captured args))
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (add-nulls (- (dec num-captured) current-captured))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" init-signature)
+ (.visitInsn Opcodes/ARETURN))
+ (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))])))
+ (.visitLabel default-label))
+ (->> (when (> num-args 1))))
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (add-partial-vars class-name (butlast args))
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
+(defn ^:private add-lambda-impl [class compile impl-signature impl-body]
+ (&util/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil)
+ (.visitCode))
+ (exec [;; :let [_ (prn 'add-lambda-impl/_0)]
+ *writer* &util/get-writer
+ ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)]
+ ret (compile impl-body)
+ ;; :let [_ (prn 'add-lambda-impl/_2 ret)]
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]
+ ;; :let [_ (prn 'add-lambda-impl/_3)]
+ ]
+ (return ret))))
+
+(defn ^:private instance-closure [compile lambda-class closed-over args init-signature]
+ (exec [*writer* &util/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW lambda-class)
+ (.visitInsn Opcodes/DUP))]
+ _ (->> closed-over
+ (sort #(< (-> %1 second :form (nth 2))
+ (-> %2 second :form (nth 2))))
+ (map-m (fn [[?name ?captured]]
+ (match (:form ?captured)
+ [::&analyser/captured ?closure-id ?captured-id ?source]
+ (compile ?source)))))
+ :let [num-args (count args)
+ _ (do (when (> num-args 1)
+ (.visitInsn *writer* Opcodes/ICONST_0)
+ (add-nulls *writer* (dec num-args)))
+ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature))]]
+ (return nil)))
+
+(defn ^:private add-lambda-<clinit> [class class-name args <init>-sig]
+ (let [num-args (count args)]
+ (doto (.visitMethod class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
+ (.visitCode)
+ (.visitTypeInsn Opcodes/NEW class-name)
+ (.visitInsn Opcodes/DUP)
+ (-> (doto (.visitInsn *writer* Opcodes/ICONST_0)
+ (add-nulls (dec num-args)))
+ (->> (when (> num-args 1))))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" <init>-sig)
+ (.visitFieldInsn Opcodes/PUTSTATIC class-name "_datum" +datum-sig+)
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
+;; [Resources]
+(defn compile-lambda [compile *type* ?scope ?closure ?args ?body with-datum? instance?]
+ (exec [:let [lambda-class (&host/location ?scope)
+ impl-signature (lambda-impl-signature ?args)
+ <init>-sig (lambda-<init>-signature ?closure ?args)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ lambda-class nil "java/lang/Object" (into-array [(->class +function-class+)]))
+ (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil)
+ (.visitEnd))
+ (->> (let [captured-name (str +closure-prefix+ ?captured-id)])
+ (match (:form ?captured)
+ [::&analyser/captured ?closure-id ?captured-id ?source])
+ (doseq [[?name ?captured] ?closure])))
+ (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil)
+ (.visitEnd))
+ (->> (when (> (count ?args) 1))))
+ (-> (doto (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil)
+ (add-lambda-<clinit> lambda-class ?args <init>-sig))
+ (when with-datum?))
+ (add-lambda-apply lambda-class ?closure ?args impl-signature <init>-sig)
+ (add-lambda-<init> lambda-class ?closure ?args <init>-sig)
+ )]
+ _ (add-lambda-impl =class compile impl-signature ?body)
+ :let [_ (.visitEnd =class)]
+ _ (save-class! lambda-class (.toByteArray =class))]
+ (if instance?
+ (instance-closure compile lambda-class ?closure ?args <init>-sig)
+ (return nil))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-18 01:21:18 +0000