aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/compiler.clj2
-rw-r--r--src/lux/compiler/lambda.clj54
-rw-r--r--src/lux/compiler/lux.clj242
-rw-r--r--src/lux/optimizer.clj11
4 files changed, 209 insertions, 100 deletions
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 27bb42e4f..b9acff72a 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -86,7 +86,7 @@
(&&case/compile-case compile-expression ?value ?match)
(&o/$function ?arity ?scope ?env ?body)
- (&&lambda/compile-function compile-expression ?arity ?scope ?env ?body)
+ (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body)
;; Must get rid of this one...
(&o/$ann ?value-ex ?type-ex ?value-type)
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 7ba93a32b..d291ebc07 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -237,33 +237,45 @@
;; [Exports]
(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)]
- (defn compile-function [compile arity ?scope ?env ?body]
+ (defn compile-function [compile ?prev-writer arity ?scope ?env ?body]
(|do [[file-name _ _] &/cursor
:let [name (&host/location (&/|tail ?scope))
class-name (str (&host/->module-class (&/|head ?scope)) "/" name)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version lambda-flags
- class-name nil &&/function-class (into-array String []))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity))
- (doto (.visitEnd)))
- (-> (doto (.visitField datum-flags captured-name field-sig nil nil)
- (.visitEnd))
- (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
- (|case ?name+?captured
- [?name [_ (&o/$captured _ ?captured-id ?source)]])
- (doseq [?name+?captured (&/->seq ?env)])))
- (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil)
- (doto (.visitEnd))
- (->> (dotimes [idx (dec arity)])))
- (.visitSource file-name nil)
- (add-lambda-<init> class-name arity ?env)
- (add-lambda-reset class-name arity ?env)
- )]
+ [=class save?] (|case ?prev-writer
+ (&/$Some _writer)
+ (&/T [_writer false])
+
+ (&/$None)
+ (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version lambda-flags
+ class-name nil &&/function-class (into-array String [])))
+ true]))
+ _ (doto =class
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity))
+ (doto (.visitEnd)))
+ (-> (doto (.visitField datum-flags captured-name field-sig nil nil)
+ (.visitEnd))
+ (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
+ (|case ?name+?captured
+ [?name [_ (&o/$captured _ ?captured-id ?source)]])
+ (doseq [?name+?captured (&/->seq ?env)])))
+ (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil)
+ (doto (.visitEnd))
+ (->> (dotimes [idx (dec arity)])))
+ (-> (.visitSource file-name nil)
+ (when save?))
+ (add-lambda-<init> class-name arity ?env)
+ (add-lambda-reset class-name arity ?env)
+ )]
_ (if (> arity 1)
(add-lambda-impl =class class-name compile arity ?body)
(return nil))
_ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body)
(&/|range* 1 (min arity &&/num-apply-variants)))
:let [_ (.visitEnd =class)]
- _ (&&/save-class! name (.toByteArray =class))]
- (instance-closure compile class-name arity ?env))))
+ _ (if save?
+ (&&/save-class! name (.toByteArray =class))
+ (return nil))]
+ (if save?
+ (instance-closure compile class-name arity ?env)
+ (return (instance-closure compile class-name arity ?env))))))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index f2c67bfae..2cbfcef54 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -165,6 +165,14 @@
(|let [analysis (&&type/defmeta->analysis ?meta)]
(compile analysis)))
+(defn ^:private de-ann [optim]
+ (|case optim
+ [_ (&o/$ann value-expr _ _)]
+ value-expr
+
+ _
+ optim))
+
(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 ?meta]
@@ -186,85 +194,171 @@
(fail "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.")
_
- (|do [:let [=value-type (&a/expr-type* ?body)]
- ;; ^ClassWriter *writer* &/get-writer
- [file-name _ _] &/cursor
- :let [datum-sig "Ljava/lang/Object;"
- def-name (&host/def-name ?name)
- current-class (str (&host/->module-class module-name) "/" def-name)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version class-flags
- current-class nil "java/lang/Object" (into-array String []))
- (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
- (doto (.visitEnd)))
- (-> (.visitField field-flags &/type-field datum-sig nil nil)
- (doto (.visitEnd)))
- (-> (.visitField field-flags &/meta-field datum-sig nil nil)
- (doto (.visitEnd)))
- (-> (.visitField field-flags &/value-field datum-sig nil nil)
- (doto (.visitEnd)))
- (.visitSource file-name nil))]
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor **writer** &/get-writer
- :let [_ (.visitCode **writer**)]
- _ (compile-def-type compile ?body)
- :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/type-field datum-sig)]
- _ (compile-def-meta compile ?meta)
- :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
- _ (compile ?body)
- :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)]
- :let [_ (doto **writer**
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))
- ;; :let [_ (.visitEnd *writer*)]
- :let [_ (.visitEnd =class)]
- _ (&&/save-class! def-name (.toByteArray =class))
- :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
- [def-type is-type?] (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
- (&/$Some (&/$BoolM true))
- (&/T [&type/Type
- true])
-
- _
- (if (&type/type= &type/Type =value-type)
- (&/T [&type/Type
- false])
- (&/T [(-> def-class (.getField &/type-field) (.get nil))
- false])))
- def-meta ?meta
- def-value (-> def-class (.getField &/value-field) (.get nil))]
- _ (&a-module/define module-name ?name def-type def-meta def-value)
- _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)])
- [true (&/$Some (&/$ListM tags*))]
- (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta)
- (&/$Some _)
- true
+ (|case (de-ann ?body)
+ [_ (&o/$function _ _ _ _)]
+ (|let [[_ (&o/$function _arity _scope _captured ?body+)] (&o/shift-function-body false (de-ann ?body))]
+ (|do [:let [=value-type (&a/expr-type* ?body)]
+ ;; ^ClassWriter *writer* &/get-writer
+ [file-name _ _] &/cursor
+ :let [datum-sig "Ljava/lang/Object;"
+ def-name (&host/def-name ?name)
+ current-class (str (&host/->module-class module-name) "/" def-name)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version class-flags
+ current-class nil &&/function-class (into-array String []))
+ (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/type-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/meta-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/value-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (.visitSource file-name nil))]
+ instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+)
+ _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
+ (|do [^MethodVisitor **writer** &/get-writer
+ :let [_ (.visitCode **writer**)]
+ _ (compile-def-type compile ?body)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/type-field datum-sig)]
+ _ (compile-def-meta compile ?meta)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
+ _ instancer
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)]
+ :let [_ (doto **writer**
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))
+ ;; :let [_ (.visitEnd *writer*)]
+ :let [_ (.visitEnd =class)]
+ _ (&&/save-class! def-name (.toByteArray =class))
+ :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
+ [def-type is-type?] (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
+ (&/$Some (&/$BoolM true))
+ (&/T [&type/Type
+ true])
_
- false)]
- tags (&/map% (fn [tag*]
- (|case tag*
- (&/$TextM tag)
- (return tag)
-
- _
- (fail "[Compiler Error] Incorrect format for tags.")))
- tags*)
- _ (&a-module/declare-tags module-name tags was-exported? def-value)]
- (return nil))
+ (if (&type/type= &type/Type =value-type)
+ (&/T [&type/Type
+ false])
+ (&/T [(-> def-class (.getField &/type-field) (.get nil))
+ false])))
+ def-meta ?meta
+ def-value (-> def-class (.getField &/value-field) (.get nil))]
+ _ (&a-module/define module-name ?name def-type def-meta def-value)
+ _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)])
+ [true (&/$Some (&/$ListM tags*))]
+ (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta)
+ (&/$Some _)
+ true
- [false (&/$Some _)]
- (fail "[Compiler Error] Can't define tags for non-type.")
+ _
+ false)]
+ tags (&/map% (fn [tag*]
+ (|case tag*
+ (&/$TextM tag)
+ (return tag)
- [true (&/$Some _)]
- (fail "[Compiler Error] Incorrect format for tags.")
+ _
+ (fail "[Compiler Error] Incorrect format for tags.")))
+ tags*)
+ _ (&a-module/declare-tags module-name tags was-exported? def-value)]
+ (return nil))
- [_ (&/$None)]
- (return nil))
- :let [_ (println 'DEF (str module-name ";" ?name))]]
- (return nil))))))
+ [false (&/$Some _)]
+ (fail "[Compiler Error] Can't define tags for non-type.")
+
+ [true (&/$Some _)]
+ (fail "[Compiler Error] Incorrect format for tags.")
+
+ [_ (&/$None)]
+ (return nil))
+ :let [_ (println 'DEF (str module-name ";" ?name))]]
+ (return nil)))
+
+ _
+ (|do [:let [=value-type (&a/expr-type* ?body)]
+ ;; ^ClassWriter *writer* &/get-writer
+ [file-name _ _] &/cursor
+ :let [datum-sig "Ljava/lang/Object;"
+ def-name (&host/def-name ?name)
+ current-class (str (&host/->module-class module-name) "/" def-name)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version class-flags
+ current-class nil "java/lang/Object" (into-array String []))
+ (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/type-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/meta-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/value-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (.visitSource file-name nil))]
+ _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
+ (|do [^MethodVisitor **writer** &/get-writer
+ :let [_ (.visitCode **writer**)]
+ _ (compile-def-type compile ?body)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/type-field datum-sig)]
+ _ (compile-def-meta compile ?meta)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
+ _ (compile ?body)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)]
+ :let [_ (doto **writer**
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))
+ ;; :let [_ (.visitEnd *writer*)]
+ :let [_ (.visitEnd =class)]
+ _ (&&/save-class! def-name (.toByteArray =class))
+ :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class))
+ [def-type is-type?] (|case (&a-meta/meta-get &a-meta/type?-tag ?meta)
+ (&/$Some (&/$BoolM true))
+ (&/T [&type/Type
+ true])
+
+ _
+ (if (&type/type= &type/Type =value-type)
+ (&/T [&type/Type
+ false])
+ (&/T [(-> def-class (.getField &/type-field) (.get nil))
+ false])))
+ def-meta ?meta
+ def-value (-> def-class (.getField &/value-field) (.get nil))]
+ _ (&a-module/define module-name ?name def-type def-meta def-value)
+ _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)])
+ [true (&/$Some (&/$ListM tags*))]
+ (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta)
+ (&/$Some _)
+ true
+
+ _
+ false)]
+ tags (&/map% (fn [tag*]
+ (|case tag*
+ (&/$TextM tag)
+ (return tag)
+
+ _
+ (fail "[Compiler Error] Incorrect format for tags.")))
+ tags*)
+ _ (&a-module/declare-tags module-name tags was-exported? def-value)]
+ (return nil))
+
+ [false (&/$Some _)]
+ (fail "[Compiler Error] Can't define tags for non-type.")
+
+ [true (&/$Some _)]
+ (fail "[Compiler Error] Incorrect format for tags.")
+
+ [_ (&/$None)]
+ (return nil))
+ :let [_ (println 'DEF (str module-name ";" ?name))]]
+ (return nil)))
+ ))))
(defn compile-program [compile ?body]
(|do [module-name &/get-module-name
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index e774f4216..9b4dd7548 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -57,7 +57,7 @@
(&/$Cons _module (&/$Cons _def (&/$Cons _level-to-remove _levels-to-keep)))
(&/$Cons _module (&/$Cons _def _levels-to-keep))))
-(defn ^:private shift-function-body [own-body? body]
+(defn shift-function-body [own-body? body]
"(-> Optimized Optimized)"
(|let [[meta body-] body]
(|case body-
@@ -106,9 +106,12 @@
body)
($apply [meta-0 ($var (&/$Local 0))] args)
- (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))])
- (&/$Cons (&/T [meta-0 ($var (&/$Local 1))])
- (&/|map (partial shift-function-body own-body?) args)))])
+ (if own-body?
+ (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))])
+ (&/$Cons (&/T [meta-0 ($var (&/$Local 1))])
+ (&/|map (partial shift-function-body own-body?) args)))])
+ (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))])
+ (&/|map (partial shift-function-body own-body?) args))]))
($apply func args)
(&/T [meta ($apply (shift-function-body own-body? func)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 07:34:54 +0000