From 0e781cd68500c6c612485cd23315b5f8a945cb5b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 11 May 2016 13:17:27 -0400 Subject: - Now fusing impl and apply1 for 1-arity functions. - Now avoiding to "reset" functions at stage 0, when called with an apply-N where N = arity. --- src/lux/compiler/lambda.clj | 170 +++++++++++++++++++++++--------------------- 1 file changed, 90 insertions(+), 80 deletions(-) (limited to 'src') diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index f1f6ec35a..3f3e1e5c7 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -90,7 +90,7 @@ )) (defn ^:private lambda-impl-signature [level] - (str "(" (&/fold str "" (&/|repeat level field-sig)) ")" lambda-return-sig)) + (str "(" (&/fold str "" (&/|repeat level field-sig)) ")" lambda-return-sig)) (defn ^:private lambda--signature [env level] (if (> level 1) @@ -171,85 +171,90 @@ (.visitMaxs 0 0) (.visitEnd)))) -(defn ^:private add-lambda-apply-n [class-writer +degree+ class-name level env] +(defn ^:private add-lambda-apply-n [class-writer +degree+ class-name level env compile impl-body] (if (> level 1) - (let [$default (new Label) - $labels* (map (fn [_] (new Label)) (repeat (dec level) nil)) + (let [num-partials (dec level) + $default (new Label) + $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) $labels (vec (concat $labels* (list $default))) $end (new Label) method-writer (.visitMethod ^ClassWriter 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])] - (doto method-writer - (.visitCode) - (get-num-args! class-name) - (.visitFrame Opcodes/F_NEW - (int (alength frame-locals)) frame-locals - (int (alength frame-stack)) frame-stack) - (.visitTableSwitchInsn 0 (- level 2) $default (into-array Label $labels*)) - ;; (< stage (- level +degree+)) - (-> (doto (.visitLabel $label) - (.visitFrame Opcodes/F_NEW - (int (alength frame-locals)) frame-locals - (int (alength frame-stack)) frame-stack) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - (get-num-args! class-name) - (inc-int! +degree+) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (fill-nulls! (dec (- (- level +degree+) stage))) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env level)) - (.visitJumpInsn Opcodes/GOTO $end)) - (->> (cond (= stage (- level +degree+)) - (doto method-writer - (.visitLabel $label) - (.visitFrame Opcodes/F_NEW - (int (alength frame-locals)) frame-locals - (int (alength frame-stack)) frame-stack) - (.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 +degree+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level)) - (.visitJumpInsn Opcodes/GOTO $end)) + (do (doto method-writer + (.visitCode) + (get-num-args! class-name) + (.visitFrame Opcodes/F_NEW + (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+)) + (-> (doto (.visitLabel $label) + (.visitFrame Opcodes/F_NEW + (int (alength frame-locals)) frame-locals + (int (alength frame-stack)) frame-stack) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + (get-num-args! class-name) + (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 level)) + (.visitJumpInsn Opcodes/GOTO $end)) + (->> (cond (= stage (- level +degree+)) + (doto method-writer + (.visitLabel $label) + (.visitFrame Opcodes/F_NEW + (int (alength frame-locals)) frame-locals + (int (alength frame-stack)) frame-stack) + (.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 level)) + (.visitJumpInsn Opcodes/GOTO $end)) - (> stage (- level +degree+)) - (let [base 1 - args-to-completion (- level stage) - args-left (- +degree+ args-to-completion)] - (doto method-writer - (.visitLabel $label) - (.visitFrame Opcodes/F_NEW - (int (alength frame-locals)) frame-locals - (int (alength frame-stack)) frame-stack) - (.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 base args-to-completion) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level)) - (consecutive-applys (+ base args-to-completion) args-left) - (.visitJumpInsn Opcodes/GOTO $end))) + (> stage (- level +degree+)) + (let [base 1 + args-to-completion (- level stage) + args-left (- +degree+ args-to-completion)] + (doto method-writer + (.visitLabel $label) + (.visitFrame Opcodes/F_NEW + (int (alength frame-locals)) frame-locals + (int (alength frame-stack)) frame-stack) + (.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 base args-to-completion) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level)) + (consecutive-applys (+ base args-to-completion) args-left) + (.visitJumpInsn Opcodes/GOTO $end))) - :else) - (doseq [[stage $label] (map vector (range level) $labels)]))) - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))) + :else) + (doseq [[stage $label] (map vector (range level) $labels)]))) + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (return nil))) + (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) + (.visitCode)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile 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) @@ -276,15 +281,20 @@ (.visitSource file-name nil) (add-lambda- class-name level ?env) (add-lambda-reset class-name level ?env) - (add-lambda-apply-n 1 class-name level ?env) - (-> (add-lambda-apply-n 2 class-name level ?env) - (->> (when (>= level 2)))) - (-> (add-lambda-apply-n 3 class-name level ?env) - (->> (when (>= level 3)))) - (-> (add-lambda-apply-n 4 class-name level ?env) - (->> (when (>= level 4)))) )] - _ (add-lambda-impl =class class-name compile level ?body) + _ (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) + (return nil)) :let [_ (.visitEnd =class)] _ (&&/save-class! name (.toByteArray =class))] (instance-closure compile class-name level ?env)))) -- cgit v1.2.3