From e4bcdcda60fec97622217840d54ae9ee2c121f72 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 19 Dec 2014 14:30:25 -0400 Subject: Almost finished implementing closures. --- src/lang.clj | 2 +- src/lang/analyser.clj | 129 +++++++++++++++++++++++++++++++++++--------------- src/lang/compiler.clj | 54 ++++++++++++++++----- 3 files changed, 134 insertions(+), 51 deletions(-) (limited to 'src') diff --git a/src/lang.clj b/src/lang.clj index e602a21a6..0a958203b 100644 --- a/src/lang.clj +++ b/src/lang.clj @@ -13,7 +13,7 @@ (comment ;; TODO: Allow "lambdas" to be closures. ;; TODO: Add Java-interop. - ;; TODO: Allow loading classes at runtime. + ;; TODO: Allow loading classes/modules at runtime. ;; TODO: Add macros. ;; TODO: Re-implement compiler in language. ;; TODO: Add signatures & structures OR type-classes. diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj index bc48a0c81..109ba15f6 100644 --- a/src/lang/analyser.clj +++ b/src/lang/analyser.clj @@ -16,6 +16,12 @@ {:form form :type type}) +(defn ^:private fresh-env [id] + {:id id + :counter 0 + :mappings {} + :closure/id 0}) + (def ^:private module-name (fn [state] [::&util/ok [state (:name state)]])) @@ -24,42 +30,52 @@ (fn [state] [::&util/ok [(-> state (assoc-in [:defs (:name state) name] desc) - (assoc-in [:env :mappings name] (annotated [::global (:name state) name] (:type desc)))) nil]])) + (assoc-in [:defs-env name] (annotated [::global (:name state) name] (:type desc)))) + nil]])) (def ^:private next-local-idx (fn [state] - [::&util/ok [state (-> state :env :counter)]])) + [::&util/ok [state (-> state :env first :counter)]])) + +(def ^:private my-frame + (fn [state] + [::&util/ok [state (-> state :env first)]])) (defn ^:private with-local [name type body] (fn [state] - (let [=return (body (update-in state [:env] #(-> % - (update-in [:counter] inc) - (assoc-in [:mappings name] (annotated [::local (:counter %)] type)))))] + (let [=return (body (update-in state [:env] + #(cons (-> (first %) + (update-in [:counter] inc) + (assoc-in [:mappings name] (annotated [::local (:id (first %)) (:counter (first %))] type))) + (rest %))))] + ;; =return (match =return [::&util/ok [?state ?value]] - [::&util/ok [(assoc ?state :env (:env state)) ?value]] + (do (prn 'POST-WITH-LOCAL name (-> ?state :env first)) + [::&util/ok [(update-in ?state [:env] #(cons (-> (first %) + (update-in [:counter] dec) + (update-in [:mappings] dissoc name)) + (rest %))) + ;; (update-in ?state [:env] (fn [[top & oframes]] + ;; (prn 'NEW-FRAMES name (cons (-> state :env first (assoc :closure (-> top :closure))) oframes)) + ;; (cons (-> state :env first (assoc :closure (-> top :closure))) oframes))) + ?value]]) _ - =return)))) + =return) + ))) (defn ^:private with-fresh-env [body] (fn [state] - (let [=return (body (update-in state [:env] - #(-> % - (assoc :counter 0) - (update-in [:mappings] (fn [ms] - (let [ms* (into {} (for [[k v] ms - :when (match (:form v) - [::local _] - false - _ - true)] - [k v]))] - ;; (prn 'ms ms 'ms* ms*) - ms*))))))] + ;; (prn '(:env state) (:env state) (-> state :env first :id inc)) + (let [=return (body (update-in state [:env] #(conj % (fresh-env (-> % first :id inc))))) + ;; _ (prn '=return =return) + ] (match =return [::&util/ok [?state ?value]] - [::&util/ok [(assoc ?state :env (:env state)) ?value]] + (do (prn 'PRE-LAMBDA (:env state)) + (prn 'POST-LAMBDA (:env ?state) ?value) + [::&util/ok [(assoc ?state :env (:env state)) [(-> ?state :env first) ?value]]]) _ =return)))) @@ -67,8 +83,8 @@ (defn ^:private import-class [long-name short-name] (fn [state] (let [=class (annotated [::class long-name] ::&type/nothing)] - [::&util/ok [(update-in state [:env :mappings] merge {long-name =class, - short-name =class}) + [::&util/ok [(update-in state [:imports] merge {long-name =class, + short-name =class}) nil]]))) (defn ^:private require-module [name alias] @@ -76,15 +92,42 @@ [::&util/ok [(assoc-in state [:deps alias] name) nil]])) +(defn ^:private close-over [ident register frame] + (prn 'close-over ident register) + (let [register* (annotated [::captured (:id frame) (:closure/id frame) register] (:type register))] + [register* (-> frame + (update-in [:closure/id] inc) + (assoc-in [:mappings ident] register*))])) + (defn ^:private resolve [ident] (fn [state] (if-let [[_ ?alias ?binding] (re-find #"^(.*)/(.*)$" ident)] (let [?module (get-in state [:deps ?alias])] ;; (prn 'resolve ?module ?alias ?binding) [::&util/ok [state (annotated [::global ?module ?binding] ::&type/nothing)]]) - (if-let [resolved (get-in state [:env :mappings ident])] - [::&util/ok [state resolved]] - [::&util/failure (str "Unresolved identifier: " ident)])))) + (let [_ (prn 'resolve/_1 ident) + [inner outer] (split-with #(nil? (get-in % [:mappings ident])) (:env state)) + ;; _ (prn ident '[inner outer] [inner outer]) + _ (prn 'resolve/_2 '[inner outer] [inner outer])] + (cond (empty? inner) + [::&util/ok [state (-> state :env first :mappings (get ident))]] + + (empty? outer) + (if-let [global|import (or (get-in state [:defs-env ident]) + (get-in state [:imports ident]))] + (do (prn 'resolve/_3 'global|import global|import) + [::&util/ok [state global|import]]) + [::&util/failure (str "Unresolved identifier: " ident)]) + + :else + (let [[=local inner*] (reduce (fn [[register new-inner] frame] + (let [[register* frame*] (close-over ident register frame)] + [register* (cons frame* new-inner)])) + [(-> outer first :mappings (get ident)) '()] + (reverse inner)) + _ (prn 'resolve/_4 '[=local inner*] =local inner*)] + [::&util/ok [(assoc state :env (concat inner* outer)) =local]]))) + ))) (defmacro ^:private defanalyser [name match return] `(def ~name @@ -136,10 +179,13 @@ (defanalyser analyse-ident [::&parser/ident ?ident] - (exec [_env (fn [state] [::&util/ok [state (:env state)]]) - ;; :let [_ (prn 'analyse-ident ?ident _env)] - ] - (resolve ?ident))) + ;; (exec [_env (fn [state] [::&util/ok [state (:env state)]]) + ;; ;; :let [_ (prn 'analyse-ident ?ident _env)] + ;; ] + ;; (resolve ?ident)) + (exec [=ident (resolve ?ident) + :let [_ (prn 'analyse-ident ?ident =ident)]] + (return =ident))) (defanalyser analyse-ann-class [::&parser/ann-class ?class ?members] @@ -277,19 +323,22 @@ [=function =args =return] (within :types (&type/fresh-function (count ?args))) ;; :let [_ (prn '[=function =args =return] [=function =args =return])] ;; :let [_ (prn 'PRE/?body ?body)] - _env (fn [state] [::&util/ok [state (:env state)]]) + ;; _env (fn [state] [::&util/ok [state (:env state)]]) ;; :let [_ (prn 'analyse-lambda _env)] - =body (with-fresh-env - (reduce (fn [inner [label type]] - (with-local label type inner)) - (analyse-form* ?body) - (reverse (map vector ?args =args)))) + [=frame =body] (with-fresh-env + (reduce (fn [inner [label type]] + (exec [=inner (with-local label type inner) + =frame* my-frame + :let [_ (prn '=frame* =frame*)]] + (return =inner))) + (analyse-form* ?body) + (reverse (map vector ?args =args)))) ;; :let [_ (prn '=body =body)] =function (within :types (exec [_ (&type/solve =return (:type =body))] (&type/clean =function))) ;; :let [_ (prn '=function =function)] ] - (return (annotated [::lambda ?args =body] =function)))) + (return (annotated [::lambda =frame ?args =body] =function)))) (defanalyser analyse-import [::&parser/import ?class] @@ -334,8 +383,10 @@ (match ((repeat-m analyse-form) {:name module-name, :forms tokens :deps {} - :env {:counter 0 - :mappings {}} + :imports {} + :defs {} + :defs-env {} + :env (list (fresh-env 0)) :types &type/+init+}) [::&util/ok [?state ?forms]] (if (empty? (:forms ?state)) diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj index 9de072bc0..f2c57f410 100644 --- a/src/lang/compiler.clj +++ b/src/lang/compiler.clj @@ -118,11 +118,18 @@ (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str "_" idx) "Ljava/lang/Object;"))))) (defcompiler ^:private compile-local - [::&analyser/local ?idx] - (do ;; (prn 'LOCAL ?idx) + [::&analyser/local ?env ?idx] + (do (prn 'LOCAL ?idx) (doto *writer* (.visitVarInsn Opcodes/ALOAD (int ?idx))))) +(defcompiler ^:private compile-captured + [::&analyser/captured ?closure-id ?captured-id ?source] + (do (prn 'CAPTURED [?closure-id ?captured-id]) + (doto *writer* + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD (str "test2" "$" "lambda") (str "__" (inc ?captured-id)) "Ljava/lang/Object;")))) + (defcompiler ^:private compile-global [::&analyser/global ?owner-class ?name] (do ;; (prn 'GLOBAL ?owner-class ?name *type*) @@ -408,8 +415,9 @@ ))) (defcompiler ^:private compile-lambda - [::&analyser/lambda ?args ?body] - (let [num-args (count ?args) + [::&analyser/lambda ?frame ?args ?body] + (let [_ (prn '?frame ?frame) + num-args (count ?args) outer-class (->class *class-name*) clo-field-sig (->type-signature "java.lang.Object") counter-sig "I" @@ -418,7 +426,9 @@ current-class (str outer-class "$" "lambda") num-captured (dec num-args) init-signature (if (not= 0 num-captured) - (str "(" (apply str counter-sig (repeat num-captured clo-field-sig)) ")" "V") + (str "(" (apply str (repeat (count (:mappings ?frame)) clo-field-sig)) + counter-sig + (apply str (repeat num-captured clo-field-sig)) ")" "V") (str "()" "V"))] ;; (.visitInnerClass *parent* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -431,16 +441,27 @@ (.visitCode) (.visitVarInsn Opcodes/ALOAD 0) (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) + (-> (doto (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD current-class captured-name clo-field-sig)) + (do (doto =class + (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) + (.visitEnd))) + (->> (let [captured-name (str "__" (inc ?captured-id))]) + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] (:mappings ?frame)]))) + (.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 2)) + (.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])))) + (dotimes [clo_idx num-captured]) + (let [offset (+ 2 (count (:mappings ?frame)))])))) (->> (when (not= 0 num-captured)))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -450,12 +471,16 @@ (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 "__" (inc 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) @@ -478,12 +503,14 @@ (->> (dotimes [clo_idx num-captured])))) (->> (when (not= 0 num-captured)))) (.visitVarInsn Opcodes/ALOAD 1) - (.visitMethodInsn Opcodes/INVOKESTATIC current-class "impl" real-signature) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL current-class "impl" real-signature) ;; (.visitLabel end-label) (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd))) - =impl (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "impl" real-signature nil nil) + _ (prn 'LAMBDA/?body ?body) + =impl (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC ;; Opcodes/ACC_STATIC + ) "impl" real-signature nil nil) (.visitCode) (->> (assoc *state* :form ?body :writer) compile-form) @@ -495,6 +522,10 @@ (doto *writer* (.visitTypeInsn Opcodes/NEW current-class) (.visitInsn Opcodes/DUP) + (-> (do (compile-form (assoc *state* :form ?source))) + (->> (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] (:mappings ?frame)]))) (-> (doto (.visitInsn Opcodes/ICONST_0) ;; (.visitInsn Opcodes/ICONST_0) (-> (.visitInsn Opcodes/ACONST_NULL) @@ -581,6 +612,7 @@ compile-variant compile-tuple compile-local + compile-captured compile-global compile-call compile-static-access -- cgit v1.2.3