aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser/host.clj4
-rw-r--r--src/lux/compiler.clj44
-rw-r--r--src/lux/compiler/lambda.clj42
-rw-r--r--src/lux/compiler/lux.clj33
-rw-r--r--src/lux/optimizer.clj158
5 files changed, 177 insertions, 104 deletions
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index c8fa72b5f..3703b6ec9 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -902,7 +902,7 @@
(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods]
(|do [module &/get-module-name
_ (compile-interface interface-decl supers =anns =methods)
- :let [_ (println 'DEF (str module "." (&/|first interface-decl)))]
+ :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))]
_cursor &/cursor]
(return (&/|list (&&/|meta &/$UnitT _cursor
(&&/$tuple (&/|list)))))))
@@ -921,7 +921,7 @@
_ (check-method-completion all-supers =methods)
_ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None)
_ &/pop-dummy-name
- :let [_ (println 'DEF full-name)]
+ :let [_ (println 'CLASS full-name)]
_cursor &/cursor]
(return (&/|list (&&/|meta &/$UnitT _cursor
(&&/$tuple (&/|list))))))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index b9acff72a..69b3d4345 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -39,7 +39,7 @@
;; [Resources]
(def ^:private !source->last-line (atom nil))
-(defn compile-expression [syntax]
+(defn compile-expression [$begin syntax]
(|let [[[?type [_file-name _line _]] ?form] syntax]
(|do [^MethodVisitor *writer* &/get-writer
:let [debug-label (new Label)
@@ -50,50 +50,53 @@
(swap! !source->last-line assoc _file-name _line))]]
(|case ?form
(&o/$bool ?value)
- (&&lux/compile-bool compile-expression ?value)
+ (&&lux/compile-bool ?value)
(&o/$int ?value)
- (&&lux/compile-int compile-expression ?value)
+ (&&lux/compile-int ?value)
(&o/$real ?value)
- (&&lux/compile-real compile-expression ?value)
+ (&&lux/compile-real ?value)
(&o/$char ?value)
- (&&lux/compile-char compile-expression ?value)
+ (&&lux/compile-char ?value)
(&o/$text ?value)
- (&&lux/compile-text compile-expression ?value)
+ (&&lux/compile-text ?value)
(&o/$tuple ?elems)
- (&&lux/compile-tuple compile-expression ?elems)
+ (&&lux/compile-tuple (partial compile-expression $begin) ?elems)
(&o/$var (&/$Local ?idx))
- (&&lux/compile-local compile-expression ?idx)
+ (&&lux/compile-local (partial compile-expression $begin) ?idx)
(&o/$captured ?scope ?captured-id ?source)
- (&&lux/compile-captured compile-expression ?scope ?captured-id ?source)
+ (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source)
(&o/$var (&/$Global ?owner-class ?name))
- (&&lux/compile-global compile-expression ?owner-class ?name)
+ (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name)
(&o/$apply ?fn ?args)
- (&&lux/compile-apply compile-expression ?fn ?args)
+ (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args)
+
+ (&o/$loop ?args)
+ (&&lux/compile-loop (partial compile-expression $begin) $begin ?args)
(&o/$variant ?tag ?tail ?members)
- (&&lux/compile-variant compile-expression ?tag ?tail ?members)
+ (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members)
(&o/$case ?value ?match)
- (&&case/compile-case compile-expression ?value ?match)
+ (&&case/compile-case (partial compile-expression $begin) ?value ?match)
(&o/$function ?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)
- (compile-expression ?value-ex)
+ (compile-expression $begin ?value-ex)
(&o/$proc [?proc-category ?proc-name] ?args special-args)
- (&&host/compile-host compile-expression ?proc-category ?proc-name ?args special-args)
+ (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args)
_
(assert false (prn-str 'compile-expression (&/adt->text syntax)))
@@ -122,7 +125,7 @@
_ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitCode *writer*)]
- _ (compile-expression expr)
+ _ (compile-expression nil expr)
:let [_ (doto *writer*
(.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;")
(.visitInsn Opcodes/RETURN)
@@ -139,10 +142,11 @@
return))))
(def all-compilers
- (&/T [(partial &&lux/compile-def compile-expression)
- (partial &&lux/compile-program compile-expression)
- (partial &&host/compile-jvm-class compile-expression)
- &&host/compile-jvm-interface]))
+ (let [compile-expression* (partial compile-expression nil)]
+ (&/T [(partial &&lux/compile-def compile-expression)
+ (partial &&lux/compile-program compile-expression*)
+ (partial &&host/compile-jvm-class compile-expression*)
+ &&host/compile-jvm-interface])))
(defn compile-module [source-dirs name]
(let [file-name (str name ".lux")]
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index d291ebc07..f51edc507 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -113,15 +113,17 @@
(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)]
(defn ^:private add-lambda-impl [class class-name compile arity impl-body]
- (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature arity) nil nil)
- (.visitCode))
- (|do [^MethodVisitor *writer* &/get-writer
- ret (compile impl-body)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return ret)))))
+ (let [$begin (new Label)]
+ (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature arity) nil nil)
+ (.visitCode)
+ (.visitLabel $begin))
+ (|do [^MethodVisitor *writer* &/get-writer
+ ret (compile $begin impl-body)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return ret))))))
(defn ^:private instance-closure [compile lambda-class arity closed-over]
(|do [^MethodVisitor *writer* &/get-writer
@@ -131,7 +133,7 @@
_ (&/map% (fn [?name+?captured]
(|case ?name+?captured
[?name [_ (&a/$captured _ _ ?source)]]
- (compile ?source)))
+ (compile nil ?source)))
closed-over)
:let [_ (when (> arity 1)
(doto *writer*
@@ -223,15 +225,17 @@
(.visitMaxs 0 0)
(.visitEnd))
(return nil)))
- (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil)
- (.visitCode))
- (|do [^MethodVisitor *writer* &/get-writer
- ret (compile impl-body)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return ret)))
+ (let [$begin (new Label)]
+ (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil)
+ (.visitCode)
+ (.visitLabel $begin))
+ (|do [^MethodVisitor *writer* &/get-writer
+ ret (compile $begin impl-body)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return ret))))
))
;; [Exports]
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 2cbfcef54..3f069dbfd 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -30,13 +30,13 @@
java.lang.reflect.Field))
;; [Exports]
-(defn compile-bool [compile ?value]
+(defn compile-bool [?value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]]
(return nil)))
(do-template [<name> <class> <sig> <caster>]
- (defn <name> [compile value]
+ (defn <name> [value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW <class>)
@@ -50,7 +50,7 @@
compile-char "java/lang/Character" "(C)V" char
)
-(defn compile-text [compile ?value]
+(defn compile-text [?value]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (.visitLdcInsn *writer* ?value)]]
(return nil)))
@@ -149,6 +149,27 @@
(compile-apply* compile ?args))
))
+(defn compile-loop [compile $begin ?args]
+ (|do [^MethodVisitor *writer* &/get-writer
+ _ (&/map% (fn [idx+?arg]
+ (|do [:let [[idx ?arg] idx+?arg
+ already-set? (|case ?arg
+ [_ (&o/$var (&/$Local l-idx))]
+ (= idx l-idx)
+
+ _
+ false)]
+ _ (if already-set?
+ (return nil)
+ (compile ?arg))
+ :let [_ (when (not already-set?)
+ (.visitVarInsn *writer* Opcodes/ASTORE idx))]]
+ (return nil)))
+ (&/zip2 (&/|range* 1 (&/|length ?args))
+ ?args))
+ :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]]
+ (return nil)))
+
(defn ^:private compile-def-type [compile ?body]
(|do [:let [?def-type (|case ?body
[[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr ?def-value-type)]
@@ -159,11 +180,11 @@
(&/T [(&/T [?def-type ?def-cursor])
(&a/$tuple (&/|list))])
(&&type/type->analysis ?def-type)))]]
- (compile ?def-type)))
+ (compile nil ?def-type)))
(defn ^:private compile-def-meta [compile ?meta]
(|let [analysis (&&type/defmeta->analysis ?meta)]
- (compile analysis)))
+ (compile nil analysis)))
(defn ^:private de-ann [optim]
(|case optim
@@ -304,7 +325,7 @@
: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)
+ _ (compile nil ?body)
:let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)]
:let [_ (doto **writer**
(.visitInsn Opcodes/RETURN)
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index 9b4dd7548..920fd21bc 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -2,7 +2,6 @@
;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
;; If a copy of the MPL was not distributed with this file,
;; You can obtain one at http://mozilla.org/MPL/2.0/.
-
(ns lux.optimizer
(:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]]
[analyser :as &analyser])
@@ -25,6 +24,9 @@
("var" 1)
("captured" 3)
("proc" 3)
+
+ ;; Purely for optimizations
+ ("loop" 1)
)
;; [Utils]
@@ -131,72 +133,114 @@
($proc proc-ident args special-args)
(&/T [meta ($proc proc-ident (&/|map (partial shift-function-body own-body?) args) special-args)])
+ ($loop args)
+ (&/T [meta ($loop (&/|map (partial shift-function-body own-body?) args))])
+
_
body
)))
-(defn ^:private optimize-closure [optimize closure]
- (&/|map (fn [capture]
- (|let [[_name _analysis] capture]
- (&/T [_name (optimize _analysis)])))
- closure))
+(defn ^:private optimize-loop [arity optim]
+ "(-> Int Optimized [Optimized Bool])"
+ (|let [[meta optim-] optim]
+ (|case optim-
+ ($apply [meta-0 ($var (&/$Local 0))] _args)
+ (if (= arity (&/|length _args))
+ (&/T [meta-0 ($loop (&/|map (partial optimize-loop -1) _args))])
+ optim)
-;; [Exports]
-(defn optimize [analysis]
- "(-> Analysis Optimized)"
- (|let [[meta analysis-] analysis]
- (|case analysis-
- (&-base/$bool value)
- (&/T [meta ($bool value)])
-
- (&-base/$int value)
- (&/T [meta ($int value)])
-
- (&-base/$real value)
- (&/T [meta ($real value)])
-
- (&-base/$char value)
- (&/T [meta ($char value)])
-
- (&-base/$text value)
- (&/T [meta ($text value)])
-
- (&-base/$variant idx is-last? value)
- (&/T [meta ($variant idx is-last? (optimize value))])
-
- (&-base/$tuple elems)
- (&/T [meta ($tuple (&/|map optimize elems))])
-
- (&-base/$apply func args)
- (&/T [meta ($apply (optimize func) (&/|map optimize args))])
-
- (&-base/$case value branches)
- (&/T [meta ($case (optimize value)
+ ($apply func args)
+ (&/T [meta ($apply (optimize-loop -1 func)
+ (&/|map (partial optimize-loop -1) args))])
+
+ ($case _value _branches)
+ (&/T [meta ($case _value
(&/|map (fn [branch]
(|let [[_pattern _body] branch]
- (&/T [_pattern (optimize _body)])))
- branches))])
-
- (&-base/$lambda scope captured body)
- (|case (optimize body)
- [_ ($function _arity _scope _captured _body)]
- (&/T [meta ($function (inc _arity) scope (optimize-closure optimize captured) (shift-function-body true _body))])
+ (&/T [_pattern (optimize-loop arity _body)])))
+ _branches))])
- =body
- (&/T [meta ($function 1 scope (optimize-closure optimize captured) =body)]))
+ ($function _arity _scope _captured _body)
+ (&/T [meta ($function _arity _scope _captured (optimize-loop _arity _body))])
- (&-base/$ann value-expr type-expr type-type)
- (&/T [meta ($ann (optimize value-expr) type-expr type-type)])
-
- (&-base/$var var-kind)
- (&/T [meta ($var var-kind)])
-
- (&-base/$captured scope idx source)
- (&/T [meta ($captured scope idx (optimize source))])
+ ($ann _value-expr _type-expr _type-type)
+ (&/T [meta ($ann (optimize-loop arity _value-expr) _type-expr _type-type)])
+
+ ($variant idx is-last? value)
+ (&/T [meta ($variant idx is-last? (optimize-loop -1 value))])
- (&-base/$proc proc-ident args special-args)
- (&/T [meta ($proc proc-ident (&/|map optimize args) special-args)])
+ ($tuple elems)
+ (&/T [meta ($tuple (&/|map (partial optimize-loop -1) elems))])
_
- (assert false (prn-str 'optimize (&/adt->text analysis)))
+ optim
)))
+
+(let [optimize-closure (fn [optimize closure]
+ (&/|map (fn [capture]
+ (|let [[_name _analysis] capture]
+ (&/T [_name (optimize _analysis)])))
+ closure))]
+ (defn ^:private pass-0 [analysis]
+ "(-> Analysis Optimized)"
+ (|let [[meta analysis-] analysis]
+ (|case analysis-
+ (&-base/$bool value)
+ (&/T [meta ($bool value)])
+
+ (&-base/$int value)
+ (&/T [meta ($int value)])
+
+ (&-base/$real value)
+ (&/T [meta ($real value)])
+
+ (&-base/$char value)
+ (&/T [meta ($char value)])
+
+ (&-base/$text value)
+ (&/T [meta ($text value)])
+
+ (&-base/$variant idx is-last? value)
+ (&/T [meta ($variant idx is-last? (pass-0 value))])
+
+ (&-base/$tuple elems)
+ (&/T [meta ($tuple (&/|map pass-0 elems))])
+
+ (&-base/$apply func args)
+ (&/T [meta ($apply (pass-0 func) (&/|map pass-0 args))])
+
+ (&-base/$case value branches)
+ (&/T [meta ($case (pass-0 value)
+ (&/|map (fn [branch]
+ (|let [[_pattern _body] branch]
+ (&/T [_pattern (pass-0 _body)])))
+ branches))])
+
+ (&-base/$lambda scope captured body)
+ (|case (pass-0 body)
+ [_ ($function _arity _scope _captured _body)]
+ (&/T [meta ($function (inc _arity) scope (optimize-closure pass-0 captured) (shift-function-body true _body))])
+
+ =body
+ (&/T [meta ($function 1 scope (optimize-closure pass-0 captured) =body)]))
+
+ (&-base/$ann value-expr type-expr type-type)
+ (&/T [meta ($ann (pass-0 value-expr) type-expr type-type)])
+
+ (&-base/$var var-kind)
+ (&/T [meta ($var var-kind)])
+
+ (&-base/$captured scope idx source)
+ (&/T [meta ($captured scope idx (pass-0 source))])
+
+ (&-base/$proc proc-ident args special-args)
+ (&/T [meta ($proc proc-ident (&/|map pass-0 args) special-args)])
+
+ _
+ (assert false (prn-str 'pass-0 (&/adt->text analysis)))
+ ))))
+
+;; [Exports]
+(defn optimize [analysis]
+ "(-> Analysis Optimized)"
+ (->> analysis pass-0 (optimize-loop -1)))