diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/lux/compiler/lambda.clj | 69 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 80 | ||||
| -rw-r--r-- | src/lux/type.clj | 64 |
3 files changed, 112 insertions, 101 deletions
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 8fefab156..86bc08534 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -60,19 +60,20 @@ (.visitMaxs 0 0) (.visitEnd))) -(defn ^:private add-lambda-impl [class compile impl-signature impl-body] - (&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) - (.visitCode)) - (|do [^MethodVisitor *writer* &/get-writer - :let [$start (new Label) - $end (new Label)] - ret (compile impl-body) - :let [_ (doto *writer* - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))) +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] + (defn ^:private add-lambda-impl [class compile impl-signature impl-body] + (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" impl-signature nil nil) + (.visitCode)) + (|do [^MethodVisitor *writer* &/get-writer + :let [$start (new Label) + $end (new Label)] + ret (compile impl-body) + :let [_ (doto *writer* + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret))))) (defn ^:private instance-closure [compile lambda-class closed-over init-signature] (|do [^MethodVisitor *writer* &/get-writer @@ -88,23 +89,25 @@ (return nil))) ;; [Exports] -(defn compile-lambda [compile ?scope ?env ?body] - ;; (prn 'compile-lambda (->> ?scope &/->seq)) - (|do [:let [name (&host/location (&/|tail ?scope)) - class-name (str (&host/->module-class (&/|head ?scope)) "/" name) - =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 [&&/function-class])) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) - (doseq [?name+?captured (&/->seq ?env)]))) - (add-lambda-apply class-name ?env) - (add-lambda-<init> class-name ?env) - )] - _ (add-lambda-impl =class compile lambda-impl-signature ?body) - :let [_ (.visitEnd =class)] - _ (&&/save-class! name (.toByteArray =class))] - (instance-closure compile class-name ?env (lambda-<init>-signature ?env)))) +(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-lambda [compile ?scope ?env ?body] + ;; (prn 'compile-lambda (->> ?scope &/->seq)) + (|do [:let [name (&host/location (&/|tail ?scope)) + class-name (str (&host/->module-class (&/|head ?scope)) "/" name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 lambda-flags + class-name nil "java/lang/Object" (into-array [&&/function-class])) + (-> (doto (.visitField datum-flags captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [(&a/$captured _ ?captured-id ?source) _]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (add-lambda-apply class-name ?env) + (add-lambda-<init> class-name ?env) + )] + _ (add-lambda-impl =class compile lambda-impl-signature ?body) + :let [_ (.visitEnd =class)] + _ (&&/save-class! name (.toByteArray =class))] + (instance-closure compile class-name ?env (lambda-<init>-signature ?env))))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index c17d10494..e85af8b0d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -175,45 +175,47 @@ (return nil))) ))) -(defn compile-def [compile ?name ?body] - (|do [:let [=value-type (&a/expr-type* ?body) - def-type (cond (&type/type= &type/Type =value-type) - "type" - - :else - "value")] - ^ClassWriter *writer* &/get-writer - module-name &/get-module-name - :let [datum-sig "Ljava/lang/Object;" - def-name (&/normalize-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =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 [&&/function-class])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/datum-field datum-sig nil nil) - (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/meta-field datum-sig nil nil) - (doto (.visitEnd))))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (compile ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] - _ (compile-def-type compile current-class ?body def-type) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd *writer*)] - _ (&&/save-class! def-name (.toByteArray =class)) - class-loader &/loader - :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] - _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] - (return nil))) +(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] + (defn compile-def [compile ?name ?body] + (|do [:let [=value-type (&a/expr-type* ?body) + def-type (cond (&type/type= &type/Type =value-type) + "type" + + :else + "value")] + ^ClassWriter *writer* &/get-writer + module-name &/get-module-name + :let [datum-sig "Ljava/lang/Object;" + def-name (&/normalize-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 class-flags + current-class nil "java/lang/Object" (into-array [&&/function-class])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/datum-field datum-sig nil nil) + (doto (.visitEnd))) + (-> (.visitField field-flags &/meta-field datum-sig nil nil) + (doto (.visitEnd))))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] + _ (compile-def-type compile current-class ?body def-type) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (&&/save-class! def-name (.toByteArray =class)) + class-loader &/loader + :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] + _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] + (return nil)))) (defn compile-ann [compile *type* ?value-ex ?type-ex] (compile ?value-ex)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 889d4fc47..4672b18d4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -739,35 +739,35 @@ (check* class-loader fixpoints eA aA) (fail (check-error expected actual))) - [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] - (fn [state] - (|case ((|do [F1 (deref ?eid)] - (fn [state] - (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((check* class-loader fixpoints (App$ F1 A1) actual) - state)))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (App$ F2 A2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) - [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) - state)))) + ;; [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] + ;; (fn [state] + ;; (|case ((|do [F1 (deref ?eid)] + ;; (fn [state] + ;; (|case ((|do [F2 (deref ?aid)] + ;; (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; ((check* class-loader fixpoints (App$ F1 A1) actual) + ;; state)))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; (|case ((|do [F2 (deref ?aid)] + ;; (check* class-loader fixpoints expected (App$ F2 A2))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) + ;; [fixpoints** _] (check* class-loader fixpoints* A1 A2)] + ;; (return (&/T fixpoints** nil))) + ;; state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] @@ -788,6 +788,7 @@ [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) + ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) @@ -810,6 +811,7 @@ [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) + ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) @@ -817,6 +819,10 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) + ;; [(&/$AppT eF eA) (&/$AppT aF aA)] + ;; (|do [_ (check* class-loader fixpoints eF aF)] + ;; (check* class-loader fixpoints eA aA)) + [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) |