From 6066515f7a9736210a04652636a634179939d185 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Apr 2017 23:09:48 -0400 Subject: - Renamed _lux_lambda to _lux_function. --- luxc/src/lux/analyser.clj | 4 +- luxc/src/lux/analyser/base.clj | 16 +- luxc/src/lux/analyser/function.clj | 28 ++++ luxc/src/lux/analyser/lambda.clj | 28 ---- luxc/src/lux/analyser/lux.clj | 36 ++--- luxc/src/lux/analyser/proc/jvm.clj | 1 - luxc/src/lux/compiler/jvm.clj | 4 +- luxc/src/lux/compiler/jvm/function.clj | 281 +++++++++++++++++++++++++++++++++ luxc/src/lux/compiler/jvm/lambda.clj | 281 --------------------------------- luxc/src/lux/compiler/jvm/lux.clj | 4 +- luxc/src/lux/optimizer.clj | 4 +- 11 files changed, 343 insertions(+), 344 deletions(-) create mode 100644 luxc/src/lux/analyser/function.clj delete mode 100644 luxc/src/lux/analyser/lambda.clj create mode 100644 luxc/src/lux/compiler/jvm/function.clj delete mode 100644 luxc/src/lux/compiler/jvm/lambda.clj (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 4090cfea8..c47eaddfa 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -119,13 +119,13 @@ (&/with-analysis-meta cursor exo-type (&&lux/analyse-case analyse exo-type ?value ?branches))) - "_lux_lambda" + "_lux_function" (|let [(&/$Cons [_ (&/$SymbolS "" ?self)] (&/$Cons [_ (&/$SymbolS "" ?arg)] (&/$Cons ?body (&/$Nil)))) parameters] (&/with-analysis-meta cursor exo-type - (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body))) + (&&lux/analyse-function analyse exo-type ?self ?arg ?body))) "_lux_proc" (|let [(&/$Cons [_ (&/$TupleS (&/$Cons [_ (&/$TextS ?category)] diff --git a/luxc/src/lux/analyser/base.clj b/luxc/src/lux/analyser/base.clj index f4718a67e..46eafa051 100644 --- a/luxc/src/lux/analyser/base.clj +++ b/luxc/src/lux/analyser/base.clj @@ -17,7 +17,7 @@ ("tuple" 1) ("apply" 2) ("case" 2) - ("lambda" 4) + ("function" 4) ("ann" 2) ("var" 1) ("captured" 1) @@ -104,13 +104,13 @@ (&/T [_pattern (de-meta _body)]))) branches)) - ($lambda _register-offset scope captured body) - ($lambda _register-offset scope - (&/|map (fn [branch] - (|let [[_name _captured] branch] - (&/T [_name (de-meta _captured)]))) - captured) - (de-meta body)) + ($function _register-offset scope captured body) + ($function _register-offset scope + (&/|map (fn [branch] + (|let [[_name _captured] branch] + (&/T [_name (de-meta _captured)]))) + captured) + (de-meta body)) ($ann value-expr type-expr) (de-meta value-expr) diff --git a/luxc/src/lux/analyser/function.clj b/luxc/src/lux/analyser/function.clj new file mode 100644 index 000000000..aaaaed9f9 --- /dev/null +++ b/luxc/src/lux/analyser/function.clj @@ -0,0 +1,28 @@ +(ns lux.analyser.function + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return |case]] + [host :as &host]) + (lux.analyser [base :as &&] + [env :as &env]))) + +;; [Resource] +(defn with-function [self self-type arg arg-type body] + (&/with-closure + (|do [scope-name &/get-scope-name] + (&env/with-local self self-type + (&env/with-local arg arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T [scope-name =captured =return])))))))) + +(defn close-over [scope name register frame] + (|let [[[register-type register-cursor] _] register + register* (&&/|meta register-type register-cursor + (&&/$captured (&/T [scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register])))] + (&/T [register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) + frame)]))) diff --git a/luxc/src/lux/analyser/lambda.clj b/luxc/src/lux/analyser/lambda.clj deleted file mode 100644 index fdea7521a..000000000 --- a/luxc/src/lux/analyser/lambda.clj +++ /dev/null @@ -1,28 +0,0 @@ -(ns lux.analyser.lambda - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return |case]] - [host :as &host]) - (lux.analyser [base :as &&] - [env :as &env]))) - -;; [Resource] -(defn with-lambda [self self-type arg arg-type body] - (&/with-closure - (|do [scope-name &/get-scope-name] - (&env/with-local self self-type - (&env/with-local arg arg-type - (|do [=return body - =captured &env/captured-vars] - (return (&/T [scope-name =captured =return])))))))) - -(defn close-over [scope name register frame] - (|let [[[register-type register-cursor] _] register - register* (&&/|meta register-type register-cursor - (&&/$captured (&/T [scope - (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) - register])))] - (&/T [register* (&/update$ &/$closure #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) - frame)]))) diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index 989ccb591..04ef66683 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -8,7 +8,7 @@ [type :as &type] [host :as &host]) (lux.analyser [base :as &&] - [lambda :as &&lambda] + [function :as &&function] [case :as &&case] [env :as &&env] [module :as &&module] @@ -302,7 +302,7 @@ (|let [scopes (&/|map #(&/get$ &/$name %) (&/|reverse inner)) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner - [register* frame*] (&&lambda/close-over in-scope name register frame)] + [register* frame*] (&&function/close-over in-scope name register frame)] (&/T [register* (&/$Cons frame* new-inner)]))) (&/T [(or (->> bottom-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) (->> bottom-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) @@ -464,25 +464,25 @@ =func** (&type/clean $output =func*)] (return =func**)))) -(defn analyse-lambda* [analyse exo-type ?self ?arg ?body] +(defn analyse-function* [analyse exo-type ?self ?arg ?body] (|case exo-type (&/$VarT id) (|do [? (&type/bound? id)] (if ? (|do [exo-type* (&type/deref id)] - (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + (analyse-function* analyse exo-type* ?self ?arg ?body)) ;; Inference (&type/with-var (fn [$input] (&type/with-var (fn [$output] - (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&/$LambdaT $input $output) ?self ?arg ?body) + (|do [[[function-type function-cursor] function-analysis] (analyse-function* analyse (&/$LambdaT $input $output) ?self ?arg ?body) =input (&type/resolve-type $input) =output (&type/resolve-type $output) inferred-type (clean-func-inference $input $output =input (embed-inferred-input =input =output)) _ (&type/check exo-type inferred-type)] - (return (&&/|meta inferred-type lambda-cursor - lambda-analysis))) + (return (&&/|meta inferred-type function-cursor + function-analysis))) )))))) _ @@ -494,23 +494,23 @@ :let [(&/$ExT $var-id) $var] exo-type** (&type/apply-type exo-type* $var)] (&/with-scope-type-var $var-id - (analyse-lambda* analyse exo-type** ?self ?arg ?body))) + (analyse-function* analyse exo-type** ?self ?arg ?body))) (&/$ExQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - =expr (analyse-lambda* analyse exo-type** ?self ?arg ?body)] + =expr (analyse-function* analyse exo-type** ?self ?arg ?body)] (&&/clean-analysis $var =expr)))) (&/$LambdaT ?arg-t ?return-t) - (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + (|do [[=scope =captured =body] (&&function/with-function ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body)) _cursor &/cursor register-offset &&env/next-local-idx] (return (&&/|meta exo-type* _cursor - (&&/$lambda register-offset =scope =captured =body)))) + (&&/$function register-offset =scope =captured =body)))) _ (&/fail ""))) @@ -518,14 +518,14 @@ (&/fail-with-loc (str err "\n" "[Analyser Error] Functions require function types: " (&type/show-type exo-type))))) )) -(defn analyse-lambda** [analyse exo-type ?self ?arg ?body] +(defn analyse-function** [analyse exo-type ?self ?arg ?body] (|case exo-type (&/$UnivQ _) (|do [$var &type/existential :let [(&/$ExT $var-id) $var] exo-type* (&type/apply-type exo-type $var) [_ _expr] (&/with-scope-type-var $var-id - (analyse-lambda** analyse exo-type* ?self ?arg ?body)) + (analyse-function** analyse exo-type* ?self ?arg ?body)) _cursor &/cursor] (return (&&/|meta exo-type _cursor _expr))) @@ -533,17 +533,17 @@ (|do [? (&type/bound? id)] (if ? (|do [exo-type* (&type/actual-type exo-type)] - (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + (analyse-function* analyse exo-type* ?self ?arg ?body)) ;; Inference - (analyse-lambda* analyse exo-type ?self ?arg ?body))) + (analyse-function* analyse exo-type ?self ?arg ?body))) _ (|do [exo-type* (&type/actual-type exo-type)] - (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + (analyse-function* analyse exo-type* ?self ?arg ?body)) )) -(defn analyse-lambda [analyse exo-type ?self ?arg ?body] - (|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)] +(defn analyse-function [analyse exo-type ?self ?arg ?body] + (|do [output (analyse-function** analyse exo-type ?self ?arg ?body)] (return (&/|list output)))) (defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta] diff --git a/luxc/src/lux/analyser/proc/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj index ec14aabb0..3fc3e2e8c 100644 --- a/luxc/src/lux/analyser/proc/jvm.clj +++ b/luxc/src/lux/analyser/proc/jvm.clj @@ -12,7 +12,6 @@ [lux.type.host :as &host-type] [lux.host.generics :as &host-generics] (lux.analyser [base :as &&] - [lambda :as &&lambda] [env :as &&env] [parser :as &&a-parser]) [lux.compiler.jvm.base :as &c!base]) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 150ec54f4..b612c9f35 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -24,7 +24,7 @@ (lux.compiler.jvm [base :as &&] [lux :as &&lux] [case :as &&case] - [lambda :as &&lambda] + [function :as &&function] [rt :as &&rt] [cache :as &&jvm-cache]) (lux.compiler.jvm.proc [common :as &&proc-common] @@ -105,7 +105,7 @@ (&&lux/compile-if (partial compile-expression $begin) _test _then _else) (&o/$function _register-offset ?arity ?scope ?env ?body) - (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body) + (&&function/compile-function compile-expression &/$None ?arity ?scope ?env ?body) (&o/$ann ?value-ex ?type-ex) (compile-expression $begin ?value-ex) diff --git a/luxc/src/lux/compiler/jvm/function.clj b/luxc/src/lux/compiler/jvm/function.clj new file mode 100644 index 000000000..83c1fb95c --- /dev/null +++ b/luxc/src/lux/compiler/jvm/function.clj @@ -0,0 +1,281 @@ +(ns lux.compiler.jvm.function + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |case |let]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + (lux.compiler.jvm [base :as &&])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private function-return-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private -return "V") + +(defn ^:private ^String reset-signature [function-class] + (str "()" (&host-generics/->type-signature function-class))) + +(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) + +(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] + (doto method-writer + (.visitLdcInsn (int by)) + (.visitInsn Opcodes/IADD))) + +(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig))) + +(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + value-thunk + (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig))) + +(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount] + (doto method-writer + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (dotimes [_ amount]))))) + +(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] + (doto method-writer + (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) + (->> (dotimes [idx amount]))))) + +(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] + (let [max-args-num (min amount &&/num-apply-variants)] + (doto method-writer + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (consecutive-args start max-args-num) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) + (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) + (->> (when (> amount &&/num-apply-variants))))))) + +(defn ^:private function-impl-signature [arity] + (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" function-return-sig)) + +(defn ^:private function--signature [env arity] + (if (> arity 1) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" + -return) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" + -return))) + +(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] + (if (= 1 arity) + (doto method-writer + (.visitLdcInsn (int 0)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")) + (doto method-writer + (.visitVarInsn Opcodes/ILOAD (inc closure-length)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")))) + +(defn ^:private add-function- [^ClassWriter class class-name arity env] + (let [closure-length (&/|length env)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "" (function--signature env arity) nil nil) + (.visitCode) + ;; Do normal object initialization + (.visitVarInsn Opcodes/ALOAD 0) + (init-function arity closure-length) + ;; Add all of the closure variables + (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) + (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) + (doseq [?name+?captured (&/->seq env)]))) + ;; Add all the partial arguments + (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) + (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) + (dotimes [idx* (dec arity)]))) + ;; Finish + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] + (defn ^:private add-function-impl [^ClassWriter class class-name compile arity impl-body] + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod class impl-flags "impl" (function-impl-signature arity) nil nil) + (.visitCode) + (.visitLabel $begin)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile $begin impl-body) + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret)))))) + +(defn ^:private instance-closure [compile function-class arity closed-over] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW function-class) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [?name+?captured] + (|case ?name+?captured + [?name [_ (&o/$captured _ _ ?source)]] + (compile nil ?source))) + closed-over) + :let [_ (when (> arity 1) + (doto *writer* + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity))))] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL function-class "" (function--signature closed-over arity))]] + (return nil))) + +(defn ^:private add-function-reset [^ClassWriter class-writer class-name arity env] + (if (> arity 1) + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (function--signature env arity)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(defn ^:private add-function-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] + (if (> arity 1) + (let [num-partials (dec arity) + $default (new Label) + $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) + $labels (vec (concat $labels* (list $default))) + $end (new Label) + method-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil) + frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) + frame-stack (to-array [Opcodes/INTEGER]) + arity-over-extent (- arity +degree+)] + (do (doto method-writer + (.visitCode) + get-num-partials! + (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) + ;; (< stage (- arity +degree+)) + (-> (doto (.visitLabel $label) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + get-num-partials! + (inc-int! +degree+) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (fill-nulls! (- (- num-partials +degree+) stage)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (function--signature env arity)) + (.visitJumpInsn Opcodes/GOTO $end)) + (->> (cond (= stage arity-over-extent) + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (->> (when (not= 0 stage)))) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (function-impl-signature arity)) + (.visitJumpInsn Opcodes/GOTO $end)) + + (> stage arity-over-extent) + (let [args-to-completion (- arity stage) + args-left (- +degree+ args-to-completion)] + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 args-to-completion) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (function-impl-signature arity)) + (consecutive-applys (+ 1 args-to-completion) args-left) + (.visitJumpInsn Opcodes/GOTO $end))) + + :else) + (doseq [[stage $label] (map vector (range arity) $labels)]))) + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (return nil))) + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) + (.visitCode) + (.visitLabel $begin)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile $begin impl-body) + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret)))) + )) + +;; [Exports] +(let [function-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] + (|do [[file-name _ _] &/cursor + :let [??scope (&/|reverse ?scope) + name (&host/location (&/|tail ??scope)) + class-name (str (&host/->module-class (&/|head ??scope)) "/" name) + [^ClassWriter =class save?] (|case ?prev-writer + (&/$Some _writer) + (&/T [_writer false]) + + (&/$None) + (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version function-flags + class-name nil &&/function-class (into-array String []))) + true])) + _ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) + (doto (.visitEnd))) + (-> (doto (.visitField datum-flags captured-name field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) + (doto (.visitEnd)) + (->> (dotimes [idx (dec arity)]))) + (-> (.visitSource file-name nil) + (when save?)) + (add-function- class-name arity ?env) + (add-function-reset class-name arity ?env) + )] + _ (if (> arity 1) + (add-function-impl =class class-name compile arity ?body) + (return nil)) + _ (&/map% #(add-function-apply-n =class % class-name arity ?env compile ?body) + (&/|range* 1 (min arity &&/num-apply-variants))) + :let [_ (.visitEnd =class)] + _ (if save? + (&&/save-class! name (.toByteArray =class)) + (return nil))] + (if save? + (instance-closure compile class-name arity ?env) + (return (instance-closure compile class-name arity ?env)))))) diff --git a/luxc/src/lux/compiler/jvm/lambda.clj b/luxc/src/lux/compiler/jvm/lambda.clj deleted file mode 100644 index 87d977012..000000000 --- a/luxc/src/lux/compiler/jvm/lambda.clj +++ /dev/null @@ -1,281 +0,0 @@ -(ns lux.compiler.jvm.lambda - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |case |let]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - (lux.compiler.jvm [base :as &&])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Utils] -(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private -return "V") - -(defn ^:private ^String reset-signature [function-class] - (str "()" (&host-generics/->type-signature function-class))) - -(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) - -(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] - (doto method-writer - (.visitLdcInsn (int by)) - (.visitInsn Opcodes/IADD))) - -(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig))) - -(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - value-thunk - (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig))) - -(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount] - (doto method-writer - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [_ amount]))))) - -(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] - (doto method-writer - (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) - (->> (dotimes [idx amount]))))) - -(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] - (let [max-args-num (min amount &&/num-apply-variants)] - (doto method-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start max-args-num) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) - (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) - (->> (when (> amount &&/num-apply-variants))))))) - -(defn ^:private lambda-impl-signature [arity] - (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig)) - -(defn ^:private lambda--signature [env arity] - (if (> arity 1) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" - -return) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" - -return))) - -(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] - (if (= 1 arity) - (doto method-writer - (.visitLdcInsn (int 0)) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")) - (doto method-writer - (.visitVarInsn Opcodes/ILOAD (inc closure-length)) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")))) - -(defn ^:private add-lambda- [^ClassWriter class class-name arity env] - (let [closure-length (&/|length env)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "" (lambda--signature env arity) nil nil) - (.visitCode) - ;; Do normal object initialization - (.visitVarInsn Opcodes/ALOAD 0) - (init-function arity closure-length) - ;; Add all of the closure variables - (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) - (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) - (doseq [?name+?captured (&/->seq env)]))) - ;; Add all the partial arguments - (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) - (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) - (dotimes [idx* (dec arity)]))) - ;; Finish - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] - (defn ^:private add-lambda-impl [^ClassWriter class class-name compile arity impl-body] - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod class impl-flags "impl" (lambda-impl-signature arity) nil nil) - (.visitCode) - (.visitLabel $begin)) - (|do [^MethodVisitor *writer* &/get-writer - ret (compile $begin impl-body) - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))))) - -(defn ^:private instance-closure [compile lambda-class arity closed-over] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW lambda-class) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [?name+?captured] - (|case ?name+?captured - [?name [_ (&o/$captured _ _ ?source)]] - (compile nil ?source))) - closed-over) - :let [_ (when (> arity 1) - (doto *writer* - (.visitLdcInsn (int 0)) - (fill-nulls! (dec arity))))] - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" (lambda--signature closed-over arity))]] - (return nil))) - -(defn ^:private add-lambda-reset [^ClassWriter class-writer class-name arity env] - (if (> arity 1) - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - (.visitLdcInsn (int 0)) - (fill-nulls! (dec arity)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -(defn ^:private add-lambda-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] - (if (> arity 1) - (let [num-partials (dec arity) - $default (new Label) - $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) - $labels (vec (concat $labels* (list $default))) - $end (new Label) - method-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil) - frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) - frame-stack (to-array [Opcodes/INTEGER]) - arity-over-extent (- arity +degree+)] - (do (doto method-writer - (.visitCode) - get-num-partials! - (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) - ;; (< stage (- arity +degree+)) - (-> (doto (.visitLabel $label) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - get-num-partials! - (inc-int! +degree+) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (fill-nulls! (- (- num-partials +degree+) stage)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) - (.visitJumpInsn Opcodes/GOTO $end)) - (->> (cond (= stage arity-over-extent) - (doto method-writer - (.visitLabel $label) - (.visitVarInsn Opcodes/ALOAD 0) - (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) - (->> (when (not= 0 stage)))) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) - (.visitJumpInsn Opcodes/GOTO $end)) - - (> stage arity-over-extent) - (let [args-to-completion (- arity stage) - args-left (- +degree+ args-to-completion)] - (doto method-writer - (.visitLabel $label) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 args-to-completion) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) - (consecutive-applys (+ 1 args-to-completion) args-left) - (.visitJumpInsn Opcodes/GOTO $end))) - - :else) - (doseq [[stage $label] (map vector (range arity) $labels)]))) - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (return nil))) - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) - (.visitCode) - (.visitLabel $begin)) - (|do [^MethodVisitor *writer* &/get-writer - ret (compile $begin impl-body) - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))) - )) - -;; [Exports] -(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] - (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] - (|do [[file-name _ _] &/cursor - :let [??scope (&/|reverse ?scope) - name (&host/location (&/|tail ??scope)) - class-name (str (&host/->module-class (&/|head ??scope)) "/" name) - [^ClassWriter =class save?] (|case ?prev-writer - (&/$Some _writer) - (&/T [_writer false]) - - (&/$None) - (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version lambda-flags - class-name nil &&/function-class (into-array String []))) - true])) - _ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) - (doto (.visitEnd))) - (-> (doto (.visitField datum-flags captured-name field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&o/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq ?env)]))) - (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) - (doto (.visitEnd)) - (->> (dotimes [idx (dec arity)]))) - (-> (.visitSource file-name nil) - (when save?)) - (add-lambda- class-name arity ?env) - (add-lambda-reset class-name arity ?env) - )] - _ (if (> arity 1) - (add-lambda-impl =class class-name compile arity ?body) - (return nil)) - _ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body) - (&/|range* 1 (min arity &&/num-apply-variants))) - :let [_ (.visitEnd =class)] - _ (if save? - (&&/save-class! name (.toByteArray =class)) - (return nil))] - (if save? - (instance-closure compile class-name arity ?env) - (return (instance-closure compile class-name arity ?env)))))) diff --git a/luxc/src/lux/compiler/jvm/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj index e14615946..882c9b74c 100644 --- a/luxc/src/lux/compiler/jvm/lux.clj +++ b/luxc/src/lux/compiler/jvm/lux.clj @@ -16,7 +16,7 @@ [module :as &a-module] [meta :as &a-meta]) (lux.compiler.jvm [base :as &&] - [lambda :as &&lambda])) + [function :as &&function])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -286,7 +286,7 @@ (-> (.visitField field-flags &/value-field datum-sig nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] - instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) + instancer (&&function/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] diff --git a/luxc/src/lux/optimizer.clj b/luxc/src/lux/optimizer.clj index 9fc50646e..36caf3362 100644 --- a/luxc/src/lux/optimizer.clj +++ b/luxc/src/lux/optimizer.clj @@ -1142,9 +1142,9 @@ _ (normal-case-optim))) - (&a/$lambda _register-offset scope captured body) + (&a/$function _register-offset scope captured body) (|let [inner-func? (|case body - [_ (&a/$lambda _ _ _ _)] + [_ (&a/$function _ _ _ _)] true _ -- cgit v1.2.3