From de427e2de39159863fbb9ca9d9984faa1cf60b02 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 28 Jan 2015 01:12:30 -0400 Subject: [Enhancement] - The compiler is now working properly post-refactoring. - The code for generating lambdas was refactored, though it needs to be broken-down further. --- src/lux.clj | 3 +- src/lux/analyser.clj | 71 +++++-- src/lux/compiler.clj | 577 ++++++++++++++++++++++++++++++--------------------- 3 files changed, 392 insertions(+), 259 deletions(-) (limited to 'src') diff --git a/src/lux.clj b/src/lux.clj index 045e6b0f2..f748fd0f3 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -29,7 +29,8 @@ ;; TODO: ;; TODO: - (time (&compiler/compile-all ["lux" "test2"])) + (time (&compiler/compile-all ["lux" ;; "test2" + ])) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 725067db1..5fe13b91d 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -30,6 +30,10 @@ (fn [state] [::&util/ok [state (::current-module state)]])) +(def scope + (fn [state] + [::&util/ok [state (::scope state)]])) + (defn ^:private annotate [name mode access macro? type] (fn [state] [::&util/ok [(assoc-in state [::modules (::current-module state) name] {:mode mode @@ -73,12 +77,31 @@ (fn [state] [::&util/ok [state (-> state ::local-envs first :name)]])) +(defn with-global [top-level-name body] + (exec [$module module-name] + (fn [state] + (let [=return (body (-> state + (update-in [::local-envs] conj (fresh-env top-level-name)) + (assoc ::scope [$module top-level-name])))] + (match =return + [::&util/ok [?state ?value]] + [::&util/ok [(assoc ?state ::scope []) ?value]] + + _ + =return)) + ))) + (defn with-env [label body] (fn [state] - (let [=return (body (update-in state [::local-envs] conj (fresh-env label)))] + (let [=return (body (-> state + (update-in [::local-envs] conj (fresh-env label)) + (update-in [::scope] conj label)))] (match =return [::&util/ok [?state ?value]] - [::&util/ok [(update-in ?state [::local-envs] rest) ?value]] + [::&util/ok [(-> ?state + (update-in [::local-envs] rest) + (update-in [::scope] rest)) + ?value]] _ =return)))) @@ -133,15 +156,14 @@ (defn with-lambda [self self-type arg arg-type body] (exec [$module module-name] (fn [state] - (let [top (-> state ::local-envs first) - scope* (str $module "$" (:name top) "$" (str (:inner-closures top))) - body* (with-env scope* - (with-local self (annotated [::self scope* []] self-type) - (with-let arg arg-type - (exec [=return body - =next next-local-idx - =captured captured-vars] - (return [scope* =next =captured =return])))))] + (let [body* (with-env (-> state ::local-envs first :inner-closures str) + (exec [$scope scope] + (with-local self (annotated [::self $scope []] self-type) + (with-let arg arg-type + (exec [=return body + =next next-local-idx + =captured captured-vars] + (return [$scope =next =captured =return]))))))] (body* (update-in state [::local-envs] #(cons (update-in (first %) [:inner-closures] inc) (rest %)))) )))) @@ -691,6 +713,7 @@ ;; :let [_ (prn 'analyse-lambda/=body ?arg =captured =body)] =function (within ::types (exec [_ (&type/solve =return (:type =body))] (&type/clean =function))) + ;; :let [_ (prn 'LAMBDA/PRE (:form =body))] :let [;; _ (prn '(:form =body) (:form =body)) =lambda (match (:form =body) [::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body] @@ -698,7 +721,9 @@ [::lambda =scope =captured (cons ?arg ?sub-args) ?sub-body*]) _ - [::lambda =scope =captured (list ?arg) =body])]] + [::lambda =scope =captured (list ?arg) =body])] + ;; :let [_ (prn 'LAMBDA/POST =lambda)] + ] (return (list (annotated =lambda =function))))) (declare ->def-lambda) @@ -722,10 +747,8 @@ (defn ^:private ->def-lambda [old-scope new-scope syntax] (match (:form syntax) [::local ?local-scope ?idx] - (if (= ?local-scope old-scope) - {:form [::local new-scope ?idx] - :type (:type syntax)} - syntax) + {:form [::local new-scope (inc ?idx)] + :type (:type syntax)} [::self ?self-name ?curried] (if (= ?self-name old-scope) @@ -735,7 +758,7 @@ [::jvm:iadd ?x ?y] - {:form [::iadd (->def-lambda old-scope new-scope ?x) (->def-lambda old-scope new-scope ?y)] + {:form [::jvm:iadd (->def-lambda old-scope new-scope ?x) (->def-lambda old-scope new-scope ?y)] :type (:type syntax)} [::case ?base ?variant ?registers ?mappings ?tree] @@ -752,11 +775,11 @@ :type (:type syntax)} [::lambda ?scope ?captured ?args ?value] - {:form [::lambda ?scope + {:form [::lambda new-scope (into {} (for [[?name ?sub-syntax] ?captured] [?name (->def-lambda old-scope new-scope ?sub-syntax)])) ?args - (->def-lambda old-scope new-scope ?value)] + ?value] :type (:type syntax)} _ @@ -768,16 +791,18 @@ (fail (str "Can't redefine function/constant: " ?name)) (exec [ann?? (annotated? ?name) $module module-name - :let [scoped-name (str $module "$def_" ?name)] - [=value] (with-env scoped-name + [=value] (with-global ?name (analyse-ast ?value)) + ;; :let [_ (prn 'DEF/PRE =value)] :let [;; _ (prn 'analyse-def/=value =value) =value (match (:form =value) - [::lambda ?scope _ _ _] - (->def-lambda ?scope scoped-name =value) + [::lambda ?scope ?env ?args ?body] + {:form [::lambda ?scope ?env ?args (->def-lambda ?scope [$module ?name] ?body)] + :type (:type =value)} _ =value)] + ;; :let [_ (prn 'DEF/POST =value)] _ (if ann?? (return nil) (annotate ?name ::constant ::public false (:type =value))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index f4cc6e834..e9a445510 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -29,9 +29,15 @@ (defn ^:private write-class [name data] (write-file (str "output/" name ".class") data)) -(defn load-class! [loader name] +(defn ^:private load-class! [loader name] (.loadClass loader name)) +(defn save-class! [name bytecode] + (exec [loader &util/loader + :let [_ (write-class name bytecode) + _ (load-class! loader (string/replace name #"/" "."))]] + (return nil))) + (def ^:private +variant-class+ (str +prefix+ ".Variant")) (def ^:private +tuple-class+ (str +prefix+ ".Tuple")) @@ -42,8 +48,21 @@ (def ^:private get-writer (fn [state] + ;; (prn 'get-writer (::writer state)) (return* state (::writer state)))) +(defn ^:private with-writer [writer body] + (fn [state] + ;; (prn 'with-writer/_0 body) + (let [result (body (assoc state ::writer writer))] + ;; (prn 'with-writer/_1 result) + (match result + [::&util/ok [?state ?value]] + [::&util/ok [(assoc ?state ::writer (::writer state)) ?value]] + + _ + result)))) + (defn ^:private ->class [class] (string/replace class #"\." "/")) @@ -182,16 +201,20 @@ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class fn-class) "_datum" (->type-signature fn-class)))]] (return nil))) +(def +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;") + (defn ^:private compile-call [compile *type* ?fn ?args] (exec [*writer* get-writer - :let [_ (do (compile ?fn) - (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"] - (doseq [arg ?args] - (compile arg) - (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" apply-signature))))]] + _ (compile ?fn) + _ (map-m (fn [arg] + (exec [ret (compile arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" +apply-signature+)]] + (return ret))) + ?args)] (return nil))) (defn ^:private compile-static-call [compile *type* ?needs-num ?fn ?args] + (assert false (pr-str 'compile-static-call)) (exec [*writer* get-writer :let [_ (match (:form ?fn) [::&analyser/global-fn ?owner-class ?fn-name] @@ -199,14 +222,13 @@ call-class (str (->class ?owner-class) "$" (normalize-ident ?fn-name)) provides-num (count ?args)] (if (>= provides-num ?needs-num) - (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;" - impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)] + (let [impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)] (doto *writer* (-> (do (compile arg)) (->> (doseq [arg (take ?needs-num ?args)]))) (.visitMethodInsn Opcodes/INVOKESTATIC call-class "impl" impl-sig) (-> (doto (do (compile arg)) - (.visitMethodInsn Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" apply-signature)) + (.visitMethodInsn Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" +apply-signature+)) (->> (doseq [arg (drop ?needs-num ?args)]))))) (let [counter-sig "I" init-signature (str "(" (apply str counter-sig (repeat (dec ?needs-num) arg-sig)) ")" "V")] @@ -566,46 +588,47 @@ ex-class (->class "java.lang.IllegalStateException")] (defn ^:private compile-case [compile *type* ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree] (exec [*writer* get-writer - :let [_ (let [start-label (new Label) - end-label (new Label) - entries (for [[?branch ?body] ?branch-mappings - :let [label (new Label)]] - [[?branch label] - [label ?body]]) - mappings* (into {} (map first entries))] - (dotimes [idx ?max-registers] - (.visitLocalVariable *writer* (str "__" (swap! !case-vars inc) "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx)))) - (compile ?variant) - (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLabel start-label)) - (let [default-label (new Label)] - (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] + :let [start-label (new Label) + end-label (new Label) + entries (for [[?branch ?body] ?branch-mappings + :let [label (new Label)]] + [[?branch label] + [label ?body]]) + mappings* (into {} (map first entries)) + _ (dotimes [idx ?max-registers] + (.visitLocalVariable *writer* (str "__" (swap! !case-vars inc) "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx))))] + _ (compile ?variant) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLabel start-label)) + default-label (new Label) + _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] (if (or (:default ?decision-tree) (not (empty? (:defaults ?decision-tree)))) (butlast pieces) pieces))] (compile-decision-tree *writer* mappings* default-label decision-tree)) - (.visitLabel *writer* default-label) - (if-let [[_ [_ _ ?idx] ?body] (or (:default ?decision-tree) - (first (:defaults ?decision-tree)))] - (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitVarInsn Opcodes/ASTORE ?idx) - (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) - (doto *writer* - (.visitInsn Opcodes/POP) - (.visitTypeInsn Opcodes/NEW ex-class) - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "" "()V") - (.visitInsn Opcodes/ATHROW)))) - (doseq [[?label ?body] (map second entries)] - (.visitLabel *writer* ?label) - (.visitInsn *writer* Opcodes/POP) - (compile ?body) - (.visitJumpInsn *writer* Opcodes/GOTO end-label)) - (.visitLabel *writer* end-label) - )]] + (.visitLabel *writer* default-label) + (if-let [[_ [_ _ ?idx] ?body] (or (:default ?decision-tree) + (first (:defaults ?decision-tree)))] + (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) + (doto *writer* + (.visitInsn Opcodes/POP) + (.visitTypeInsn Opcodes/NEW ex-class) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "" "()V") + (.visitInsn Opcodes/ATHROW))))] + _ (map-m (fn [[?label ?body]] + (exec [:let [_ (do (.visitLabel *writer* ?label) + (.visitInsn *writer* Opcodes/POP))] + ret (compile ?body) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO end-label)]] + (return ret))) + (map second entries)) + :let [_ (.visitLabel *writer* end-label)]] (return nil)))) (defn ^:private compile-let [compile *type* ?idx ?label ?value ?body] @@ -622,34 +645,30 @@ (.visitLabel *writer* end-label))]] (return nil))) -(defn compile-field [compile writer loader class-name ?name body] - (let [outer-class (->class class-name) - datum-sig (->type-signature "java.lang.Object") - current-class (str outer-class "$" (normalize-ident ?name))] - (.visitInnerClass writer current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) - (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) - (doto (.visitEnd))) - (-> (.visitMethod Opcodes/ACC_PUBLIC "" "()V" nil nil) - (doto (.visitCode) - (compile body) - (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))) - (.visitEnd)) - bytecode (.toByteArray =class)] - (write-class current-class bytecode) - (load-class! loader (string/replace current-class #"/" "."))) - )) - -(defn ^:private compile-def [compile *type* ?name ?value] +(defn compile-field [compile ?name body] (exec [*writer* get-writer - *class-name* &analyser/module-name - loader &util/loader - :let [_ (compile-field compile *writer* loader *class-name* ?name ?value)]] + class-name &analyser/module-name + :let [outer-class (->class class-name) + datum-sig (->type-signature "java.lang.Object") + current-class (str outer-class "$" (normalize-ident ?name)) + _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + current-class nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) + (doto (.visitEnd))))] + _ (with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) + (exec [*writer* get-writer + :let [_ (.visitCode *writer*)] + _ (compile body) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (save-class! current-class (.toByteArray =class))] (return nil))) (defn ^:private captured? [form] @@ -659,142 +678,216 @@ _ false)) -(defn ^:private compile-lambda [compile *type* ?scope ?frame ?args ?body] - (exec [*writer* get-writer - loader &util/loader - :let [_ (let [num-args (count ?args) - clo-field-sig (->type-signature "java.lang.Object") - counter-sig "I" - apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;" - real-signature (str "(" (apply str (repeat num-args clo-field-sig)) ")" "Ljava/lang/Object;") - current-class (apply str (interpose "$" (map (comp normalize-ident str) ?scope))) - num-captured (dec num-args) - init-signature (str "(" (apply str (repeat (->> (:mappings ?frame) - (map (comp :form second)) - (filter captured?) - count) - clo-field-sig)) - (if (not= 0 num-captured) - (apply str counter-sig (repeat num-captured clo-field-sig))) - ")" - "V") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str "__" ?captured-id)]) - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] (:mappings ?frame) - :when (captured? (:form ?captured))]))) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) - (.visitEnd)) - (->> (when (not= 0 num-captured))))) - =init (doto (.visitMethod =class Opcodes/ACC_PUBLIC "" init-signature nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) - (.visitFieldInsn Opcodes/PUTFIELD current-class captured-name clo-field-sig)) - (->> (let [captured-name (str "__" ?captured-id)]) - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] (:mappings ?frame) - :when (captured? (:form ?captured))]))) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD (inc (count (:mappings ?frame)))) - (.visitFieldInsn Opcodes/PUTFIELD current-class "_counter" counter-sig) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset)) - (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig)) - (->> (let [field-name (str "_" clo_idx)] - (doto (.visitField =class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil) - (.visitEnd))) - (dotimes [clo_idx num-captured]) - (let [offset (+ 2 (count (:mappings ?frame)))])))) - (->> (when (not= 0 num-captured)))) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - =method (let [default-label (new Label) - branch-labels (for [_ (range num-captured)] - (new Label))] - (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig) - (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels)) - (-> (doto (.visitLabel branch-label) - (.visitTypeInsn Opcodes/NEW current-class) - (.visitInsn Opcodes/DUP) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD current-class (str "__" capt_idx) clo-field-sig)) - (->> (dotimes [capt_idx (count (:mappings ?frame))]))) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD current-class "_counter" counter-sig) - (.visitInsn Opcodes/ICONST_1) - (.visitInsn Opcodes/IADD) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) - (->> (dotimes [clo_idx current-captured]))) - (.visitVarInsn Opcodes/ALOAD 1) - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [clo_idx (- (dec num-captured) current-captured)]))) - (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "" init-signature) - (.visitInsn Opcodes/ARETURN)) - (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))]))) - (.visitLabel default-label) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig)) - (->> (dotimes [clo_idx num-captured])))) - (->> (when (not= 0 num-captured)))) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL current-class "impl" real-signature) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - =impl (doto (.visitMethod =class Opcodes/ACC_PUBLIC "impl" real-signature nil nil) - (.visitCode) - (compile ?body) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (.visitEnd =class) - bytecode (.toByteArray =class)] - (write-class current-class bytecode) - (load-class! loader (string/replace current-class #"/" ".")) - (doto *writer* - (.visitTypeInsn Opcodes/NEW current-class) - (.visitInsn Opcodes/DUP) - (-> (do (compile ?source)) - (->> (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] (->> (:mappings ?frame) - (filter (comp captured? :form second)) - (sort #(< (-> %1 second :form (nth 2)) - (-> %2 second :form (nth 2)))))]))) - (-> (doto (.visitInsn Opcodes/ICONST_0) - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (doseq [_ (butlast ?args)])))) - (->> (when (> (count ?args) 1)))) - (.visitMethodInsn Opcodes/INVOKESPECIAL current-class "" init-signature)) - )]] +(let [clo-field-sig (->type-signature "java.lang.Object") + lambda-return-sig (->type-signature "java.lang.Object") + -return "V" + counter-sig "I" + +datum-sig+ (->type-signature "java.lang.Object")] + (defn lambda-impl-signature [args] + (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig)) + + (defn lambda--signature [closed-over args] + (let [num-args (count args)] + (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig)) + (if (> num-args 1) + (reduce str counter-sig (repeat num-args clo-field-sig))) + ")" + -return))) + + (defn add-lambda- [class class-name closed-over args init-signature] + (let [num-args (count args) + num-mappings (count closed-over)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "" init-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str "__" ?captured-id)]) + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] closed-over + :when (captured? (:form ?captured))]))) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD (inc num-mappings)) + (.visitFieldInsn Opcodes/PUTFIELD class-name "_counter" counter-sig) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset)) + (.visitFieldInsn Opcodes/PUTFIELD class-name field-name clo-field-sig)) + (->> (let [field-name (str "_" clo_idx)] + (doto (.visitField class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil) + (.visitEnd))) + (dotimes [clo_idx (dec num-args)]) + (let [offset (+ 2 num-mappings)])))) + (->> (when (> num-args 1)))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + + (defn add-lambda-apply [class class-name closed-over args impl-signature init-signature] + (let [num-args (count args) + num-captured (dec num-args) + default-label (new Label) + branch-labels (for [_ (range num-captured)] + (new Label))] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig) + (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels)) + (-> (doto (.visitLabel branch-label) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name (str "__" capt_idx) clo-field-sig)) + (->> (dotimes [capt_idx (count closed-over)]))) + (.visitLdcInsn (-> current-captured inc int)) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig)) + (->> (dotimes [clo_idx current-captured]))) + (.visitVarInsn Opcodes/ALOAD 1) + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (dotimes [clo_idx (- (dec num-captured) current-captured)]))) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" init-signature) + (.visitInsn Opcodes/ARETURN)) + (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))]))) + (.visitLabel default-label) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name (str "_" clo_idx) clo-field-sig)) + (->> (dotimes [clo_idx num-captured])))) + (->> (when (> num-args 1)))) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + + (defn add-lambda-impl [class compile impl-signature impl-body] + (with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) + (.visitCode)) + (exec [;; :let [_ (prn 'add-lambda-impl/_0)] + *writer* get-writer + ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)] + ret (compile impl-body) + ;; :let [_ (prn 'add-lambda-impl/_2 ret)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + ;; :let [_ (prn 'add-lambda-impl/_3)] + ] + (return ret)))) + + (defn instance-closure [compile lambda-class closed-over args init-signature] + (exec [*writer* get-writer + :let [;; _ (prn 'instance-closure/*writer* *writer*) + num-args (count args) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW lambda-class) + (.visitInsn Opcodes/DUP))] + _ (map-m (fn [[?name ?captured]] + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source] + (compile ?source))) + (->> closed-over + (filter (comp captured? :form second)) + (sort #(< (-> %1 second :form (nth 2)) + (-> %2 second :form (nth 2)))))) + :let [_ (do (when (> num-args 1) + (.visitInsn *writer* Opcodes/ICONST_0) + (dotimes [_ (dec num-args)] + (.visitInsn *writer* Opcodes/ACONST_NULL))) + (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature))]] + (return nil))) + + (defn ^:private compile-lambda [compile *type* ?scope ?closure ?args ?body] + (exec [:let [current-class (reduce str "" (interpose "$" (map normalize-ident ?scope))) + impl-signature (lambda-impl-signature ?args) + init-signature (lambda--signature ?closure ?args) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + current-class nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str "__" ?captured-id)]) + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] ?closure + :when (captured? (:form ?captured))]))) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) + (.visitEnd)) + (->> (when (> (count ?args) 1)))) + (add-lambda- current-class ?closure ?args init-signature) + (add-lambda-apply current-class ?closure ?args impl-signature init-signature))] + _ (add-lambda-impl =class compile impl-signature ?body) + :let [_ (.visitEnd =class)] + _ (save-class! current-class (.toByteArray =class))] + (instance-closure compile current-class ?closure ?args init-signature))) + + (defn ^:private add-lambda- [class class-name args -sig] + (let [num-args (count args)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "" "()V" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (doto (.visitLdcInsn (int 0)) + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (dotimes [_ (dec num-args)])))) + (->> (when (> num-args 1)))) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" -sig) + (.visitFieldInsn Opcodes/PUTSTATIC class-name "_datum" +datum-sig+) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + + (defn ^:private compile-method [compile ?name ?value] + (match (:form ?value) + [::&analyser/lambda ?scope ?env ?args ?body] + (exec [*writer* get-writer + outer-class &analyser/module-name + :let [class-name (str outer-class "$" (normalize-ident ?name)) + _ (.visitInnerClass *writer* class-name outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) + impl-signature (lambda-impl-signature ?args) + -sig (lambda--signature ?env ?args) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + class-name nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) + (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) + (.visitEnd)) + (->> (when (> (count ?args) 1)))) + (add-lambda-apply class-name ?env ?args impl-signature -sig) + (add-lambda- class-name ?env ?args -sig) + (add-lambda- class-name ?args -sig))] + _ (add-lambda-impl =class compile impl-signature ?body) + :let [_ (.visitEnd =class)] + _ (save-class! class-name (.toByteArray =class))] + (return nil)))) + ) + +(defn ^:private compile-def [compile *type* ?name ?value] + (exec [;; :let [_ (prn 'compile-def ?name ?value)] + _ (match (:form ?value) + [::&analyser/lambda ?scope ?captured ?args ?body] + (compile-method compile ?name ?value) + + _ + (compile-field compile ?name ?value))] (return nil))) (defn ^:private compile-defclass [compile *type* ?package ?name ?super-class ?members] (exec [*writer* get-writer loader &util/loader - :let [_ (let [parent-dir (->package ?package) - super-class* (->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str parent-dir "/" ?name) nil super-class* nil))] - (doseq [[field props] (:fields ?members)] - (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil) - (.visitEnd))) + :let [parent-dir (->package ?package) + super-class* (->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str parent-dir "/" ?name) nil super-class* nil)) + _ (do (doseq [[field props] (:fields ?members)] + (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil) + (.visitEnd))) (doto (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (.visitCode) (.visitVarInsn Opcodes/ALOAD 0) @@ -803,27 +896,25 @@ (.visitMaxs 0 0) (.visitEnd)) (.visitEnd =class) - (.mkdirs (java.io.File. (str "output/" parent-dir))) - (write-class (str parent-dir "/" ?name) (.toByteArray =class)) - (load-class! loader (string/replace (str parent-dir "/" ?name) #"/" ".")))]] + (.mkdirs (java.io.File. (str "output/" parent-dir))))] + _ (save-class! (str parent-dir "/" ?name) (.toByteArray =class))] (return nil))) (defn ^:private compile-definterface [compile *type* ?package ?name ?members] (exec [*writer* get-writer loader &util/loader - :let [_ (let [parent-dir (->package ?package) - =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE ;; Opcodes/ACC_ABSTRACT - ) - (str parent-dir "/" ?name) nil "java/lang/Object" nil))] - (doseq [[?method ?props] (:methods ?members) - :let [[?args ?return] (:type ?props) - signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]] - (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) + :let [parent-dir (->package ?package) + =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE ;; Opcodes/ACC_ABSTRACT + ) + (str parent-dir "/" ?name) nil "java/lang/Object" nil)) + _ (do (doseq [[?method ?props] (:methods ?members) + :let [[?args ?return] (:type ?props) + signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]] + (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) (.visitEnd =interface) - (.mkdirs (java.io.File. (str "output/" parent-dir))) - (write-class (str parent-dir "/" ?name) (.toByteArray =interface)) - (load-class! loader (string/replace (str parent-dir "/" ?name) #"/" ".")))]] + (.mkdirs (java.io.File. (str "output/" parent-dir))))] + _ (save-class! (str parent-dir "/" ?name) (.toByteArray =interface))] (return nil))) (defn ^:private compile-variant [compile *type* ?tag ?members] @@ -847,16 +938,17 @@ (do-template [ ] (defn [compile *type* ?x ?y] (exec [*writer* get-writer - :let [_ (do (compile ?x) - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +int-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +int-class+ "intValue" "()I")) - (compile ?y) - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +int-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +int-class+ "intValue" "()I") - (.visitInsn ) - (.visitMethodInsn Opcodes/INVOKESTATIC +int-class+ "valueOf" (str "(I)" (->type-signature "java.lang.Integer")))))]] + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +int-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +int-class+ "intValue" "()I"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +int-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +int-class+ "intValue" "()I")) + _ (doto *writer* + (.visitInsn ) + (.visitMethodInsn Opcodes/INVOKESTATIC +int-class+ "valueOf" (str "(I)" (->type-signature "java.lang.Integer"))))]] (return nil))) ^:private compile-jvm-iadd Opcodes/IADD @@ -866,6 +958,19 @@ ^:private compile-jvm-irem Opcodes/IREM )) +(defn compile-self-call [?scope ?assumed-args] + (exec [*writer* get-writer + :let [lambda-class (->class (reduce str "" (interpose "$" (map normalize-ident ?scope)))) + _ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC lambda-class "_datum" (->type-signature "java.lang.Object")) + (.visitTypeInsn Opcodes/CHECKCAST lambda-class))] + _ (map-m (fn [arg] + (exec [ret (compile arg) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" +apply-signature+)]] + (return ret))) + ?assumed-args)] + (return nil))) + (defn ^:private compile [syntax] (match (:form syntax) [::&analyser/literal ?literal] @@ -913,19 +1018,19 @@ [::&analyser/def ?form ?body] (compile-def compile (:type syntax) ?form ?body) - [::&analyser/jvm-iadd ?x ?y] + [::&analyser/jvm:iadd ?x ?y] (compile-jvm-iadd compile (:type syntax) ?x ?y) - [::&analyser/jvm-isub ?x ?y] + [::&analyser/jvm:isub ?x ?y] (compile-jvm-isub compile (:type syntax) ?x ?y) - [::&analyser/jvm-imul ?x ?y] + [::&analyser/jvm:imul ?x ?y] (compile-jvm-imul compile (:type syntax) ?x ?y) - [::&analyser/jvm-idiv ?x ?y] + [::&analyser/jvm:idiv ?x ?y] (compile-jvm-idiv compile (:type syntax) ?x ?y) - [::&analyser/jvm-irem ?x ?y] + [::&analyser/jvm:irem ?x ?y] (compile-jvm-irem compile (:type syntax) ?x ?y) [::&analyser/do ?exprs] @@ -951,6 +1056,9 @@ [::&analyser/defclass [?package ?name] ?super-class ?members] (compile-defclass compile (:type syntax) ?package ?name ?super-class ?members) + + [::&analyser/self ?scope ?assumed-args] + (compile-self-call ?scope ?assumed-args) )) ;; [Interface] @@ -971,9 +1079,7 @@ [::&util/ok [?state ?forms]] (if (empty? (::&lexer/source ?state)) (do (.visitEnd =class) - (write-class name (.toByteArray =class)) - (load-class! loader (string/replace name #"/" ".")) - [::&util/ok [?state nil]]) + ((save-class! name (.toByteArray =class)) ?state)) (assert false (str "[Compiler Error] Can't compile: " (::&lexer/source ?state)))) [::&util/failure ?message] @@ -982,6 +1088,7 @@ (defn compile-all [modules] (let [state {::&lexer/source nil ::&analyser/current-module nil + ::&analyser/scope [] ::&analyser/modules {} ::&analyser/global-env {} ::&analyser/local-envs (list) -- cgit v1.2.3