diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux.clj | 8 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 563 | ||||
| -rw-r--r-- | src/lux/compiler/base.clj | 36 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 352 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 164 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 55 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 196 | ||||
| -rw-r--r-- | src/lux/host.clj | 40 |
8 files changed, 757 insertions, 657 deletions
diff --git a/src/lux.clj b/src/lux.clj index 3c29968de..eb81b43a0 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -18,7 +18,6 @@ ;; TODO: Allow setting fields. ;; TODO: monitor enter & monitor exit. ;; TODO: Remember to optimize calling global functions. - ;; TODO: Reader macros. ;; TODO: ;; TODO: ;; TODO: @@ -30,10 +29,3 @@ ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 ;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd .. ) - -;; (def (workday? d) -;; (case d -;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday] -;; true) -;; (or [#Saturday #Sunday] -;; false))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 742455b86..bd1df6157 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -6,444 +6,209 @@ [clojure.core.match :refer [match]] (lux [util :as &util :refer [exec return* return fail fail* repeat-m exhaust-m try-m try-all-m map-m reduce-m - apply-m within + apply-m normalize-ident]] [type :as &type] [lexer :as &lexer] [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.analyser.base :as &a] + (lux.compiler [base :as &&] + [lux :as &&lux] + [host :as &&host] + [case :as &&case] + [lambda :as &&lambda]) :reload) (:import (org.objectweb.asm Opcodes Label ClassWriter MethodVisitor))) -;; [Utils/General] -(defn ^:private write-file [file data] - (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] - (.write stream data))) - -(defn ^:private write-class [name data] - (write-file (str "output/" name ".class") data)) - -(defn ^:private load-class! [loader name] - (.loadClass loader name)) - -(defn ^:private save-class! [name bytecode] - (exec [loader &util/loader - :let [_ (write-class name bytecode) - _ (load-class! loader (string/replace name #"/" "."))]] - (return nil))) - -(def ^:private +prefix+ "lux.") -(def ^:private +variant-class+ (str +prefix+ "Variant")) -(def ^:private +tuple-class+ (str +prefix+ "Tuple")) -(def ^:private +function-class+ (str +prefix+ "Function")) -(def ^:private +local-prefix+ "l") -(def ^:private +partial-prefix+ "p") -(def ^:private +closure-prefix+ "c") -(def ^:private +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;") - -(def ^:private ->package ->class) - -(defn ^:private ->type-signature [class] - (case class - "void" "V" - "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" - ;; else - (let [class* (->class class)] - (if (.startsWith class* "[") - class* - (str "L" class* ";"))) - )) - -(defn ^:private ->java-sig [type] - (match type - ::&type/Any - (->type-signature "java.lang.Object") - - [::&type/Data ?name] - (->type-signature ?name) - - [::&type/Array ?elem] - (str "[" (->java-sig ?elem)) - - [::&type/variant ?tag ?value] - (->type-signature +variant-class+) - - [::&type/Lambda _ _] - (->type-signature +function-class+))) - ;; [Utils/Compilers] -(let [+class+ (->class "java.lang.Boolean") - +sig+ (->type-signature "java.lang.Boolean")] - (defn ^:private compile-bool [compile *type* ?value] - (exec [*writer* &util/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (->type-signature "java.lang.Boolean"))]] - (return nil)))) - -(do-template [<name> <class> <sig>] - (let [+class+ (->class <class>)] - (defn <name> [compile *type* ?value] - (exec [*writer* &util/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW <class>) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?literal) - (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]] - (return nil)))) - - ^:private compile-int "java.lang.Long" "(J)V" - ^:private compile-real "java.lang.Double" "(D)V" - ^:private compile-char "java.lang.Character" "(C)V" - ) - -(defn ^:private compile-text [compile *type* ?value] - (exec [*writer* &util/get-writer - :let [_ (.visitLdcInsn *writer* ?value)]] - (return nil))) - -(defn ^:private compile-tuple [compile *type* ?elems] - (exec [*writer* &util/get-writer - :let [num-elems (count ?elems) - tuple-class (->class (str +tuple-class+ num-elems)) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW tuple-class) - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))] - _ (map-m (fn [idx] - (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)] - ret (compile (nth ?elems idx)) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str +partial-prefix+ idx) "Ljava/lang/Object;")]] - (return ret))) - (range num-elems))] - (return nil))) - -(defn ^:private compile-variant [compile *type* ?tag ?members] - (exec [*writer* &util/get-writer - :let [variant-class* (str (->class +variant-class+) (count ?members)) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW variant-class*) - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?tag) - (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String")))] - _ (map-m (fn [[?tfield ?member]] - (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)] - ret (compile ?member) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* (str +partial-prefix+ ?tfield) "Ljava/lang/Object;")]] - (return ret))) - (map vector (range (count ?members)) ?members))] - (return nil))) - -(defn ^:private compile-local [compile *type* ?idx] - (exec [*writer* &util/get-writer - :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] - (return nil))) - -(defn ^:private compile-captured [compile *type* ?scope ?captured-id ?source] - (exec [*writer* &util/get-writer - :let [_ (doto *writer* - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD - (normalize-ident ?scope) - (str +closure-prefix+ ?captured-id) - "Ljava/lang/Object;"))]] - (return nil))) - -(defn ^:private compile-global [compile *type* ?owner-class ?name] - (exec [*writer* &util/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (&host/location (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]] - (return nil))) - -(defn ^:private compile-call [compile *type* ?fn ?args] - (exec [*writer* &util/get-writer - _ (compile ?fn) - _ (map-m (fn [arg] - (exec [ret (compile arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+)]] - (return ret))) - ?args)] - (return nil))) - -(defn ^:private compile-static-call [compile *type* ?needs-num ?fn ?args] - (assert false (pr-str 'compile-static-call)) - (exec [*writer* &util/get-writer - :let [_ (match (:form ?fn) - [::&analyser/global ?owner-class ?fn-name] - (let [arg-sig (->type-signature "java.lang.Object") - call-class (&host/location (list ?fn-name ?owner-class)) - provides-num (count ?args)] - (if (>= provides-num ?needs-num) - (let [impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)] - (doto *writer* - (-> (do (compile arg)) - (->> (doseq [arg (take ?needs-num ?args)]))) - (.visitMethodInsn Opcodes/INVOKESTATIC call-class "impl" impl-sig) - (-> (doto (do (compile arg)) - (.visitMethodInsn Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+)) - (->> (doseq [arg (drop ?needs-num ?args)]))))) - (let [counter-sig "I" - init-signature (str "(" (apply str counter-sig (repeat (dec ?needs-num) arg-sig)) ")" "V")] - (doto *writer* - (.visitTypeInsn Opcodes/NEW call-class) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int provides-num)) - (-> (do (compile arg)) - (->> (doseq [arg ?args]))) - (add-nulls (dec (- ?needs-num provides-num))) - (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" init-signature))) - )) - )]] - (return nil))) - -(defn ^:private compile-do [compile *type* ?exprs] - (exec [*writer* &util/get-writer - _ (map-m (fn [expr] - (exec [ret (compile expr) - :let [_ (.visitInsn *writer* Opcodes/POP)]] - (return ret))) - (butlast ?exprs)) - _ (compile (last ?exprs))] - (return nil))) - -(defn ^:private compile-field [compile *type* ?name body] - (exec [*writer* &util/get-writer - module-name &analyser/module-name - :let [outer-class (->class module-name) - datum-sig (->type-signature "java.lang.Object") - current-class (&host/location (list ?name outer-class)) - _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [(->class +function-class+)])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) - (doto (.visitEnd))))] - _ (&util/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (exec [*writer* &util/get-writer - :let [_ (.visitCode *writer*)] - _ (compile body) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd *writer*)] - _ (save-class! current-class (.toByteArray =class))] - (return nil))) - -(defn ^:private compile-def [compile *type* name value] - (match value - [::&analyser/Expression ?form _] +(defn ^:private compile-expression [syntax] + (match syntax + [::&a/Expression ?form ?type] (match ?form - [::&analyser/lambda ?scope ?captured ?args ?body] - (compile-lambda compile *type* ?scope ?closure ?args ?body true false) + [::&a/bool ?value] + (&&lux/compile-bool compile-expression ?type ?value) + + [::&a/int ?value] + (&&lux/compile-int compile-expression ?type ?value) + + [::&a/real ?value] + (&&lux/compile-real compile-expression ?type ?value) + + [::&a/char ?value] + (&&lux/compile-char compile-expression ?type ?value) + + [::&a/text ?value] + (&&lux/compile-text compile-expression ?type ?value) + + [::&a/tuple ?elems] + (&&lux/compile-tuple compile-expression ?type ?elems) + + [::&a/local ?idx] + (&&lux/compile-local compile-expression ?type ?idx) + + [::&a/captured ?scope ?captured-id ?source] + (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) + + [::&a/global ?owner-class ?name] + (&&lux/compile-global compile-expression ?type ?owner-class ?name) + + [::&a/call ?fn ?args] + (&&lux/compile-call compile-expression ?type ?fn ?args) + + [::&a/static-call ?needs-num ?fn ?args] + (&&lux/compile-static-call compile-expression ?type ?needs-num ?fn ?args) + + [::&a/variant ?tag ?members] + (&&lux/compile-variant compile-expression ?type ?tag ?members) + + [::&a/case ?variant ?base-register ?num-registers ?branches] + (&&case/compile-case compile-expression ?type ?variant ?base-register ?num-registers ?branches) + + [::&a/lambda ?scope ?frame ?args ?body] + (&&lambda/compile-lambda compile-expression ?type ?scope ?frame ?args ?body false true) + + [::&a/self ?assumed-args] + (&&lux/compile-self-call compile-expression ?assumed-args) + + ;; Integer arithmetic + [::&a/jvm-iadd ?x ?y] + (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) + + [::&a/jvm-isub ?x ?y] + (&&host/compile-jvm-isub compile-expression ?type ?x ?y) + + [::&a/jvm-imul ?x ?y] + (&&host/compile-jvm-imul compile-expression ?type ?x ?y) + + [::&a/jvm-idiv ?x ?y] + (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) + + [::&a/jvm-irem ?x ?y] + (&&host/compile-jvm-irem compile-expression ?type ?x ?y) + + ;; Long arithmetic + [::&a/jvm-ladd ?x ?y] + (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) + + [::&a/jvm-lsub ?x ?y] + (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) + + [::&a/jvm-lmul ?x ?y] + (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) + + [::&a/jvm-ldiv ?x ?y] + (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) + + [::&a/jvm-lrem ?x ?y] + (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) + + ;; Float arithmetic + [::&a/jvm-fadd ?x ?y] + (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) + + [::&a/jvm-fsub ?x ?y] + (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) + + [::&a/jvm-fmul ?x ?y] + (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) + + [::&a/jvm-fdiv ?x ?y] + (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) + + [::&a/jvm-frem ?x ?y] + (&&host/compile-jvm-frem compile-expression ?type ?x ?y) + + ;; Double arithmetic + [::&a/jvm-dadd ?x ?y] + (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) + + [::&a/jvm-dsub ?x ?y] + (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) + + [::&a/jvm-dmul ?x ?y] + (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) + + [::&a/jvm-ddiv ?x ?y] + (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) + + [::&a/jvm-drem ?x ?y] + (&&host/compile-jvm-drem compile-expression ?type ?x ?y) + + [::&a/exec ?exprs] + (&&host/compile-exec compile-expression ?type ?exprs) + + [::&a/jvm-new ?class ?classes ?args] + (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) + + [::&a/jvm-getstatic ?class ?field] + (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) + + [::&a/jvm-getfield ?class ?field ?object] + (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) + + [::&a/jvm-invokestatic ?class ?method ?classes ?args] + (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) + + [::&a/jvm-invokevirtual ?class ?method ?classes ?object ?args] + (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) + + [::&a/jvm-new-array ?class ?length] + (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) + + [::&a/jvm-aastore ?array ?idx ?elem] + (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) + + [::&a/jvm-aaload ?array ?idx] + (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) _ - (compile-field compile *type* name value)) - - _ - (fail "Can only define expressions."))) - -(defn ^:private compile-self-call [compile ?assumed-args] - (exec [*writer* &util/get-writer - :let [_ (.visitVarInsn *writer* Opcodes/ALOAD 0)] - _ (map-m (fn [arg] - (exec [ret (compile arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+)]] - (return ret))) - ?assumed-args)] - (return nil))) - -(defn ^:private compile-expression [syntax] - (match (:form syntax) - [::&analyser/bool ?value] - (compile-bool compile-expression (:type syntax) ?value) - - [::&analyser/int ?value] - (compile-int compile-expression (:type syntax) ?value) - - [::&analyser/real ?value] - (compile-real compile-expression (:type syntax) ?value) - - [::&analyser/char ?value] - (compile-char compile-expression (:type syntax) ?value) - - [::&analyser/text ?value] - (compile-text compile-expression (:type syntax) ?value) - - [::&analyser/tuple ?elems] - (compile-tuple compile-expression (:type syntax) ?elems) - - [::&analyser/local ?idx] - (compile-local compile-expression (:type syntax) ?idx) - - [::&analyser/captured ?scope ?captured-id ?source] - (compile-captured compile-expression (:type syntax) ?scope ?captured-id ?source) - - [::&analyser/global ?owner-class ?name] - (compile-global compile-expression (:type syntax) ?owner-class ?name) - - [::&analyser/call ?fn ?args] - (compile-call compile-expression (:type syntax) ?fn ?args) - - [::&analyser/static-call ?needs-num ?fn ?args] - (compile-static-call compile-expression (:type syntax) ?needs-num ?fn ?args) - - [::&analyser/variant ?tag ?members] - (compile-variant compile-expression (:type syntax) ?tag ?members) - - [::&analyser/case ?variant ?base-register ?num-registers ?branches] - (compile-case compile-expression (:type syntax) ?variant ?base-register ?num-registers ?branches) - - [::&analyser/lambda ?scope ?frame ?args ?body] - (compile-lambda compile-expression (:type syntax) ?scope ?frame ?args ?body false true) - - ;; Integer arithmetic - [::&analyser/jvm-iadd ?x ?y] - (compile-jvm-iadd compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-isub ?x ?y] - (compile-jvm-isub compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-imul ?x ?y] - (compile-jvm-imul compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-idiv ?x ?y] - (compile-jvm-idiv compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-irem ?x ?y] - (compile-jvm-irem compile-expression (:type syntax) ?x ?y) - - ;; Long arithmetic - [::&analyser/jvm-ladd ?x ?y] - (compile-jvm-ladd compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-lsub ?x ?y] - (compile-jvm-lsub compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-lmul ?x ?y] - (compile-jvm-lmul compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-ldiv ?x ?y] - (compile-jvm-ldiv compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-lrem ?x ?y] - (compile-jvm-lrem compile-expression (:type syntax) ?x ?y) - - ;; Float arithmetic - [::&analyser/jvm-fadd ?x ?y] - (compile-jvm-fadd compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-fsub ?x ?y] - (compile-jvm-fsub compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-fmul ?x ?y] - (compile-jvm-fmul compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-fdiv ?x ?y] - (compile-jvm-fdiv compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-frem ?x ?y] - (compile-jvm-frem compile-expression (:type syntax) ?x ?y) - - ;; Double arithmetic - [::&analyser/jvm-dadd ?x ?y] - (compile-jvm-dadd compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-dsub ?x ?y] - (compile-jvm-dsub compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-dmul ?x ?y] - (compile-jvm-dmul compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-ddiv ?x ?y] - (compile-jvm-ddiv compile-expression (:type syntax) ?x ?y) - - [::&analyser/jvm-drem ?x ?y] - (compile-jvm-drem compile-expression (:type syntax) ?x ?y) - - [::&analyser/do ?exprs] - (compile-do compile-expression (:type syntax) ?exprs) - - [::&analyser/jvm-new ?class ?classes ?args] - (compile-jvm-new compile-expression (:type syntax) ?class ?classes ?args) - - [::&analyser/jvm-getstatic ?class ?field] - (compile-jvm-getstatic compile-expression (:type syntax) ?class ?field) - - [::&analyser/jvm-getfield ?class ?field ?object] - (compile-jvm-getfield compile-expression (:type syntax) ?class ?field ?object) - - [::&analyser/jvm-invokestatic ?class ?method ?classes ?args] - (compile-jvm-invokestatic compile-expression (:type syntax) ?class ?method ?classes ?args) - - [::&analyser/jvm-invokevirtual ?class ?method ?classes ?object ?args] - (compile-jvm-invokevirtual compile-expression (:type syntax) ?class ?method ?classes ?object ?args) - - [::&analyser/jvm-new-array ?class ?length] - (compile-jvm-new-array compile-expression (:type syntax) ?class ?length) - - [::&analyser/jvm-aastore ?array ?idx ?elem] - (compile-jvm-aastore compile-expression (:type syntax) ?array ?idx ?elem) - - [::&analyser/jvm-aaload ?array ?idx] - (compile-jvm-aaload compile-expression (:type syntax) ?array ?idx) - - [::&analyser/self ?assumed-args] - (compile-self-call compile-expression ?assumed-args) - - _ - (fail "[Compiler Error] Can't compile expressions as top-level forms.") - )) + (fail "[Compiler Error] Can't compile expressions as top-level forms.") + ))) (defn ^:private compile-statement [syntax] - (match (:form syntax) - [::&analyser/def ?form ?body] - (compile-def compile-expression (:type syntax) ?form ?body) - - [::&analyser/jvm-interface [?package ?name] ?members] - (compile-jvm-interface compile-expression (:type syntax) ?package ?name ?members) + (match syntax + [::&a/Expression ?form ?type] + (match ?form + [::&a/def ?form ?body] + (&&lux/compile-def compile-expression ?type ?form ?body) + + [::&a/jvm-interface [?package ?name] ?members] + (&&host/compile-jvm-interface compile-expression ?type ?package ?name ?members) - [::&analyser/jvm-class [?package ?name] ?super-class ?members] - (compile-jvm-class compile-expression (:type syntax) ?package ?name ?super-class ?members) + [::&a/jvm-class [?package ?name] ?super-class ?members] + (&&host/compile-jvm-class compile-expression ?type ?package ?name ?super-class ?members) - _ - (fail "[Compiler Error] Can't compile expressions as top-level forms.") - )) + _ + (fail "[Compiler Error] Can't compile expressions as top-level forms.") + ))) -;; [Interface] (let [compiler-step (exec [analysis+ &analyser/analyse] (map-m compile-statement analysis+))] - (defn compile-module [name] + (defn ^:private compile-module [name] (exec [loader &util/loader] (fn [state] (if (-> state ::&util/modules (contains? name)) (fail "[Compiler Error] Can't redefine a module!") (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (->class name) nil "java/lang/Object" nil))] + (&host/->class name) nil "java/lang/Object" nil))] (match (&util/run-state (exhaust-m compiler-step) (assoc state ::&util/source (slurp (str "source/" name ".lux")) ::&util/current-module name ::&util/writer =class)) [::&util/ok [?state _]] (do (.visitEnd =class) - (&util/run-state (save-class! name (.toByteArray =class)) ?state)) + (&util/run-state (&&/save-class! name (.toByteArray =class)) ?state)) [::&util/failure ?message] (fail* ?message)))))))) +;; [Resources] (defn compile-all [modules] (.mkdir (java.io.File. "output")) (match (&util/run-state (map-m compile-module modules) (&util/init-state)) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj new file mode 100644 index 000000000..7896902be --- /dev/null +++ b/src/lux/compiler/base.clj @@ -0,0 +1,36 @@ +(ns lux.compiler.base + (:require [clojure.string :as string] + (lux [util :as &util :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + apply-m + normalize-ident]])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Resources] +(def local-prefix "l") +(def partial-prefix "p") +(def closure-prefix "c") +(def apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") + +(defn add-nulls [writer amount] + (dotimes [_ amount] + (.visitInsn writer Opcodes/ACONST_NULL))) + +(defn write-file [file data] + (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] + (.write stream data))) + +(defn write-class [name data] + (write-file (str "output/" name ".class") data)) + +(defn load-class! [loader name] + (.loadClass loader name)) + +(defn save-class! [name bytecode] + (exec [loader &util/loader + :let [_ (write-class name bytecode) + _ (load-class! loader (string/replace name #"/" "."))]] + (return nil))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 8f35ec2c0..a6a181a6d 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -1,101 +1,23 @@ - -(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))) - )) - +(ns lux.compiler.case + (:require (clojure [set :as set] + [template :refer [do-template]]) + [clojure.core.match :refer [match]] + (lux [util :as &util :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + apply-m + normalize-ident]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host]) + [lux.compiler.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] (defn ^:private map-branches [idx mappings patterns] (reduce (fn [[idx mappings patterns*] [test body]] [(inc idx) @@ -177,7 +99,7 @@ (doseq [[?token $body] ?patterns :let [$else (new Label)]] (doto writer - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <wrapper-class>) <value-method> <method-sig>) (.visitLdcInsn ?token) (.visitJumpInsn Opcodes/IF_ICMPNE $else) (.visitInsn Opcodes/POP) @@ -196,7 +118,7 @@ (doseq [[?token $body] ?patterns :let [$else (new Label)]] (doto writer - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class <wrapper-class>) <value-method> <method-sig>) (.visitLdcInsn ?token) (.visitInsn <cmp-op>) (.visitJumpInsn Opcodes/IFNE $else) @@ -217,7 +139,7 @@ (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?token) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Object") "equals" (str "(" (->type-signature "java.lang.Object") ")Z")) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z")) (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO (get mappings $body)) @@ -232,19 +154,117 @@ [(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)] + ;; 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] +(let [+tag-sig+ (&host/->type-signature "java.lang.String") + variant-class* (&host/->class &host/variant-class) + tuple-class* (&host/->class &host/tuple-class) + +variant-field-sig+ (&host/->type-signature "java.lang.Object") + oclass (&host/->class "java.lang.Object") + equals-sig (str "(" (&host/->type-signature "java.lang.Object") ")Z")] + (defn ^:private compile-decision-tree [writer mappings default-label decision-tree] + (match decision-tree + [::test-bool ?pairs] + (compile-bool-pm writer mappings default-label ?pairs) + + [::test-int ?pairs] + (compile-int-pm writer mappings default-label ?pairs) + + [::test-real ?pairs] + (compile-real-pm writer mappings default-label ?pairs) + + [::test-char ?pairs] + (compile-char-pm writer mappings default-label ?pairs) + + [::test-text ?pairs] + (compile-text-pm 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 compile-pm [writer mapping pm-struct $default] (match pm-struct [::BoolPM ?patterns ?defaults] (compile-bool-pm writer mapping $default ?patterns) @@ -310,8 +330,8 @@ [::&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)))] + (exec [_ (&util/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] @@ -326,8 +346,8 @@ (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))] + (exec [_ (&util/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])) @@ -344,8 +364,8 @@ (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))] + (exec [_ (&util/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])) @@ -412,9 +432,9 @@ (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)]) + (let [curr-paths (set/intersection prev-paths (valid-paths head))] + (for [[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)))) @@ -444,11 +464,12 @@ ) (defn ^:private sequence-? [group] - [::?PM ([[default-register $body] & _] :seq)] - (return (list [<test> default-register #{$body}])) + (match group + [::?PM ([[default-register $body] & _] :seq)] + (return (list [::test-store default-register #{$body}])) - :else - (fail "")) + :else + (fail ""))) (defn ^:private sequence-pm [group] (match group @@ -482,14 +503,15 @@ (return (cons [::test-tuple ?num-elems sub-seqs] (match ?defaults ([[default-register $body] & _] :seq) - (list [<test> default-register #{$body}]) + (list [::test-store default-register #{$body}]) :else (list))))) [::VariantPM ?tags ?patterns ?defaults] (map-m (fn [tag] - (exec [:let [members+bodies (mapcat (fn [[ptag pmembers pbody]] + (exec [:let [?num-elems (get ?tags tag) + members+bodies (mapcat (fn [[ptag pmembers pbody]] (if (= ptag tag) (list [pmembers pbody]) (list))) @@ -505,7 +527,7 @@ (cons [::test-variant tag ?num-elems sub-seqs] (match ?defaults ([[default-register $body] & _] :seq) - (list [<test> default-register #{$body}]) + (list [::test-store default-register #{$body}]) :else (list))))) @@ -518,51 +540,53 @@ 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] +;; [Resources] +(let [ex-class (&host/->class "java.lang.IllegalStateException")] + (defn 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)))] + (.visitLocalVariable *writer* (str &&/local-prefix idx) (&host/->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)]] + ;; :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 index dfe67eece..0a11decb4 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -1,18 +1,40 @@ - -(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"]}] +(ns lux.compiler.host + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + [clojure.core.match :refer [match]] + (lux [util :as &util :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + apply-m + normalize-ident]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host]) + [lux.analyser.base :as &a] + [lux.compiler.base :as &&] + :reload) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(let [class+method+sig {"boolean" [(&host/->class "java.lang.Boolean") "booleanValue" "()Z"] + "byte" [(&host/->class "java.lang.Byte") "byteValue" "()B"] + "short" [(&host/->class "java.lang.Short") "shortValue" "()S"] + "int" [(&host/->class "java.lang.Integer") "intValue" "()I"] + "long" [(&host/->class "java.lang.Long") "longValue" "()J"] + "float" [(&host/->class "java.lang.Float") "floatValue" "()F"] + "double" [(&host/->class "java.lang.Double") "doubleValue" "()D"] + "char" [(&host/->class "java.lang.Character") "charValue" "()C"]}] (defn ^:private prepare-arg! [*writer* class-name] - (if-let [[class method sig] (get class+metthod+sig class-name)] + (if-let [[class method sig] (get class+method+sig class-name)] (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST class) (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) - (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name))))) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class class-name))))) ;; (let [boolean-class "java.lang.Boolean" ;; integer-class "java.lang.Integer" @@ -23,50 +45,50 @@ ;; (.visitInsn *writer* Opcodes/ACONST_NULL) ;; [::&type/primitive "char"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class))) +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) ;; [::&type/primitive "int"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class))) +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class integer-class) "valueOf" (str "(I)" (&host/->type-signature integer-class))) ;; [::&type/primitive "boolean"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class))) +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) ;; [::&type/Data ?oclass] ;; nil))) - -(defn ^:private compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] +;; [Resources] +(defn 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*))] + :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->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) + :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) ;; (prepare-return! *writer* *type*) )]] (return nil))) -(defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args] +(defn 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*))] + :let [method-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->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) + :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (&host/->class ?class) ?method method-sig) ;; (prepare-return! *writer* *type*) )]] (return nil))) -(defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args] +(defn 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) + :let [init-sig (str "(" (reduce str "" (map &host/->type-signature ?classes)) ")V") + class* (&host/->class ?class) _ (doto *writer* (.visitTypeInsn Opcodes/NEW class*) (.visitInsn Opcodes/DUP))] @@ -79,14 +101,14 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] (return nil))) -(defn ^:private compile-jvm-new-array [compile *type* ?class ?length] +(defn compile-jvm-new-array [compile *type* ?class ?length] (exec [*writer* &util/get-writer :let [_ (doto *writer* (.visitLdcInsn (int ?length)) - (.visitTypeInsn Opcodes/ANEWARRAY (->class ?class)))]] + (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] (return nil))) -(defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem] +(defn compile-jvm-aastore [compile *type* ?array ?idx ?elem] (exec [*writer* &util/get-writer _ (compile ?array) :let [_ (doto *writer* @@ -96,7 +118,7 @@ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn ^:private compile-jvm-aaload [compile *type* ?array ?idx] +(defn compile-jvm-aaload [compile *type* ?array ?idx] (exec [*writer* &util/get-writer _ (compile ?array) :let [_ (doto *writer* @@ -104,27 +126,27 @@ (.visitInsn Opcodes/AALOAD))]] (return nil))) -(defn ^:private compile-jvm-getstatic [compile *type* ?class ?field] +(defn compile-jvm-getstatic [compile *type* ?class ?field] (exec [*writer* &util/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?class) ?field (->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] (return nil))) -(defn ^:private compile-jvm-getfield [compile *type* ?class ?field ?object] +(defn 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*))]] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] + :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] (return nil))) -(defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods] - (let [parent-dir (->package ?package) +(defn compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods] + (let [parent-dir (&host/->package ?package) full-name (str parent-dir "/" ?name) - super-class* (->class ?super-class) + super-class* (&host/->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) + (doto (.visitField =class Opcodes/ACC_PUBLIC field (&host/->type-signature (:type props)) nil nil) (.visitEnd))) (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil) (.visitCode) @@ -135,25 +157,25 @@ (.visitEnd)) (.visitEnd =class) (.mkdirs (java.io.File. (str "output/" parent-dir))))] - (save-class! full-name (.toByteArray =class)))) + (&&/save-class! full-name (.toByteArray =class)))) -(defn ^:private compile-jvm-interface [compile *type* ?package ?name ?fields ?methods] - (let [parent-dir (->package ?package) +(defn compile-jvm-interface [compile *type* ?package ?name ?fields ?methods] + (let [parent-dir (&host/->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))]] + signature (str "(" (reduce str "" (map &host/->type-signature ?args)) ")" (&host/->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)))) + (&&/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>)] + (exec [:let [+wrapper-class+ (&host/->class <wrapper-class>)] *writer* &util/get-writer _ (compile ?x) :let [_ (doto *writer* @@ -165,30 +187,40 @@ (.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>))))]] + (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (&host/->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)" + compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + 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)" + compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + + compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + 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)" + compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" ) + +(defn compile-exec [compile *type* ?exprs] + (exec [*writer* &util/get-writer + _ (map-m (fn [expr] + (exec [ret (compile expr) + :let [_ (.visitInsn *writer* Opcodes/POP)]] + (return ret))) + (butlast ?exprs)) + _ (compile (last ?exprs))] + (return nil))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index b3bfc4860..d0588e073 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -1,11 +1,30 @@ -(ns lux.compiler.lambda) +(ns lux.compiler.lambda + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + [clojure.core.match :refer [match]] + (lux [util :as &util :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + normalize-ident]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host]) + [lux.analyser.base :as &a] + (lux.compiler [base :as &&]) + :reload) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) ;; [Utils] -(def ^:private clo-field-sig (->type-signature "java.lang.Object")) -(def ^:private lambda-return-sig (->type-signature "java.lang.Object")) +(def ^:private clo-field-sig (&host/->type-signature "java.lang.Object")) +(def ^:private lambda-return-sig (&host/->type-signature "java.lang.Object")) (def ^:private <init>-return "V") (def ^:private counter-sig "I") -(def ^:private +datum-sig+ (->type-signature "java.lang.Object")) +(def ^:private +datum-sig+ (&host/->type-signature "java.lang.Object")) (defn ^:private lambda-impl-signature [args] (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig)) @@ -28,7 +47,7 @@ (-> (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)]) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (match (:form ?captured) [::&analyser/captured ?closure-id ?captured-id ?source]) (doseq [[?name ?captured] closed-over]))) @@ -38,7 +57,7 @@ (-> (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)] + (->> (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)]) @@ -55,21 +74,17 @@ (.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+ + ^: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) + (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) @@ -81,7 +96,7 @@ (.visitLdcInsn (int current-captured)) (add-partial-vars class-name (take current-captured args)) (.visitVarInsn Opcodes/ALOAD 1) - (add-nulls (- (dec num-captured) current-captured)) + (&&/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)))]))) @@ -126,7 +141,7 @@ :let [num-args (count args) _ (do (when (> num-args 1) (.visitInsn *writer* Opcodes/ICONST_0) - (add-nulls *writer* (dec num-args))) + (&&/add-nulls *writer* (dec num-args))) (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature))]] (return nil))) @@ -136,8 +151,8 @@ (.visitCode) (.visitTypeInsn Opcodes/NEW class-name) (.visitInsn Opcodes/DUP) - (-> (doto (.visitInsn *writer* Opcodes/ICONST_0) - (add-nulls (dec num-args))) + (-> (doto (.visitInsn 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+) @@ -152,10 +167,10 @@ <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+)])) + lambda-class nil "java/lang/Object" (into-array [(&host/->class &host/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)]) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (match (:form ?captured) [::&analyser/captured ?closure-id ?captured-id ?source]) (doseq [[?name ?captured] ?closure]))) @@ -170,7 +185,7 @@ )] _ (add-lambda-impl =class compile impl-signature ?body) :let [_ (.visitEnd =class)] - _ (save-class! lambda-class (.toByteArray =class))] + _ (&&/save-class! lambda-class (.toByteArray =class))] (if instance? (instance-closure compile lambda-class ?closure ?args <init>-sig) (return nil)))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj new file mode 100644 index 000000000..ebf376e39 --- /dev/null +++ b/src/lux/compiler/lux.clj @@ -0,0 +1,196 @@ +(ns lux.compiler.lux + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + [clojure.core.match :refer [match]] + (lux [util :as &util :refer [exec return* return fail fail* + repeat-m exhaust-m try-m try-all-m map-m reduce-m + apply-m + normalize-ident]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host]) + [lux.analyser.base :as &a] + (lux.compiler [base :as &&] + [lambda :as &&lambda]) + :reload) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(defn ^:private compile-field [compile *type* ?name body] + (exec [*writer* &util/get-writer + module-name &util/get-module-name + :let [outer-class (&host/->class module-name) + datum-sig (&host/->type-signature "java.lang.Object") + current-class (&host/location (list ?name outer-class)) + _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + current-class nil "java/lang/Object" (into-array [(&host/->class &host/function-class)])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) + (doto (.visitEnd))))] + _ (&util/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + (exec [*writer* &util/get-writer + :let [_ (.visitCode *writer*)] + _ (compile body) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (&&/save-class! current-class (.toByteArray =class))] + (return nil))) + +;; [Resources] +(let [+class+ (&host/->class "java.lang.Boolean") + +sig+ (&host/->type-signature "java.lang.Boolean")] + (defn compile-bool [compile *type* ?value] + (exec [*writer* &util/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") (if ?value "TRUE" "FALSE") (&host/->type-signature "java.lang.Boolean"))]] + (return nil)))) + +(do-template [<name> <class> <sig>] + (let [+class+ (&host/->class <class>)] + (defn <name> [compile *type* value] + (exec [*writer* &util/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW <class>) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn value) + (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]] + (return nil)))) + + compile-int "java.lang.Long" "(J)V" + compile-real "java.lang.Double" "(D)V" + compile-char "java.lang.Character" "(C)V" + ) + +(defn compile-text [compile *type* ?value] + (exec [*writer* &util/get-writer + :let [_ (.visitLdcInsn *writer* ?value)]] + (return nil))) + +(defn compile-tuple [compile *type* ?elems] + (exec [*writer* &util/get-writer + :let [num-elems (count ?elems) + tuple-class (&host/->class (str &host/tuple-class num-elems)) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW tuple-class) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL tuple-class "<init>" "()V"))] + _ (map-m (fn [idx] + (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)] + ret (compile (nth ?elems idx)) + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str &&/partial-prefix idx) "Ljava/lang/Object;")]] + (return ret))) + (range num-elems))] + (return nil))) + +(defn compile-variant [compile *type* ?tag ?members] + (exec [*writer* &util/get-writer + :let [variant-class* (str (&host/->class &host/variant-class) (count ?members)) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW variant-class*) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "<init>" "()V") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?tag) + (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (&host/->type-signature "java.lang.String")))] + _ (map-m (fn [[?tfield ?member]] + (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)] + ret (compile ?member) + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* (str &&/partial-prefix ?tfield) "Ljava/lang/Object;")]] + (return ret))) + (map vector (range (count ?members)) ?members))] + (return nil))) + +(defn compile-local [compile *type* ?idx] + (exec [*writer* &util/get-writer + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] + (return nil))) + +(defn compile-captured [compile *type* ?scope ?captured-id ?source] + (exec [*writer* &util/get-writer + :let [_ (doto *writer* + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD + (normalize-ident ?scope) + (str &&/closure-prefix ?captured-id) + "Ljava/lang/Object;"))]] + (return nil))) + +(defn compile-global [compile *type* ?owner-class ?name] + (exec [*writer* &util/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (&host/->class (&host/location (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]] + (return nil))) + +(defn compile-call [compile *type* ?fn ?args] + (exec [*writer* &util/get-writer + _ (compile ?fn) + _ (map-m (fn [arg] + (exec [ret (compile arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]] + (return ret))) + ?args)] + (return nil))) + +(defn compile-static-call [compile *type* ?needs-num ?fn ?args] + (assert false (pr-str 'compile-static-call)) + (exec [*writer* &util/get-writer + :let [_ (match (:form ?fn) + [::&a/global ?owner-class ?fn-name] + (let [arg-sig (&host/->type-signature "java.lang.Object") + call-class (&host/location (list ?fn-name ?owner-class)) + provides-num (count ?args)] + (if (>= provides-num ?needs-num) + (let [impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)] + (doto *writer* + (-> (do (compile arg)) + (->> (doseq [arg (take ?needs-num ?args)]))) + (.visitMethodInsn Opcodes/INVOKESTATIC call-class "impl" impl-sig) + (-> (doto (do (compile arg)) + (.visitMethodInsn Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)) + (->> (doseq [arg (drop ?needs-num ?args)]))))) + (let [counter-sig "I" + init-signature (str "(" (apply str counter-sig (repeat (dec ?needs-num) arg-sig)) ")" "V")] + (doto *writer* + (.visitTypeInsn Opcodes/NEW call-class) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int provides-num)) + (-> (do (compile arg)) + (->> (doseq [arg ?args]))) + (&&/add-nulls (dec (- ?needs-num provides-num))) + (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" init-signature))) + )) + )]] + (return nil))) + +(defn compile-def [compile *type* name value] + (match value + [::&a/Expression ?form _] + (match ?form + [::&a/lambda ?scope ?captured ?args ?body] + (&&lambda/compile-lambda compile *type* ?scope ?captured ?args ?body true false) + + _ + (compile-field compile *type* name value)) + + _ + (fail "Can only define expressions."))) + +(defn compile-self-call [compile ?assumed-args] + (exec [*writer* &util/get-writer + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD 0)] + _ (map-m (fn [arg] + (exec [ret (compile arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]] + (return ret))) + ?assumed-args)] + (return nil))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 56a29b093..b21ed03dc 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -8,6 +8,12 @@ [parser :as &parser] [type :as &type]))) +;; [Constants] +(def prefix "lux.") +(def variant-class (str prefix "Variant")) +(def tuple-class (str prefix "Tuple")) +(def function-class (str prefix "Function")) + ;; [Utils] (defn ^:private class->type [class] (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" @@ -54,6 +60,40 @@ (defn ->class [class] (string/replace class #"\." "/")) +(def ->package ->class) + +(defn ->type-signature [class] + (case class + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ;; else + (let [class* (->class class)] + (if (.startsWith class* "[") + class* + (str "L" class* ";"))) + )) + +(defn ->java-sig [type] + (match type + ::&type/Any + (->type-signature "java.lang.Object") + + [::&type/Data ?name] + (->type-signature ?name) + + [::&type/Array ?elem] + (str "[" (->java-sig ?elem)) + + [::&type/Lambda _ _] + (->type-signature function-class))) + (defn extract-jvm-param [token] (match token [::&parser/ident ?ident] |