aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser.clj47
-rw-r--r--src/lux/analyser/base.clj5
-rw-r--r--src/lux/analyser/host.clj207
-rw-r--r--src/lux/compiler.clj15
-rw-r--r--src/lux/compiler/host.clj292
-rw-r--r--src/lux/optimizer.clj20
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))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 02:31:18 +0000