diff options
Diffstat (limited to '')
| -rw-r--r-- | src/lux/analyser.clj | 47 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 5 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 207 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 15 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 292 | ||||
| -rw-r--r-- | src/lux/optimizer.clj | 20 |
6 files changed, 260 insertions, 326 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index ad96cdd9b..f2c238833 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -117,53 +117,6 @@ (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TupleS ?arg-classes)] - (&/$Cons [_ (&/$TupleS ?args)] - (&/$Nil)))))) - (|do [=arg-classes (&/map% &&a-parser/parse-text ?arg-classes)] - (&&host/analyse-jvm-new analyse exo-type ?class =arg-classes ?args)) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?arg-classes)] - (&/$Cons [_ (&/$TupleS ?args)] - (&/$Nil))))))) - (|do [=arg-classes (&/map% &&a-parser/parse-text ?arg-classes)] - (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method =arg-classes ?args)) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?arg-classes)] - (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] - (&/$Nil)))))))) - (|do [=arg-classes (&/map% &&a-parser/parse-text ?arg-classes)] - (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method =arg-classes ?object ?args)) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?arg-classes)] - (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] - (&/$Nil)))))))) - (|do [=arg-classes (&/map% &&a-parser/parse-text ?arg-classes)] - (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method =arg-classes ?object ?args)) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?arg-classes)] - (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] - (&/$Nil)))))))) - (|do [=arg-classes (&/map% &&a-parser/parse-text ?arg-classes)] - (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method =arg-classes ?object ?args)) - ;; Exceptions (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 42bbcf284..9f53e6843 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -27,12 +27,7 @@ ("captured" 1) ("host" 2) - ("jvm-invokestatic" 1) ("jvm-instanceof" 1) - ("jvm-invokevirtual" 1) - ("jvm-invokeinterface" 1) - ("jvm-invokespecial" 1) - ("jvm-new" 1) ("jvm-class" 1) ("jvm-interface" 1) ("jvm-try" 1) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index c82a71566..1bee0739c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -170,98 +170,6 @@ (return (&/|list (&&/|meta output-type _cursor (&&/$jvm-instanceof (&/T [class =object]))))))) -(defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =arg-types (&/map% &type/show-type+ arg-types) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - =gret (&host-type/instance-param &type/existential gtype-env gret)] - (return (&/T [=gret =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-method-call-helper analyse gret gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(let [dummy-type-param (&/$DataT "java.lang.Object" &/$Nil)] - (do-template [<name> <tag> <only-interface?>] - (defn <name> [analyse exo-type class method classes object args] - (|do [class-loader &/loader - _ (try (assert! (let [=class (Class/forName class true class-loader)] - (= <only-interface?> (.isInterface =class))) - (if <only-interface?> - (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") - (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) - (catch Exception e - (fail (str "[Analyser Error] Unknown class: " class)))) - [gret exceptions parent-gvars gvars gargs] (if (= "<init>" method) - (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) - (&host/lookup-virtual-method class-loader class method classes)) - _ (ensure-catching exceptions) - =object (&&/analyse-1+ analyse object) - [sub-class sub-params] (ensure-object (&&/expr-type* =object)) - (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params) - :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - parent-gvars - super-params*)] - [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) - _ (&type/check exo-type (as-otype+ output-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (<tag> (&/T [class method classes =object =args output-type]))))))) - - analyse-jvm-invokevirtual &&/$jvm-invokevirtual false - analyse-jvm-invokespecial &&/$jvm-invokespecial false - analyse-jvm-invokeinterface &&/$jvm-invokeinterface true - )) - -(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] - (|do [class-loader &/loader - [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) - _ (ensure-catching exceptions) - :let [gtype-env (&/|table)] - [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) - _ (&type/check exo-type (as-otype+ output-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$jvm-invokestatic (&/T [class method classes =args output-type]))))))) - -(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] - (return (&/T [(make-gtype gtype gtype-vars*) - =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(defn analyse-jvm-new [analyse exo-type class classes args] - (|do [class-loader &/loader - [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) - _ (ensure-catching exceptions) - [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$jvm-new (&/T [class classes =args]))))))) - (defn generic-class->simple-class [gclass] "(-> GenericClass Text)" (|case gclass @@ -589,7 +497,7 @@ _ (compile-statement (&&/$jvm-class (&/T [class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)]))) _cursor &/cursor] (return (&/|list (&&/|meta anon-class-type _cursor - (&&/$jvm-new (&/T [anon-class (&/|repeat (&/|length sources) captured-slot-class) sources])) + (&&/$host (&/T ["jvm" "new"]) (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class) sources)) ))) )))) @@ -923,6 +831,101 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$host (&/T ["jvm" "putfield"]) (&/|list class field =object =value gclass =type))))))) +(defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =arg-types (&/map% &type/show-type+ arg-types) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret)] + (return (&/T [=gret =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-method-call-helper analyse gret gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(let [dummy-type-param (&/$DataT "java.lang.Object" &/$Nil)] + (do-template [<name> <tag> <only-interface?>] + (defn <name> [analyse exo-type class method classes ?values] + (|do [:let [(&/$Cons object args) ?values] + class-loader &/loader + _ (try (assert! (let [=class (Class/forName class true class-loader)] + (= <only-interface?> (.isInterface =class))) + (if <only-interface?> + (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") + (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) + (catch Exception e + (fail (str "[Analyser Error] Unknown class: " class)))) + [gret exceptions parent-gvars gvars gargs] (if (= "<init>" method) + (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) + (&host/lookup-virtual-method class-loader class method classes)) + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params) + :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$host (&/T ["jvm" <tag>]) (&/|list class method classes =object =args output-type))))))) + + ^:private analyse-jvm-invokevirtual "invokevirtual" false + ^:private analyse-jvm-invokespecial "invokespecial" false + ^:private analyse-jvm-invokeinterface "invokeinterface" true + )) + +(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] + (|do [:let [args ?values] + class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) + _ (ensure-catching exceptions) + :let [gtype-env (&/|table)] + [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$host (&/T ["jvm" "invokestatic"]) (&/|list class method classes =args output-type))))))) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T [(make-gtype gtype gtype-vars*) + =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] + (|do [:let [args ?values] + class-loader &/loader + [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) + _ (ensure-catching exceptions) + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$host (&/T ["jvm" "new"]) (&/|list class classes =args))))))) + (defn analyse-host [analyse exo-type category proc ?values] (case category "jvm" @@ -1012,13 +1015,23 @@ "c2l" (analyse-jvm-c2l analyse exo-type ?values) ;; else (->> (fail (str "[Analyser Error] Unknown host procedure: " [category proc])) - (if-let [[_ _class _field] (re-find #"getstatic:([^:]+):([^:]+)" proc)] + (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - (if-let [[_ _class _field] (re-find #"getfield:([^:]+):([^:]+)" proc)] + (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] (analyse-jvm-getfield analyse exo-type _class _field ?values)) - (if-let [[_ _class _field] (re-find #"putstatic:([^:]+):([^:]+)" proc)] + (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - (if-let [[_ _class _field] (re-find #"putfield:([^:]+):([^:]+)" proc)] + (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] (analyse-jvm-putfield analyse exo-type _class _field ?values)))) ;; else diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 57ded26fe..1015fdf9f 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -95,21 +95,6 @@ (&&host/compile-host compile-expression ?proc-category ?proc-name ?args) ;; JVM - (&o/$jvm-new ?class ?classes ?args) - (&&host/compile-jvm-new compile-expression ?class ?classes ?args) - - (&o/$jvm-invokestatic ?class ?method ?classes ?args ?output-type) - (&&host/compile-jvm-invokestatic compile-expression ?class ?method ?classes ?args ?output-type) - - (&o/$jvm-invokevirtual ?class ?method ?classes ?object ?args ?output-type) - (&&host/compile-jvm-invokevirtual compile-expression ?class ?method ?classes ?object ?args ?output-type) - - (&o/$jvm-invokeinterface ?class ?method ?classes ?object ?args ?output-type) - (&&host/compile-jvm-invokeinterface compile-expression ?class ?method ?classes ?object ?args ?output-type) - - (&o/$jvm-invokespecial ?class ?method ?classes ?object ?args ?output-type) - (&&host/compile-jvm-invokespecial compile-expression ?class ?method ?classes ?object ?args ?output-type) - (&o/$jvm-try ?body ?catches ?finally) (&&host/compile-jvm-try compile-expression ?body ?catches ?finally) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index c63587347..1178199c8 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -94,61 +94,6 @@ *writer*)) ;; [Resources] -(defn compile-jvm-invokestatic [compile ?class ?method ?classes ?args ?output-type] - (|do [^MethodVisitor *writer* &/get-writer - =output-type (&host/->java-sig ?output-type) - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - -(do-template [<name> <op>] - (defn <name> [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - =output-type (&host/->java-sig ?output-type) - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)] - _ (compile ?object) - :let [_ (when (not= "<init>" ?method) - (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn <op> ?class* ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - - compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL - compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - compile-jvm-invokespecial Opcodes/INVOKESPECIAL - ) - -(defn compile-jvm-new [compile ?class ?classes ?args] - (|do [^MethodVisitor *writer* &/get-writer - :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") - class* (&host-generics/->bytecode-class-name ?class) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW class*) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [class-name+arg] - (|do [:let [[class-name arg] class-name+arg] - ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (&/zip2 ?classes ?args)) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] - (return nil))) - (defn compile-jvm-instanceof [compile class object] (|do [:let [class* (&host-generics/->bytecode-class-name class)] ^MethodVisitor *writer* &/get-writer @@ -1220,97 +1165,160 @@ (.visitInsn Opcodes/ACONST_NULL))]] (return nil))) +(defn ^:private compile-jvm-invokestatic [compile ?values] + (|do [:let [(&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?args (&/$Cons ?output-type (&/$Nil)))))) ?values] + ^MethodVisitor *writer* &/get-writer + =output-type (&host/->java-sig ?output-type) + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + +(do-template [<name> <op>] + (defn <name> [compile ?values] + (|do [:let [(&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?object (&/$Cons ?args (&/$Cons ?output-type (&/$Nil))))))) ?values] + :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + =output-type (&host/->java-sig ?output-type) + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)] + _ (compile ?object) + :let [_ (when (not= "<init>" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn <op> ?class* ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + + ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL + ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE + ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ) + +(defn ^:private compile-jvm-new [compile ?values] + (|do [:let [(&/$Cons ?class (&/$Cons ?classes (&/$Cons ?args (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") + class* (&host-generics/->bytecode-class-name ?class) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW class*) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [class-name+arg] + (|do [:let [[class-name arg] class-name+arg] + ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (&/zip2 ?classes ?args)) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] + (return nil))) + (defn compile-host [compile proc-category proc-name ?values] (case proc-category "jvm" (case proc-name - "getstatic" (compile-jvm-getstatic compile ?values) - "getfield" (compile-jvm-getfield compile ?values) - "putstatic" (compile-jvm-putstatic compile ?values) - "putfield" (compile-jvm-putfield compile ?values) - "throw" (compile-jvm-throw compile ?values) - "monitorenter" (compile-jvm-monitorenter compile ?values) - "monitorexit" (compile-jvm-monitorexit compile ?values) - "null?" (compile-jvm-null? compile ?values) - "null" (compile-jvm-null compile ?values) - "anewarray" (compile-jvm-anewarray compile ?values) - "aaload" (compile-jvm-aaload compile ?values) - "aastore" (compile-jvm-aastore compile ?values) - "arraylength" (compile-jvm-arraylength compile ?values) - "znewarray" (compile-jvm-znewarray compile ?values) - "bnewarray" (compile-jvm-bnewarray compile ?values) - "snewarray" (compile-jvm-snewarray compile ?values) - "inewarray" (compile-jvm-inewarray compile ?values) - "lnewarray" (compile-jvm-lnewarray compile ?values) - "fnewarray" (compile-jvm-fnewarray compile ?values) - "dnewarray" (compile-jvm-dnewarray compile ?values) - "cnewarray" (compile-jvm-cnewarray compile ?values) - "iadd" (compile-jvm-iadd compile ?values) - "isub" (compile-jvm-isub compile ?values) - "imul" (compile-jvm-imul compile ?values) - "idiv" (compile-jvm-idiv compile ?values) - "irem" (compile-jvm-irem compile ?values) - "ieq" (compile-jvm-ieq compile ?values) - "ilt" (compile-jvm-ilt compile ?values) - "igt" (compile-jvm-igt compile ?values) - "ceq" (compile-jvm-ceq compile ?values) - "clt" (compile-jvm-clt compile ?values) - "cgt" (compile-jvm-cgt compile ?values) - "ladd" (compile-jvm-ladd compile ?values) - "lsub" (compile-jvm-lsub compile ?values) - "lmul" (compile-jvm-lmul compile ?values) - "ldiv" (compile-jvm-ldiv compile ?values) - "lrem" (compile-jvm-lrem compile ?values) - "leq" (compile-jvm-leq compile ?values) - "llt" (compile-jvm-llt compile ?values) - "lgt" (compile-jvm-lgt compile ?values) - "fadd" (compile-jvm-fadd compile ?values) - "fsub" (compile-jvm-fsub compile ?values) - "fmul" (compile-jvm-fmul compile ?values) - "fdiv" (compile-jvm-fdiv compile ?values) - "frem" (compile-jvm-frem compile ?values) - "feq" (compile-jvm-feq compile ?values) - "flt" (compile-jvm-flt compile ?values) - "fgt" (compile-jvm-fgt compile ?values) - "dadd" (compile-jvm-dadd compile ?values) - "dsub" (compile-jvm-dsub compile ?values) - "dmul" (compile-jvm-dmul compile ?values) - "ddiv" (compile-jvm-ddiv compile ?values) - "drem" (compile-jvm-drem compile ?values) - "deq" (compile-jvm-deq compile ?values) - "dlt" (compile-jvm-dlt compile ?values) - "dgt" (compile-jvm-dgt compile ?values) - "iand" (compile-jvm-iand compile ?values) - "ior" (compile-jvm-ior compile ?values) - "ixor" (compile-jvm-ixor compile ?values) - "ishl" (compile-jvm-ishl compile ?values) - "ishr" (compile-jvm-ishr compile ?values) - "iushr" (compile-jvm-iushr compile ?values) - "land" (compile-jvm-land compile ?values) - "lor" (compile-jvm-lor compile ?values) - "lxor" (compile-jvm-lxor compile ?values) - "lshl" (compile-jvm-lshl compile ?values) - "lshr" (compile-jvm-lshr compile ?values) - "lushr" (compile-jvm-lushr compile ?values) - "d2f" (compile-jvm-d2f compile ?values) - "d2i" (compile-jvm-d2i compile ?values) - "d2l" (compile-jvm-d2l compile ?values) - "f2d" (compile-jvm-f2d compile ?values) - "f2i" (compile-jvm-f2i compile ?values) - "f2l" (compile-jvm-f2l compile ?values) - "i2b" (compile-jvm-i2b compile ?values) - "i2c" (compile-jvm-i2c compile ?values) - "i2d" (compile-jvm-i2d compile ?values) - "i2f" (compile-jvm-i2f compile ?values) - "i2l" (compile-jvm-i2l compile ?values) - "i2s" (compile-jvm-i2s compile ?values) - "l2d" (compile-jvm-l2d compile ?values) - "l2f" (compile-jvm-l2f compile ?values) - "l2i" (compile-jvm-l2i compile ?values) - "c2b" (compile-jvm-c2b compile ?values) - "c2s" (compile-jvm-c2s compile ?values) - "c2i" (compile-jvm-c2i compile ?values) - "c2l" (compile-jvm-c2l compile ?values) + "new" (compile-jvm-new compile ?values) + "invokestatic" (compile-jvm-invokestatic compile ?values) + "invokevirtual" (compile-jvm-invokevirtual compile ?values) + "invokeinterface" (compile-jvm-invokeinterface compile ?values) + "invokespecial" (compile-jvm-invokespecial compile ?values) + "getstatic" (compile-jvm-getstatic compile ?values) + "getfield" (compile-jvm-getfield compile ?values) + "putstatic" (compile-jvm-putstatic compile ?values) + "putfield" (compile-jvm-putfield compile ?values) + "throw" (compile-jvm-throw compile ?values) + "monitorenter" (compile-jvm-monitorenter compile ?values) + "monitorexit" (compile-jvm-monitorexit compile ?values) + "null?" (compile-jvm-null? compile ?values) + "null" (compile-jvm-null compile ?values) + "anewarray" (compile-jvm-anewarray compile ?values) + "aaload" (compile-jvm-aaload compile ?values) + "aastore" (compile-jvm-aastore compile ?values) + "arraylength" (compile-jvm-arraylength compile ?values) + "znewarray" (compile-jvm-znewarray compile ?values) + "bnewarray" (compile-jvm-bnewarray compile ?values) + "snewarray" (compile-jvm-snewarray compile ?values) + "inewarray" (compile-jvm-inewarray compile ?values) + "lnewarray" (compile-jvm-lnewarray compile ?values) + "fnewarray" (compile-jvm-fnewarray compile ?values) + "dnewarray" (compile-jvm-dnewarray compile ?values) + "cnewarray" (compile-jvm-cnewarray compile ?values) + "iadd" (compile-jvm-iadd compile ?values) + "isub" (compile-jvm-isub compile ?values) + "imul" (compile-jvm-imul compile ?values) + "idiv" (compile-jvm-idiv compile ?values) + "irem" (compile-jvm-irem compile ?values) + "ieq" (compile-jvm-ieq compile ?values) + "ilt" (compile-jvm-ilt compile ?values) + "igt" (compile-jvm-igt compile ?values) + "ceq" (compile-jvm-ceq compile ?values) + "clt" (compile-jvm-clt compile ?values) + "cgt" (compile-jvm-cgt compile ?values) + "ladd" (compile-jvm-ladd compile ?values) + "lsub" (compile-jvm-lsub compile ?values) + "lmul" (compile-jvm-lmul compile ?values) + "ldiv" (compile-jvm-ldiv compile ?values) + "lrem" (compile-jvm-lrem compile ?values) + "leq" (compile-jvm-leq compile ?values) + "llt" (compile-jvm-llt compile ?values) + "lgt" (compile-jvm-lgt compile ?values) + "fadd" (compile-jvm-fadd compile ?values) + "fsub" (compile-jvm-fsub compile ?values) + "fmul" (compile-jvm-fmul compile ?values) + "fdiv" (compile-jvm-fdiv compile ?values) + "frem" (compile-jvm-frem compile ?values) + "feq" (compile-jvm-feq compile ?values) + "flt" (compile-jvm-flt compile ?values) + "fgt" (compile-jvm-fgt compile ?values) + "dadd" (compile-jvm-dadd compile ?values) + "dsub" (compile-jvm-dsub compile ?values) + "dmul" (compile-jvm-dmul compile ?values) + "ddiv" (compile-jvm-ddiv compile ?values) + "drem" (compile-jvm-drem compile ?values) + "deq" (compile-jvm-deq compile ?values) + "dlt" (compile-jvm-dlt compile ?values) + "dgt" (compile-jvm-dgt compile ?values) + "iand" (compile-jvm-iand compile ?values) + "ior" (compile-jvm-ior compile ?values) + "ixor" (compile-jvm-ixor compile ?values) + "ishl" (compile-jvm-ishl compile ?values) + "ishr" (compile-jvm-ishr compile ?values) + "iushr" (compile-jvm-iushr compile ?values) + "land" (compile-jvm-land compile ?values) + "lor" (compile-jvm-lor compile ?values) + "lxor" (compile-jvm-lxor compile ?values) + "lshl" (compile-jvm-lshl compile ?values) + "lshr" (compile-jvm-lshr compile ?values) + "lushr" (compile-jvm-lushr compile ?values) + "d2f" (compile-jvm-d2f compile ?values) + "d2i" (compile-jvm-d2i compile ?values) + "d2l" (compile-jvm-d2l compile ?values) + "f2d" (compile-jvm-f2d compile ?values) + "f2i" (compile-jvm-f2i compile ?values) + "f2l" (compile-jvm-f2l compile ?values) + "i2b" (compile-jvm-i2b compile ?values) + "i2c" (compile-jvm-i2c compile ?values) + "i2d" (compile-jvm-i2d compile ?values) + "i2f" (compile-jvm-i2f compile ?values) + "i2l" (compile-jvm-i2l compile ?values) + "i2s" (compile-jvm-i2s compile ?values) + "l2d" (compile-jvm-l2d compile ?values) + "l2f" (compile-jvm-l2f compile ?values) + "l2i" (compile-jvm-l2i compile ?values) + "c2b" (compile-jvm-c2b compile ?values) + "c2s" (compile-jvm-c2s compile ?values) + "c2i" (compile-jvm-c2i compile ?values) + "c2l" (compile-jvm-c2l compile ?values) ;; else (fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index e9bac0e08..51e1c7f8a 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -26,12 +26,7 @@ ("captured" 1) ("host" 2) - ("jvm-invokestatic" 1) ("jvm-instanceof" 1) - ("jvm-invokevirtual" 1) - ("jvm-invokeinterface" 1) - ("jvm-invokespecial" 1) - ("jvm-new" 1) ("jvm-class" 1) ("jvm-interface" 1) ("jvm-try" 1) @@ -87,24 +82,9 @@ (&-base/$host ?proc-ident ?args) (return ($host ?proc-ident ?args)) - (&-base/$jvm-invokestatic value) - (return ($jvm-invokestatic value)) - (&-base/$jvm-instanceof value) (return ($jvm-instanceof value)) - (&-base/$jvm-invokevirtual value) - (return ($jvm-invokevirtual value)) - - (&-base/$jvm-invokeinterface value) - (return ($jvm-invokeinterface value)) - - (&-base/$jvm-invokespecial value) - (return ($jvm-invokespecial value)) - - (&-base/$jvm-new value) - (return ($jvm-new value)) - (&-base/$jvm-class value) (return ($jvm-class value)) |