aboutsummaryrefslogtreecommitdiff
path: root/src/lang
diff options
context:
space:
mode:
Diffstat (limited to 'src/lang')
-rw-r--r--src/lang/analyser.clj129
-rw-r--r--src/lang/compiler.clj54
2 files changed, 133 insertions, 50 deletions
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" "<init>" "()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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 16:58:46 +0000