From 9cd4665dec8ea17bf003916cead11de1a80519a8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 13 May 2016 20:21:45 -0400 Subject: - Fixed a bug that allowed pattern-matching using unknown tags to proceed. - Streamlined invocation of functions when the args-list >= the arity. The impl method gets called immediately, instead of passing first by the apply method. --- src/lux/base.clj | 8 +++++--- src/lux/compiler/base.clj | 2 ++ src/lux/compiler/host.clj | 9 +++++++-- src/lux/compiler/lambda.clj | 42 ++++++++++++++++++++++++------------------ src/lux/compiler/lux.clj | 38 ++++++++++++++++++++++++++++++++++---- 5 files changed, 72 insertions(+), 27 deletions(-) (limited to 'src') diff --git a/src/lux/base.clj b/src/lux/base.clj index 622b5b1fc..89f9bb36a 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -266,9 +266,11 @@ ;; else (mapv transform-pattern pattern)) - (seq? pattern) [(-> (ns-resolve *ns* (first pattern)) - meta - ::idx) + (seq? pattern) [(if-let [tag-var (ns-resolve *ns* (first pattern))] + (-> tag-var + meta + ::idx) + (assert false (str "Unknown var: " (first pattern)))) '_ (transform-pattern (vec (rest pattern)))] :else pattern diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 1c5301a68..1cc310564 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -39,6 +39,8 @@ (defn ^String apply-signature [n] (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) (def num-apply-variants 8) +(def arity-field "_arity_") +(def partials-field "_partials_") (def exported-separator " ") (def def-separator "\t") diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 0726e1ecf..da0d6f788 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -528,11 +528,16 @@ Opcodes/ACC_ABSTRACT ;; Opcodes/ACC_INTERFACE ) - &&/function-class nil super-class (into-array String []))) - =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "()V" nil nil) + &&/function-class nil super-class (into-array String [])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) + (doto (.visitEnd)))) + =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) (.visitCode) (.visitVarInsn Opcodes/ALOAD 0) (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd)) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 7ef4e439d..2bc0c29eb 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -28,14 +28,14 @@ (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") -(def ^:private num-args-field "_num_args_") + (defn ^:private ^String reset-signature [function-class] (str "()" (&host-generics/->type-signature function-class))) -(defn ^:private ^MethodVisitor get-num-args! [^MethodVisitor method-writer class-name] +(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] (doto method-writer (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name num-args-field "I"))) + (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) (defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] (doto method-writer @@ -82,23 +82,30 @@ (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" -return))) +(defn ^:private init-function [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- [class class-name arity env] (let [closure-length (&/|length env)] (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "" (lambda--signature env arity) nil nil) (.visitCode) ;; Do normal object initialization (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "()V") + (init-function arity closure-length) ;; Add all of the closure variables (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn % Opcodes/ALOAD (inc ?captured-id))) (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) (doseq [?name+?captured (&/->seq env)]))) - (-> (doto (put-field! class-name num-args-field "I" #(.visitVarInsn % Opcodes/ILOAD (inc closure-length))) ;; Add the counter - ;; Add all the partial arguments - (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn % Opcodes/ALOAD partial-register)) - (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) - (dotimes [idx* (dec arity)])))) - (->> (when (> arity 1)))) + ;; Add all the partial arguments + (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn % Opcodes/ALOAD partial-register)) + (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) + (dotimes [idx* (dec arity)]))) ;; Finish (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -166,7 +173,7 @@ frame-stack (to-array [Opcodes/INTEGER])] (do (doto method-writer (.visitCode) - (get-num-args! class-name) + get-num-partials! (.visitFrame Opcodes/F_NEW (int (alength frame-locals)) frame-locals (int (alength frame-stack)) frame-stack) @@ -180,7 +187,7 @@ (.visitInsn Opcodes/DUP) (-> (get-field! class-name (str &&/closure-prefix cidx)) (->> (dotimes [cidx (&/|length env)]))) - (get-num-args! class-name) + get-num-partials! (inc-int! +degree+) (-> (get-field! class-name (str &&/partial-prefix idx)) (->> (dotimes [idx stage]))) @@ -249,18 +256,17 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version lambda-flags class-name nil &&/function-class (into-array String [])) + (-> (.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)]))) - (-> (doto (-> (.visitField datum-flags num-args-field "I" nil nil) - (doto (.visitEnd))) - (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) - (doto (.visitEnd)) - (->> (dotimes [idx (dec arity)])))) - (->> (when (> arity 1)))) + (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) + (doto (.visitEnd)) + (->> (dotimes [idx (dec arity)]))) (.visitSource file-name nil) (add-lambda- class-name arity ?env) (add-lambda-reset class-name arity ?env) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 0facb74c1..f2c67bfae 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -14,7 +14,8 @@ [lexer :as &lexer] [parser :as &parser] [analyser :as &analyser] - [host :as &host]) + [host :as &host] + [optimizer :as &o]) [lux.host.generics :as &host-generics] (lux.analyser [base :as &a] [module :as &a-module] @@ -25,7 +26,8 @@ (:import (org.objectweb.asm Opcodes Label ClassWriter - MethodVisitor))) + MethodVisitor) + java.lang.reflect.Field)) ;; [Exports] (defn compile-bool [compile ?value] @@ -108,9 +110,8 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile ?fn ?args] +(defn ^:private compile-apply* [compile ?args] (|do [^MethodVisitor *writer* &/get-writer - _ (compile ?fn) _ (&/map% (fn [?args] (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)] _ (&/map% compile ?args) @@ -119,6 +120,35 @@ (&/|partition &&/num-apply-variants ?args))] (return nil))) +(defn compile-apply [compile ?fn ?args] + (|case ?fn + [_ (&o/$var (&/$Global ?module ?name))] + (|do [[_ [_ _ func-obj]] (&a-module/find-def ?module ?name) + class-loader &/loader + :let [func-class (class func-obj) + func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil) + func-partials (.get ^Field (.getDeclaredField (Class/forName "lux.Function" true class-loader) &&/partials-field) func-obj) + num-args (&/|length ?args) + func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]] + (if (and (= 0 func-partials) + (>= num-args func-arity)) + (|do [_ (compile ?fn) + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)] + _ (&/map% compile (&/|take func-arity ?args)) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))] + _ (if (= num-args func-arity) + (return nil) + (compile-apply* compile (&/|drop func-arity ?args)))] + (return nil)) + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)))) + + _ + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)) + )) + (defn ^:private compile-def-type [compile ?body] (|do [:let [?def-type (|case ?body [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr ?def-value-type)] -- cgit v1.2.3