From 5d4cd81c9dbaff906487f99b2ab39d089b9a3378 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 11 May 2016 13:56:56 -0400 Subject: - Now generating variants of the "apply" method of lux/Function up to 8 arities. --- src/lux/base.clj | 5 ++ src/lux/compiler.clj | 4 +- src/lux/compiler/base.clj | 1 + src/lux/compiler/host.clj | 43 ++++------------- src/lux/compiler/lambda.clj | 115 +++++++++++++++++--------------------------- src/lux/compiler/lux.clj | 2 +- src/lux/optimizer.clj | 12 ++--- 7 files changed, 70 insertions(+), 112 deletions(-) diff --git a/src/lux/base.clj b/src/lux/base.clj index 02bd55112..d514e17e5 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -504,6 +504,11 @@ (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) +(defn |range* [from to] + (if (<= from to) + ($Cons from (|range* (inc from) to)) + $Nil)) + (let [|range* (fn |range* [from to] (if (< from to) ($Cons from (|range* (inc from) to)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 89a608ad0..fe256a942 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -85,8 +85,8 @@ (&o/$case ?value ?match) (&&case/compile-case compile-expression ?value ?match) - (&o/$function ?level ?scope ?env ?body) - (&&lambda/compile-function compile-expression ?level ?scope ?env ?body) + (&o/$function ?arity ?scope ?env ?body) + (&&lambda/compile-function compile-expression ?arity ?scope ?env ?body) ;; Must get rid of this one... (&o/$ann ?value-ex ?type-ex ?value-type) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 19d918ef9..1c5301a68 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -38,6 +38,7 @@ (def ^String apply-method "apply") (defn ^String apply-signature [n] (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) +(def num-apply-variants 8) (def exported-separator " ") (def def-separator "\t") diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 54def6b76..0726e1ecf 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -536,45 +536,22 @@ (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd)) - =apply1 (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature 1) nil nil) + _ (dotimes [arity* &&/num-apply-variants] + (let [arity (inc arity*)] + (if (= 1 arity) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) (.visitEnd)) - =apply2 (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 2) nil nil) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - =apply3 (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 3) nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 2)) + (-> (.visitVarInsn Opcodes/ALOAD idx) + (->> (dotimes [idx arity]))) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitVarInsn Opcodes/ALOAD 3) + (.visitVarInsn Opcodes/ALOAD arity) (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) - (.visitEnd)) - =apply4 (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 4) nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitVarInsn Opcodes/ALOAD 3) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 3)) - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitVarInsn Opcodes/ALOAD 4) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - ]] + (.visitEnd)))))]] (&&/save-class! (second (string/split &&/function-class #"/")) (.toByteArray (doto =class .visitEnd))))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 3f3e1e5c7..7ef4e439d 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -64,44 +64,27 @@ (->> (dotimes [idx amount]))))) (defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] - (case amount - 1 (doto method-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start 1) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))) - 2 (doto method-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start 2) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 2))) - 3 (doto method-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start 3) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 3))) - 4 (doto method-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start 4) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 4))) - ;; > 4 + (let [max-args-num (min amount &&/num-apply-variants)] (doto method-writer (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start 4) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 4)) - (consecutive-applys (+ start 4) (- amount 4))) - )) + (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 [level] - (str "(" (&/fold str "" (&/|repeat level field-sig)) ")" lambda-return-sig)) +(defn ^:private lambda-impl-signature [arity] + (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig)) -(defn ^:private lambda--signature [env level] - (if (> level 1) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec level) field-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 add-lambda- [class class-name level env] +(defn ^:private add-lambda- [class class-name arity env] (let [closure-length (&/|length env)] - (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "" (lambda--signature env level) nil nil) + (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "" (lambda--signature env arity) nil nil) (.visitCode) ;; Do normal object initialization (.visitVarInsn Opcodes/ALOAD 0) @@ -114,16 +97,16 @@ ;; 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 level)])))) - (->> (when (> level 1)))) + (dotimes [idx* (dec arity)])))) + (->> (when (> arity 1)))) ;; Finish (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd)))) (let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] - (defn ^:private add-lambda-impl [class class-name compile level impl-body] - (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature level) nil nil) + (defn ^:private add-lambda-impl [class class-name compile arity impl-body] + (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature arity) nil nil) (.visitCode)) (|do [^MethodVisitor *writer* &/get-writer ret (compile impl-body) @@ -133,7 +116,7 @@ (.visitEnd))]] (return ret))))) -(defn ^:private instance-closure [compile lambda-class level closed-over] +(defn ^:private instance-closure [compile lambda-class arity closed-over] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) @@ -143,15 +126,15 @@ [?name [_ (&a/$captured _ _ ?source)]] (compile ?source))) closed-over) - :let [_ (when (> level 1) + :let [_ (when (> arity 1) (doto *writer* (.visitLdcInsn (int 0)) - (fill-nulls! (dec level))))] - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" (lambda--signature closed-over level))]] + (fill-nulls! (dec arity))))] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" (lambda--signature closed-over arity))]] (return nil))) -(defn ^:private add-lambda-reset [class-writer class-name level env] - (if (> level 1) +(defn ^:private add-lambda-reset [class-writer class-name arity env] + (if (> arity 1) (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) (.visitCode) (.visitTypeInsn Opcodes/NEW class-name) @@ -159,8 +142,8 @@ (-> (get-field! class-name (str &&/closure-prefix cidx)) (->> (dotimes [cidx (&/|length env)]))) (.visitLdcInsn (int 0)) - (fill-nulls! (dec level)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env level)) + (fill-nulls! (dec arity)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd)) @@ -171,9 +154,9 @@ (.visitMaxs 0 0) (.visitEnd)))) -(defn ^:private add-lambda-apply-n [class-writer +degree+ class-name level env compile impl-body] - (if (> level 1) - (let [num-partials (dec level) +(defn ^:private add-lambda-apply-n [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))) @@ -188,7 +171,7 @@ (int (alength frame-locals)) frame-locals (int (alength frame-stack)) frame-stack) (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) - ;; (< stage (- level +degree+)) + ;; (< stage (- arity +degree+)) (-> (doto (.visitLabel $label) (.visitFrame Opcodes/F_NEW (int (alength frame-locals)) frame-locals @@ -203,9 +186,9 @@ (->> (dotimes [idx stage]))) (consecutive-args 1 +degree+) (fill-nulls! (- (- num-partials +degree+) stage)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env level)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) (.visitJumpInsn Opcodes/GOTO $end)) - (->> (cond (= stage (- level +degree+)) + (->> (cond (= stage (- arity +degree+)) (doto method-writer (.visitLabel $label) (.visitFrame Opcodes/F_NEW @@ -217,12 +200,12 @@ (-> (get-field! class-name (str &&/partial-prefix idx)) (->> (dotimes [idx stage]))) (consecutive-args 1 +degree+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) (.visitJumpInsn Opcodes/GOTO $end)) - (> stage (- level +degree+)) + (> stage (- arity +degree+)) (let [base 1 - args-to-completion (- level stage) + args-to-completion (- arity stage) args-left (- +degree+ args-to-completion)] (doto method-writer (.visitLabel $label) @@ -234,12 +217,12 @@ (-> (get-field! class-name (str &&/partial-prefix idx)) (->> (dotimes [idx stage]))) (consecutive-args base args-to-completion) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) (consecutive-applys (+ base args-to-completion) args-left) (.visitJumpInsn Opcodes/GOTO $end))) :else) - (doseq [[stage $label] (map vector (range level) $labels)]))) + (doseq [[stage $label] (map vector (range arity) $labels)]))) (.visitLabel $end) (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) @@ -259,7 +242,7 @@ ;; [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 level ?scope ?env ?body] + (defn compile-function [compile arity ?scope ?env ?body] (|do [[file-name _ _] &/cursor :let [name (&host/location (&/|tail ?scope)) class-name (str (&host/->module-class (&/|head ?scope)) "/" name) @@ -276,25 +259,17 @@ (doto (.visitEnd))) (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) (doto (.visitEnd)) - (->> (dotimes [idx (dec level)])))) - (->> (when (> level 1)))) + (->> (dotimes [idx (dec arity)])))) + (->> (when (> arity 1)))) (.visitSource file-name nil) - (add-lambda- class-name level ?env) - (add-lambda-reset class-name level ?env) + (add-lambda- class-name arity ?env) + (add-lambda-reset class-name arity ?env) )] - _ (if (> level 1) - (add-lambda-impl =class class-name compile level ?body) - (return nil)) - _ (add-lambda-apply-n =class 1 class-name level ?env compile ?body) - _ (if (>= level 2) - (add-lambda-apply-n =class 2 class-name level ?env compile ?body) - (return nil)) - _ (if (>= level 3) - (add-lambda-apply-n =class 3 class-name level ?env compile ?body) - (return nil)) - _ (if (>= level 4) - (add-lambda-apply-n =class 4 class-name level ?env compile ?body) + _ (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)] _ (&&/save-class! name (.toByteArray =class))] - (instance-closure compile class-name level ?env)))) + (instance-closure compile class-name arity ?env)))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index e1af775f7..0facb74c1 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -116,7 +116,7 @@ _ (&/map% compile ?args) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]] (return nil))) - (&/|partition 4 ?args))] + (&/|partition &&/num-apply-variants ?args))] (return nil))) (defn ^:private compile-def-type [compile ?body] diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 4b617b591..09f23886e 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -77,8 +77,8 @@ (&/T [_pattern (de-meta _body)]))) branches)) - [meta ($function level scope captured body*)] - ($function level + [meta ($function arity scope captured body*)] + ($function arity scope (&/|map (fn [capture] (|let [[_name _captured] capture] @@ -126,8 +126,8 @@ (shift-function-body own-body? _body)]))) branches))]) - [meta ($function level scope captured body*)] - (&/T [meta ($function level + [meta ($function arity scope captured body*)] + (&/T [meta ($function arity (de-scope scope) (&/|map (fn [capture] (|let [[_name [_meta ($captured _scope _idx _source)]] capture] @@ -215,8 +215,8 @@ [meta (&-base/$lambda scope captured body)] (|case (optimize body) - [_ ($function _level _scope _captured _body)] - (&/T [meta ($function (inc _level) scope (optimize-closure optimize captured) (shift-function-body true _body))]) + [_ ($function _arity _scope _captured _body)] + (&/T [meta ($function (inc _arity) scope (optimize-closure optimize captured) (shift-function-body true _body))]) =body (&/T [meta ($function 1 scope (optimize-closure optimize captured) =body)])) -- cgit v1.2.3