aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser.clj35
-rw-r--r--src/lux/analyser/base.clj2
-rw-r--r--src/lux/analyser/case.clj27
-rw-r--r--src/lux/analyser/host.clj56
-rw-r--r--src/lux/analyser/lux.clj10
-rw-r--r--src/lux/base.clj14
-rw-r--r--src/lux/compiler.clj11
-rw-r--r--src/lux/compiler/case.clj15
-rw-r--r--src/lux/compiler/host.clj318
-rw-r--r--src/lux/compiler/io.clj2
-rw-r--r--src/lux/compiler/lambda.clj213
-rw-r--r--src/lux/optimizer.clj231
-rw-r--r--src/lux/repl.clj2
13 files changed, 640 insertions, 296 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index c5fabb409..03b217f85 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -54,7 +54,7 @@
(fn [state]
(fail* (add-loc (&/get$ &/$cursor state) msg))))
-(defn ^:private aba1 [analyse eval! compile-module compilers exo-type token]
+(defn ^:private aba1 [analyse optimize eval! compile-module compilers exo-type token]
(|let [[compile-def compile-program compile-class compile-interface] compilers]
(|case token
;; Standard special forms
@@ -112,7 +112,7 @@
(&/$Cons ?meta
(&/$Nil))
))))
- (&&lux/analyse-def analyse eval! compile-def ?name ?value ?meta)
+ (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta)
(&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")]
(&/$Cons [_ (&/$TextS ?path)]
@@ -149,17 +149,17 @@
(&/$Cons [_ (&/$SymbolS "" ?args)]
(&/$Cons ?body
(&/$Nil)))))
- (&&lux/analyse-program analyse compile-program ?args ?body)
+ (&&lux/analyse-program analyse optimize compile-program ?args ?body)
_
(fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token])))))
)))
-(defn ^:private analyse-basic-ast [analyse eval! compile-module compilers exo-type token]
+(defn ^:private analyse-basic-ast [analyse optimize eval! compile-module compilers exo-type token]
(|case token
[meta ?token]
(fn [state]
- (|case ((aba1 analyse eval! compile-module compilers exo-type ?token) state)
+ (|case ((aba1 analyse optimize eval! compile-module compilers exo-type ?token) state)
(&/$Right state* output)
(return* state* output)
@@ -186,39 +186,40 @@
(return (&&/|meta =output-type ?output-cursor ?output-term))))
))))
-(defn ^:private analyse-ast [eval! compile-module compilers exo-type token]
- (|let [[cursor _] token]
+(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type token]
+ (|let [[cursor _] token
+ analyser (partial analyse-ast optimize eval! compile-module compilers)]
(&/with-cursor cursor
(&/with-expected-type exo-type
(|case token
[meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))]
- (&&lux/analyse-variant (partial analyse-ast eval! compile-module compilers) (&/$Right exo-type) idx nil ?values)
+ (&&lux/analyse-variant analyser (&/$Right exo-type) idx nil ?values)
[meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))]
- (analyse-variant+ (partial analyse-ast eval! compile-module compilers) exo-type ?ident ?values)
+ (analyse-variant+ analyser exo-type ?ident ?values)
[meta (&/$FormS (&/$Cons ?fn ?args))]
(|case ?fn
[_ (&/$SymbolS _)]
(fn [state]
- (|case ((just-analyse (partial analyse-ast eval! compile-module compilers) ?fn) state)
+ (|case ((just-analyse analyser ?fn) state)
(&/$Right state* =fn)
- ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compilers) exo-type =fn ?args) state*)
+ ((&&lux/analyse-apply analyser exo-type =fn ?args) state*)
_
- ((analyse-basic-ast (partial analyse-ast eval! compile-module compilers) eval! compile-module compilers exo-type token) state)))
+ ((analyse-basic-ast analyser optimize eval! compile-module compilers exo-type token) state)))
_
- (|do [=fn (just-analyse (partial analyse-ast eval! compile-module compilers) ?fn)]
- (&&lux/analyse-apply (partial analyse-ast eval! compile-module compilers) exo-type =fn ?args)))
+ (|do [=fn (just-analyse analyser ?fn)]
+ (&&lux/analyse-apply analyser exo-type =fn ?args)))
_
- (analyse-basic-ast (partial analyse-ast eval! compile-module compilers) eval! compile-module compilers exo-type token))))))
+ (analyse-basic-ast analyser optimize eval! compile-module compilers exo-type token))))))
;; [Resources]
-(defn analyse [eval! compile-module compilers]
+(defn analyse [optimize eval! compile-module compilers]
(|do [asts &parser/parse]
- (&/flat-map% (partial analyse-ast eval! compile-module compilers &/$VoidT) asts)))
+ (&/flat-map% (partial analyse-ast optimize eval! compile-module compilers &/$VoidT) asts)))
(defn clean-output [?var analysis]
(|do [:let [[[?output-type ?output-cursor] ?output-term] analysis]
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj
index 5ee60d4cf..aa2f27a68 100644
--- a/src/lux/analyser/base.clj
+++ b/src/lux/analyser/base.clj
@@ -24,7 +24,7 @@
("ann" 3) ;; Eliminate
("var" 1)
("captured" 1)
- ("proc" 2)
+ ("proc" 3)
)
;; [Exports]
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index 71dc1d7bf..0aefca025 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -26,6 +26,7 @@
("VariantTotal" 2))
(defvariant
+ ("NoTestAC" 0)
("StoreTestAC" 1)
("BoolTestAC" 1)
("IntTestAC" 1)
@@ -136,7 +137,7 @@
(&/$Some var-analysis)
(|do [=kont (&env/with-alias name var-analysis
kont)]
- (return (&/T [($StoreTestAC -1) =kont])))
+ (return (&/T [$NoTestAC =kont])))
_
(|do [=kont (&env/with-local name value-type
@@ -267,6 +268,30 @@
(defn ^:private merge-total [struct test+body]
(|let [[test ?body] test+body]
(|case [struct test]
+ [($DefaultTotal total?) ($NoTestAC)]
+ (return ($DefaultTotal true))
+
+ [($BoolTotal total? ?values) ($NoTestAC)]
+ (return ($BoolTotal true ?values))
+
+ [($IntTotal total? ?values) ($NoTestAC)]
+ (return ($IntTotal true ?values))
+
+ [($RealTotal total? ?values) ($NoTestAC)]
+ (return ($RealTotal true ?values))
+
+ [($CharTotal total? ?values) ($NoTestAC)]
+ (return ($CharTotal true ?values))
+
+ [($TextTotal total? ?values) ($NoTestAC)]
+ (return ($TextTotal true ?values))
+
+ [($TupleTotal total? ?values) ($NoTestAC)]
+ (return ($TupleTotal true ?values))
+
+ [($VariantTotal total? ?values) ($NoTestAC)]
+ (return ($VariantTotal true ?values))
+
[($DefaultTotal total?) ($StoreTestAC ?idx)]
(return ($DefaultTotal true))
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index dd3172dab..eea8297c4 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -433,7 +433,7 @@
=value (&&/analyse-1 analyse (&/$HostT <from-class> &/$Nil) ?value)
_ (&type/check exo-type output-type)
_cursor &/cursor]
- (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value))))))))
+ (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value) (&/|list))))))))
^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float"
^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer"
@@ -468,7 +468,7 @@
=value2 (&&/analyse-1 analyse (&/$HostT <v2-class> &/$Nil) ?value2)
_ (&type/check exo-type output-type)
_cursor &/cursor]
- (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value1 =value2))))))))
+ (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value1 =value2) (&/|list))))))))
^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer"
^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer"
@@ -495,7 +495,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta output-type _cursor
- (&&/$proc (&/T ["jvm" <proc>]) (&/|list =x =y))))))))
+ (&&/$proc (&/T ["jvm" <proc>]) (&/|list =x =y) (&/|list))))))))
^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer"
^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer"
@@ -549,7 +549,7 @@
_ (&type/check exo-type array-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <new-tag>]) (&/|list =length)))))))
+ (&&/$proc (&/T ["jvm" <new-tag>]) (&/|list =length) (&/|list)))))))
(defn <load-name> [analyse exo-type ?values]
(|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
@@ -558,7 +558,7 @@
_ (&type/check exo-type elem-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <load-tag>]) (&/|list =array =idx)))))))
+ (&&/$proc (&/T ["jvm" <load-tag>]) (&/|list =array =idx) (&/|list)))))))
(defn <store-name> [analyse exo-type ?values]
(|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values]
@@ -568,7 +568,7 @@
_ (&type/check exo-type array-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <store-tag>]) (&/|list =array =idx =elem)))))))
+ (&&/$proc (&/T ["jvm" <store-tag>]) (&/|list =array =idx =elem) (&/|list)))))))
)
"java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore"
@@ -601,7 +601,7 @@
_ (&type/check exo-type array-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list gclass =length gtype-env)))))))
+ (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env)))))))
(defn ^:private analyse-jvm-aaload [analyse exo-type ?values]
(|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
@@ -613,7 +613,7 @@
_ (&type/check exo-type inner-arr-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx)))))))
+ (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list)))))))
(defn ^:private analyse-jvm-aastore [analyse exo-type ?values]
(|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values]
@@ -627,7 +627,7 @@
_ (&type/check exo-type array-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem))))))))
+ (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list))))))))
(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values]
(|do [:let [(&/$Cons array (&/$Nil)) ?values]
@@ -637,7 +637,7 @@
_ (&type/check exo-type &type/Int)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array))
+ (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list))
)))))
(defn ^:private analyse-jvm-null? [analyse exo-type ?values]
@@ -648,7 +648,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object)))))))
+ (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list)))))))
(defn ^:private analyse-jvm-null [analyse exo-type ?values]
(|do [:let [(&/$Nil) ?values]
@@ -656,7 +656,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "null"]) (&/|list)))))))
+ (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))))))
(do-template [<name> <tag>]
(defn <name> [analyse exo-type ?values]
@@ -667,7 +667,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <tag>]) (&/|list =monitor)))))))
+ (&&/$proc (&/T ["jvm" <tag>]) (&/|list =monitor) (&/|list)))))))
^:private analyse-jvm-monitorenter "monitorenter"
^:private analyse-jvm-monitorexit "monitorexit"
@@ -679,7 +679,7 @@
_cursor &/cursor
_ (&type/check exo-type &/$VoidT)]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex)))))))
+ (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list)))))))
(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values]
(|do [:let [(&/$Nil) ?values]
@@ -690,7 +690,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list class field output-type)))))))
+ (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type)))))))
(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values]
(|do [:let [(&/$Cons object (&/$Nil)) ?values]
@@ -703,7 +703,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "getfield"]) (&/|list class field =object output-type)))))))
+ (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type)))))))
(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values]
(|do [:let [(&/$Cons value (&/$Nil)) ?values]
@@ -716,7 +716,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list class field =value gclass)))))))
+ (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass)))))))
(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values]
(|do [:let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values]
@@ -732,7 +732,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "putfield"]) (&/|list class field =object =value gclass =type)))))))
+ (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type)))))))
(defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args]
(|case gtype-vars
@@ -780,7 +780,7 @@
_ (&type/check exo-type (as-otype+ output-type))
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" <tag>]) (&/|list class method classes =object =args output-type)))))))
+ (&&/$proc (&/T ["jvm" <tag>]) (&/$Cons =object =args) (&/|list class method classes output-type)))))))
^:private analyse-jvm-invokevirtual "invokevirtual" false
^:private analyse-jvm-invokespecial "invokespecial" false
@@ -797,7 +797,7 @@
_ (&type/check exo-type (as-otype+ output-type))
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "invokestatic"]) (&/|list class method classes =args output-type)))))))
+ (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type)))))))
(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args]
(|case gtype-vars
@@ -827,7 +827,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "new"]) (&/|list class classes =args)))))))
+ (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes)))))))
(defn ^:private analyse-jvm-try [analyse exo-type ?values]
(|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values]
@@ -836,7 +836,7 @@
=catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch)))))))
+ (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list)))))))
(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values]
(|do [:let [(&/$Cons object (&/$Nil)) ?values]
@@ -846,7 +846,7 @@
_ (&type/check exo-type output-type)
_cursor &/cursor]
(return (&/|list (&&/|meta output-type _cursor
- (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list class =object)))))))
+ (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class)))))))
(let [length-type &type/Int
idx-type &type/Int]
@@ -859,7 +859,7 @@
_ (&type/check exo-type array-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list gclass =length gtype-env)))))))
+ (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env)))))))
(defn ^:private analyse-array-get [analyse exo-type ?values]
(|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
@@ -871,7 +871,7 @@
_ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type))
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx)))))))
+ (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list)))))))
(defn ^:private analyse-array-remove [analyse exo-type ?values]
(|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
@@ -883,10 +883,10 @@
=idx (&&/analyse-1 analyse idx-type idx)
_cursor &/cursor
:let [=elem (&&/|meta inner-arr-type _cursor
- (&&/$proc (&/T ["jvm" "null"]) (&/|list)))]
+ (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))]
_ (&type/check exo-type array-type)]
(return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem))))))))
+ (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list))))))))
(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods]
(|do [module &/get-module-name
@@ -962,7 +962,7 @@
_ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args))
_cursor &/cursor]
(return (&/|list (&&/|meta anon-class-type _cursor
- (&&/$proc (&/T ["jvm" "new"]) (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class) sources))
+ (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class)))
)))
))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 382637e4a..843f61d34 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -543,7 +543,7 @@
(|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)]
(return (&/|list output))))
-(defn analyse-def [analyse eval! compile-def ?name ?value ?meta]
+(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta]
(|do [module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
@@ -551,10 +551,10 @@
(|do [=value (&/with-scope ?name
(&&/analyse-1+ analyse ?value))
=meta (&&/analyse-1 analyse &type/DefMeta ?meta)
- ==meta (eval! =meta)
+ ==meta (eval! (optimize =meta))
_ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value))
_ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value))
- _ (compile-def ?name =value ==meta)]
+ _ (compile-def ?name (optimize =value) ==meta)]
(return &/$Nil))
)))
@@ -613,9 +613,9 @@
(let [input-type (&/$AppT &type/List &type/Text)
output-type (&/$AppT &type/IO &/$UnitT)]
- (defn analyse-program [analyse compile-program ?args ?body]
+ (defn analyse-program [analyse optimize compile-program ?args ?body]
(|do [=body (&/with-scope ""
(&&env/with-local ?args input-type
(&&/analyse-1 analyse output-type ?body)))
- _ (compile-program =body)]
+ _ (compile-program (optimize =body))]
(return &/$Nil))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index c9050a7e6..b921fa86c 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -1198,3 +1198,17 @@
[_ ($Nil)] $Nil
[_ ($Cons x xs*)] (|drop (dec n) xs*)
))
+
+(defn |but-last [xs]
+ (|case xs
+ ($Nil)
+ $Nil
+
+ ($Cons x ($Nil))
+ $Nil
+
+ ($Cons x xs*)
+ ($Cons x (|but-last xs*))
+
+ _
+ (assert false (adt->text xs))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 713d5ea9a..657d681c8 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -85,14 +85,15 @@
(&o/$case ?value ?match)
(&&case/compile-case compile-expression ?value ?match)
- (&o/$lambda ?scope ?env ?body)
- (&&lambda/compile-lambda compile-expression ?scope ?env ?body)
+ (&o/$function ?level ?scope ?env ?body)
+ (&&lambda/compile-function compile-expression ?level ?scope ?env ?body)
+ ;; Must get rid of this one...
(&o/$ann ?value-ex ?type-ex ?value-type)
(&&lux/compile-ann compile-expression ?value-ex ?type-ex ?value-type)
- (&o/$proc [?proc-category ?proc-name] ?args)
- (&&host/compile-host compile-expression ?proc-category ?proc-name ?args)
+ (&o/$proc [?proc-category ?proc-name] ?args special-args)
+ (&&host/compile-host compile-expression ?proc-category ?proc-name ?args special-args)
_
(assert false (prn-str 'compile-expression (&/adt->text syntax)))
@@ -149,7 +150,7 @@
:let [file-hash (hash file-content)]]
(if (&&cache/cached? name)
(&&cache/load source-dirs name file-hash compile-module)
- (let [compiler-step (&optimizer/optimize eval! (partial compile-module source-dirs) all-compilers)]
+ (let [compiler-step (&analyser/analyse &optimizer/optimize eval! (partial compile-module source-dirs) all-compilers)]
(|do [module-exists? (&a-module/exists? name)]
(if module-exists?
(fail "[Compiler Error] Can't redefine a module!")
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
index cd672b5ec..aa5e1ed72 100644
--- a/src/lux/compiler/case.clj
+++ b/src/lux/compiler/case.clj
@@ -25,14 +25,15 @@
(defn ^:private compile-match [^MethodVisitor writer ?match $target $else]
"(-> [MethodVisitor CaseAnalysis Label Label] Unit)"
(|case ?match
+ (&a-case/$NoTestAC)
+ (doto writer
+ (.visitInsn Opcodes/POP) ;; Basically, a No-Op
+ (.visitJumpInsn Opcodes/GOTO $target))
+
(&a-case/$StoreTestAC ?idx)
- (if (< ?idx 0)
- (doto writer
- (.visitInsn Opcodes/POP) ;; Basically, a No-Op
- (.visitJumpInsn Opcodes/GOTO $target))
- (doto writer
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitJumpInsn Opcodes/GOTO $target)))
+ (doto writer
+ (.visitVarInsn Opcodes/ASTORE ?idx)
+ (.visitJumpInsn Opcodes/GOTO $target))
(&a-case/$BoolTestAC ?value)
(doto writer
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index cb2777124..d56c67715 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -14,6 +14,7 @@
[lexer :as &lexer]
[parser :as &parser]
[analyser :as &analyser]
+ [optimizer :as &o]
[host :as &host])
[lux.type.host :as &host-type]
[lux.host.generics :as &host-generics]
@@ -266,7 +267,7 @@
:let [_ (.visitVarInsn =method Opcodes/ALOAD 0)]
_ (->> ?ctor-args (&/|map &/|second) (&/map% compile))
:let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)]
- _ (compile ?body)
+ _ (compile (&o/optimize ?body))
:let [_ (doto =method
(compile-method-return ?output)
(.visitMaxs 0 0)
@@ -289,7 +290,7 @@
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 1 ?inputs =method)
:let [_ (.visitFrame =method Opcodes/F_NEW (int (inc (&/|length =input-tags))) (to-array (&/->seq (&/$Cons bytecode-class-name =input-tags))) (int 0) (to-array []))]
- _ (compile ?body)
+ _ (compile (&o/optimize ?body))
:let [_ (doto =method
(compile-method-return ?output)
(.visitMaxs 0 0)
@@ -311,7 +312,7 @@
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 1 ?inputs =method)
:let [_ (.visitFrame =method Opcodes/F_NEW (int (inc (&/|length =input-tags))) (to-array (&/->seq (&/$Cons bytecode-class-name =input-tags))) (int 0) (to-array []))]
- _ (compile ?body)
+ _ (compile (&o/optimize ?body))
:let [_ (doto =method
(compile-method-return ?output)
(.visitMaxs 0 0)
@@ -334,7 +335,7 @@
_ (.visitCode =method)]
=input-tags (prepare-method-inputs 0 ?inputs =method)
:let [_ (.visitFrame =method Opcodes/F_NEW (int (&/|length =input-tags)) (to-array (&/->seq =input-tags)) (int 0) (to-array []))]
- _ (compile ?body)
+ _ (compile (&o/optimize ?body))
:let [_ (doto =method
(compile-method-return ?output)
(.visitMaxs 0 0)
@@ -493,7 +494,7 @@
(.visitCode))]
_ (&/map% (fn [ftriple]
(|let [[fname fgclass fvalue] ftriple]
- (compile-jvm-putstatic compile (&/|list ?name fname fvalue fgclass))))
+ (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass))))
(constant-inits ?fields))
:let [_ (doto =method
(.visitInsn Opcodes/RETURN)
@@ -723,7 +724,7 @@
(.toByteArray (doto =class .visitEnd)))))
(do-template [<name> <op> <from-class> <from-method> <from-sig> <to-class> <to-sig>]
- (defn <name> [compile _?value]
+ (defn <name> [compile _?value special-args]
(|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
@@ -763,7 +764,7 @@
)
(do-template [<name> <op> <from1-method> <from1-sig> <from1-class> <from2-method> <from2-sig> <from2-class> <to-class> <to-sig>]
- (defn <name> [compile ?values]
+ (defn <name> [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
@@ -798,7 +799,7 @@
)
(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>]
- (defn <name> [compile ?values]
+ (defn <name> [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
@@ -841,7 +842,7 @@
)
(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>]
- (defn <name> [compile ?values]
+ (defn <name> [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
@@ -874,7 +875,7 @@
)
(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>]
- (defn <name> [compile ?values]
+ (defn <name> [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
:let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)]
^MethodVisitor *writer* &/get-writer
@@ -913,8 +914,9 @@
)
(do-template [<prim-type> <array-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>]
- (do (defn <new-name> [compile ?values]
- (|do [:let [(&/$Cons ?length (&/$Nil)) ?values]
+ (do (defn <new-name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?length (&/$Nil)) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?length)
:let [_ (doto *writer*
@@ -923,8 +925,9 @@
:let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]]
(return nil)))
- (defn <load-name> [compile ?values]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values]
+ (defn <load-name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?array)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)]
@@ -937,8 +940,9 @@
<wrapper>)]]
(return nil)))
- (defn <store-name> [compile ?values]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values]
+ (defn <store-name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?array)
:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)]
@@ -964,8 +968,9 @@
Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char
)
-(defn ^:private compile-jvm-anewarray [compile ?values]
- (|do [:let [(&/$Cons ?gclass (&/$Cons ?length (&/$Cons type-env (&/$Nil)))) ?values]
+(defn ^:private compile-jvm-anewarray [compile ?values special-args]
+ (|do [:let [(&/$Cons ?length (&/$Nil)) ?values
+ (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?length)
:let [_ (doto *writer*
@@ -974,8 +979,9 @@
:let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]]
(return nil)))
-(defn ^:private compile-jvm-aaload [compile ?values]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values]
+(defn ^:private compile-jvm-aaload [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
array-type (&host/->java-sig (&a/expr-type* ?array))
_ (compile ?array)
@@ -987,8 +993,9 @@
:let [_ (.visitInsn *writer* Opcodes/AALOAD)]]
(return nil)))
-(defn ^:private compile-jvm-aastore [compile ?values]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values]
+(defn ^:private compile-jvm-aastore [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
array-type (&host/->java-sig (&a/expr-type* ?array))
_ (compile ?array)
@@ -1002,8 +1009,9 @@
:let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
(return nil)))
-(defn ^:private compile-jvm-arraylength [compile ?values]
- (|do [:let [(&/$Cons ?array (&/$Nil)) ?values]
+(defn ^:private compile-jvm-arraylength [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Nil)) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
array-type (&host/->java-sig (&a/expr-type* ?array))
_ (compile ?array)
@@ -1014,14 +1022,16 @@
&&/wrap-long)]]
(return nil)))
-(defn ^:private compile-jvm-null [compile ?values]
- (|do [:let [(&/$Nil) ?values]
+(defn ^:private compile-jvm-null [compile ?values special-args]
+ (|do [:let [(&/$Nil) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
:let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
(return nil)))
-(defn ^:private compile-jvm-null? [compile ?values]
- (|do [:let [(&/$Cons ?object (&/$Nil)) ?values]
+(defn ^:private compile-jvm-null? [compile ?values special-args]
+ (|do [:let [(&/$Cons ?object (&/$Nil)) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?object)
:let [$then (new Label)
@@ -1036,8 +1046,9 @@
(return nil)))
(do-template [<name> <op>]
- (defn <name> [compile ?values]
- (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?monitor)
:let [_ (doto *writer*
@@ -1049,15 +1060,17 @@
^:private compile-jvm-monitorexit Opcodes/MONITOREXIT
)
-(defn ^:private compile-jvm-throw [compile ?values]
- (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values]
+(defn ^:private compile-jvm-throw [compile ?values special-args]
+ (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?ex)
:let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
(return nil)))
-(defn ^:private compile-jvm-getstatic [compile ?values]
- (|do [:let [(&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) ?values]
+(defn ^:private compile-jvm-getstatic [compile ?values special-args]
+ (|do [:let [(&/$Nil) ?values
+ (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
^MethodVisitor *writer* &/get-writer
=output-type (&host/->java-sig ?output-type)
:let [_ (doto *writer*
@@ -1065,8 +1078,9 @@
(prepare-return! ?output-type))]]
(return nil)))
-(defn ^:private compile-jvm-getfield [compile ?values]
- (|do [:let [(&/$Cons ?class (&/$Cons ?field (&/$Cons ?object (&/$Cons ?output-type (&/$Nil))))) ?values]
+(defn ^:private compile-jvm-getfield [compile ?values special-args]
+ (|do [:let [(&/$Cons ?object (&/$Nil)) ?values
+ (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
:let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
_ (compile ?object)
@@ -1077,8 +1091,9 @@
(prepare-return! ?output-type))]]
(return nil)))
-(defn ^:private compile-jvm-putstatic [compile ?values]
- (|do [:let [(&/$Cons ?class (&/$Cons ?field (&/$Cons ?value (&/$Cons input-gclass (&/$Nil))))) ?values]
+(defn ^:private compile-jvm-putstatic [compile ?values special-args]
+ (|do [:let [(&/$Cons ?value (&/$Nil)) ?values
+ (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args]
^MethodVisitor *writer* &/get-writer
_ (compile ?value)
:let [=input-sig (&host-type/gclass->sig input-gclass)
@@ -1088,8 +1103,9 @@
(.visitInsn Opcodes/ACONST_NULL))]]
(return nil)))
-(defn ^:private compile-jvm-putfield [compile ?values]
- (|do [:let [(&/$Cons ?class (&/$Cons ?field (&/$Cons ?object (&/$Cons ?value (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))))) ?values]
+(defn ^:private compile-jvm-putfield [compile ?values special-args]
+ (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values
+ (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args]
:let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
_ (compile ?object)
@@ -1102,8 +1118,9 @@
(.visitInsn Opcodes/ACONST_NULL))]]
(return nil)))
-(defn ^:private compile-jvm-invokestatic [compile ?values]
- (|do [:let [(&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?args (&/$Cons ?output-type (&/$Nil)))))) ?values]
+(defn ^:private compile-jvm-invokestatic [compile ?values special-args]
+ (|do [:let [?args ?values
+ (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Nil))))) special-args]
^MethodVisitor *writer* &/get-writer
=output-type (&host/->java-sig ?output-type)
:let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)]
@@ -1118,8 +1135,9 @@
(return nil)))
(do-template [<name> <op>]
- (defn <name> [compile ?values]
- (|do [:let [(&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?object (&/$Cons ?args (&/$Cons ?output-type (&/$Nil))))))) ?values]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?object ?args) ?values
+ (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Nil))))) special-args]
:let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
^MethodVisitor *writer* &/get-writer
=output-type (&host/->java-sig ?output-type)
@@ -1142,8 +1160,9 @@
^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL
)
-(defn ^:private compile-jvm-new [compile ?values]
- (|do [:let [(&/$Cons ?class (&/$Cons ?classes (&/$Cons ?args (&/$Nil)))) ?values]
+(defn ^:private compile-jvm-new [compile ?values special-args]
+ (|do [:let [?args ?values
+ (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args]
^MethodVisitor *writer* &/get-writer
:let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V")
class* (&host-generics/->bytecode-class-name ?class)
@@ -1160,8 +1179,9 @@
(.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
(return nil)))
-(defn ^:private compile-jvm-try [compile ?values]
- (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values]
+(defn ^:private compile-jvm-try [compile ?values special-args]
+ (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
:let [$from (new Label)
$to (new Label)
@@ -1182,8 +1202,9 @@
:let [_ (.visitLabel *writer* $end)]]
(return nil)))
-(defn ^:private compile-jvm-instanceof [compile ?values]
- (|do [:let [(&/$Cons class (&/$Cons object (&/$Nil))) ?values]
+(defn ^:private compile-jvm-instanceof [compile ?values special-args]
+ (|do [:let [(&/$Cons object (&/$Nil)) ?values
+ (&/$Cons class (&/$Nil)) special-args]
:let [class* (&host-generics/->bytecode-class-name class)]
^MethodVisitor *writer* &/get-writer
_ (compile object)
@@ -1192,8 +1213,9 @@
(&&/wrap-boolean))]]
(return nil)))
-(defn ^:private compile-array-get [compile ?values]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values]
+(defn ^:private compile-array-get [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
+ (&/$Nil) special-args]
^MethodVisitor *writer* &/get-writer
array-type (&host/->java-sig (&a/expr-type* ?array))
_ (compile ?array)
@@ -1223,108 +1245,108 @@
(.visitLabel $end))]]
(return nil)))
-(defn compile-host [compile proc-category proc-name ?values]
+(defn compile-host [compile proc-category proc-name ?values special-args]
(case proc-category
"array"
(case proc-name
- "get" (compile-array-get compile ?values))
+ "get" (compile-array-get compile ?values special-args))
"jvm"
(case proc-name
- "instanceof" (compile-jvm-instanceof compile ?values)
- "try" (compile-jvm-try compile ?values)
- "new" (compile-jvm-new compile ?values)
- "invokestatic" (compile-jvm-invokestatic compile ?values)
- "invokevirtual" (compile-jvm-invokevirtual compile ?values)
- "invokeinterface" (compile-jvm-invokeinterface compile ?values)
- "invokespecial" (compile-jvm-invokespecial compile ?values)
- "getstatic" (compile-jvm-getstatic compile ?values)
- "getfield" (compile-jvm-getfield compile ?values)
- "putstatic" (compile-jvm-putstatic compile ?values)
- "putfield" (compile-jvm-putfield compile ?values)
- "throw" (compile-jvm-throw compile ?values)
- "monitorenter" (compile-jvm-monitorenter compile ?values)
- "monitorexit" (compile-jvm-monitorexit compile ?values)
- "null?" (compile-jvm-null? compile ?values)
- "null" (compile-jvm-null compile ?values)
- "anewarray" (compile-jvm-anewarray compile ?values)
- "aaload" (compile-jvm-aaload compile ?values)
- "aastore" (compile-jvm-aastore compile ?values)
- "arraylength" (compile-jvm-arraylength compile ?values)
- "znewarray" (compile-jvm-znewarray compile ?values)
- "bnewarray" (compile-jvm-bnewarray compile ?values)
- "snewarray" (compile-jvm-snewarray compile ?values)
- "inewarray" (compile-jvm-inewarray compile ?values)
- "lnewarray" (compile-jvm-lnewarray compile ?values)
- "fnewarray" (compile-jvm-fnewarray compile ?values)
- "dnewarray" (compile-jvm-dnewarray compile ?values)
- "cnewarray" (compile-jvm-cnewarray compile ?values)
- "iadd" (compile-jvm-iadd compile ?values)
- "isub" (compile-jvm-isub compile ?values)
- "imul" (compile-jvm-imul compile ?values)
- "idiv" (compile-jvm-idiv compile ?values)
- "irem" (compile-jvm-irem compile ?values)
- "ieq" (compile-jvm-ieq compile ?values)
- "ilt" (compile-jvm-ilt compile ?values)
- "igt" (compile-jvm-igt compile ?values)
- "ceq" (compile-jvm-ceq compile ?values)
- "clt" (compile-jvm-clt compile ?values)
- "cgt" (compile-jvm-cgt compile ?values)
- "ladd" (compile-jvm-ladd compile ?values)
- "lsub" (compile-jvm-lsub compile ?values)
- "lmul" (compile-jvm-lmul compile ?values)
- "ldiv" (compile-jvm-ldiv compile ?values)
- "lrem" (compile-jvm-lrem compile ?values)
- "leq" (compile-jvm-leq compile ?values)
- "llt" (compile-jvm-llt compile ?values)
- "lgt" (compile-jvm-lgt compile ?values)
- "fadd" (compile-jvm-fadd compile ?values)
- "fsub" (compile-jvm-fsub compile ?values)
- "fmul" (compile-jvm-fmul compile ?values)
- "fdiv" (compile-jvm-fdiv compile ?values)
- "frem" (compile-jvm-frem compile ?values)
- "feq" (compile-jvm-feq compile ?values)
- "flt" (compile-jvm-flt compile ?values)
- "fgt" (compile-jvm-fgt compile ?values)
- "dadd" (compile-jvm-dadd compile ?values)
- "dsub" (compile-jvm-dsub compile ?values)
- "dmul" (compile-jvm-dmul compile ?values)
- "ddiv" (compile-jvm-ddiv compile ?values)
- "drem" (compile-jvm-drem compile ?values)
- "deq" (compile-jvm-deq compile ?values)
- "dlt" (compile-jvm-dlt compile ?values)
- "dgt" (compile-jvm-dgt compile ?values)
- "iand" (compile-jvm-iand compile ?values)
- "ior" (compile-jvm-ior compile ?values)
- "ixor" (compile-jvm-ixor compile ?values)
- "ishl" (compile-jvm-ishl compile ?values)
- "ishr" (compile-jvm-ishr compile ?values)
- "iushr" (compile-jvm-iushr compile ?values)
- "land" (compile-jvm-land compile ?values)
- "lor" (compile-jvm-lor compile ?values)
- "lxor" (compile-jvm-lxor compile ?values)
- "lshl" (compile-jvm-lshl compile ?values)
- "lshr" (compile-jvm-lshr compile ?values)
- "lushr" (compile-jvm-lushr compile ?values)
- "d2f" (compile-jvm-d2f compile ?values)
- "d2i" (compile-jvm-d2i compile ?values)
- "d2l" (compile-jvm-d2l compile ?values)
- "f2d" (compile-jvm-f2d compile ?values)
- "f2i" (compile-jvm-f2i compile ?values)
- "f2l" (compile-jvm-f2l compile ?values)
- "i2b" (compile-jvm-i2b compile ?values)
- "i2c" (compile-jvm-i2c compile ?values)
- "i2d" (compile-jvm-i2d compile ?values)
- "i2f" (compile-jvm-i2f compile ?values)
- "i2l" (compile-jvm-i2l compile ?values)
- "i2s" (compile-jvm-i2s compile ?values)
- "l2d" (compile-jvm-l2d compile ?values)
- "l2f" (compile-jvm-l2f compile ?values)
- "l2i" (compile-jvm-l2i compile ?values)
- "c2b" (compile-jvm-c2b compile ?values)
- "c2s" (compile-jvm-c2s compile ?values)
- "c2i" (compile-jvm-c2i compile ?values)
- "c2l" (compile-jvm-c2l compile ?values)
+ "instanceof" (compile-jvm-instanceof compile ?values special-args)
+ "try" (compile-jvm-try compile ?values special-args)
+ "new" (compile-jvm-new compile ?values special-args)
+ "invokestatic" (compile-jvm-invokestatic compile ?values special-args)
+ "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args)
+ "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args)
+ "invokespecial" (compile-jvm-invokespecial compile ?values special-args)
+ "getstatic" (compile-jvm-getstatic compile ?values special-args)
+ "getfield" (compile-jvm-getfield compile ?values special-args)
+ "putstatic" (compile-jvm-putstatic compile ?values special-args)
+ "putfield" (compile-jvm-putfield compile ?values special-args)
+ "throw" (compile-jvm-throw compile ?values special-args)
+ "monitorenter" (compile-jvm-monitorenter compile ?values special-args)
+ "monitorexit" (compile-jvm-monitorexit compile ?values special-args)
+ "null?" (compile-jvm-null? compile ?values special-args)
+ "null" (compile-jvm-null compile ?values special-args)
+ "anewarray" (compile-jvm-anewarray compile ?values special-args)
+ "aaload" (compile-jvm-aaload compile ?values special-args)
+ "aastore" (compile-jvm-aastore compile ?values special-args)
+ "arraylength" (compile-jvm-arraylength compile ?values special-args)
+ "znewarray" (compile-jvm-znewarray compile ?values special-args)
+ "bnewarray" (compile-jvm-bnewarray compile ?values special-args)
+ "snewarray" (compile-jvm-snewarray compile ?values special-args)
+ "inewarray" (compile-jvm-inewarray compile ?values special-args)
+ "lnewarray" (compile-jvm-lnewarray compile ?values special-args)
+ "fnewarray" (compile-jvm-fnewarray compile ?values special-args)
+ "dnewarray" (compile-jvm-dnewarray compile ?values special-args)
+ "cnewarray" (compile-jvm-cnewarray compile ?values special-args)
+ "iadd" (compile-jvm-iadd compile ?values special-args)
+ "isub" (compile-jvm-isub compile ?values special-args)
+ "imul" (compile-jvm-imul compile ?values special-args)
+ "idiv" (compile-jvm-idiv compile ?values special-args)
+ "irem" (compile-jvm-irem compile ?values special-args)
+ "ieq" (compile-jvm-ieq compile ?values special-args)
+ "ilt" (compile-jvm-ilt compile ?values special-args)
+ "igt" (compile-jvm-igt compile ?values special-args)
+ "ceq" (compile-jvm-ceq compile ?values special-args)
+ "clt" (compile-jvm-clt compile ?values special-args)
+ "cgt" (compile-jvm-cgt compile ?values special-args)
+ "ladd" (compile-jvm-ladd compile ?values special-args)
+ "lsub" (compile-jvm-lsub compile ?values special-args)
+ "lmul" (compile-jvm-lmul compile ?values special-args)
+ "ldiv" (compile-jvm-ldiv compile ?values special-args)
+ "lrem" (compile-jvm-lrem compile ?values special-args)
+ "leq" (compile-jvm-leq compile ?values special-args)
+ "llt" (compile-jvm-llt compile ?values special-args)
+ "lgt" (compile-jvm-lgt compile ?values special-args)
+ "fadd" (compile-jvm-fadd compile ?values special-args)
+ "fsub" (compile-jvm-fsub compile ?values special-args)
+ "fmul" (compile-jvm-fmul compile ?values special-args)
+ "fdiv" (compile-jvm-fdiv compile ?values special-args)
+ "frem" (compile-jvm-frem compile ?values special-args)
+ "feq" (compile-jvm-feq compile ?values special-args)
+ "flt" (compile-jvm-flt compile ?values special-args)
+ "fgt" (compile-jvm-fgt compile ?values special-args)
+ "dadd" (compile-jvm-dadd compile ?values special-args)
+ "dsub" (compile-jvm-dsub compile ?values special-args)
+ "dmul" (compile-jvm-dmul compile ?values special-args)
+ "ddiv" (compile-jvm-ddiv compile ?values special-args)
+ "drem" (compile-jvm-drem compile ?values special-args)
+ "deq" (compile-jvm-deq compile ?values special-args)
+ "dlt" (compile-jvm-dlt compile ?values special-args)
+ "dgt" (compile-jvm-dgt compile ?values special-args)
+ "iand" (compile-jvm-iand compile ?values special-args)
+ "ior" (compile-jvm-ior compile ?values special-args)
+ "ixor" (compile-jvm-ixor compile ?values special-args)
+ "ishl" (compile-jvm-ishl compile ?values special-args)
+ "ishr" (compile-jvm-ishr compile ?values special-args)
+ "iushr" (compile-jvm-iushr compile ?values special-args)
+ "land" (compile-jvm-land compile ?values special-args)
+ "lor" (compile-jvm-lor compile ?values special-args)
+ "lxor" (compile-jvm-lxor compile ?values special-args)
+ "lshl" (compile-jvm-lshl compile ?values special-args)
+ "lshr" (compile-jvm-lshr compile ?values special-args)
+ "lushr" (compile-jvm-lushr compile ?values special-args)
+ "d2f" (compile-jvm-d2f compile ?values special-args)
+ "d2i" (compile-jvm-d2i compile ?values special-args)
+ "d2l" (compile-jvm-d2l compile ?values special-args)
+ "f2d" (compile-jvm-f2d compile ?values special-args)
+ "f2i" (compile-jvm-f2i compile ?values special-args)
+ "f2l" (compile-jvm-f2l compile ?values special-args)
+ "i2b" (compile-jvm-i2b compile ?values special-args)
+ "i2c" (compile-jvm-i2c compile ?values special-args)
+ "i2d" (compile-jvm-i2d compile ?values special-args)
+ "i2f" (compile-jvm-i2f compile ?values special-args)
+ "i2l" (compile-jvm-i2l compile ?values special-args)
+ "i2s" (compile-jvm-i2s compile ?values special-args)
+ "l2d" (compile-jvm-l2d compile ?values special-args)
+ "l2f" (compile-jvm-l2f compile ?values special-args)
+ "l2i" (compile-jvm-l2i compile ?values special-args)
+ "c2b" (compile-jvm-c2b compile ?values special-args)
+ "c2s" (compile-jvm-c2s compile ?values special-args)
+ "c2i" (compile-jvm-c2i compile ?values special-args)
+ "c2l" (compile-jvm-c2l compile ?values special-args)
;; else
(fail (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))
diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj
index 7a7f5f9a6..ecb2066cd 100644
--- a/src/lux/compiler/io.clj
+++ b/src/lux/compiler/io.clj
@@ -20,7 +20,7 @@
;; [Resources]
(defn read-file [source-dirs ^String file-name]
(|case (&/|some (fn [source-dir]
- (let [file (new java.io.File (str source-dir "/" file-name))]
+ (let [file (new java.io.File (str source-dir "/" file-name))]
(if (.exists file)
(&/$Some file)
&/$None)))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 83714517f..987928db6 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -9,12 +9,13 @@
[template :refer [do-template]])
clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|do return* return fail fail* |case]]
+ (lux [base :as & :refer [|do return* return fail fail* |case |let]]
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
[analyser :as &analyser]
- [host :as &host])
+ [host :as &host]
+ [optimizer :as &o])
[lux.host.generics :as &host-generics]
[lux.analyser.base :as &a]
(lux.compiler [base :as &&]))
@@ -24,59 +25,84 @@
MethodVisitor)))
;; [Utils]
-(def ^:private clo-field-sig (&host-generics/->type-signature "java.lang.Object"))
+(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object"))
(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object"))
(def ^:private <init>-return "V")
+(def ^:private num-args-field "_num_args_")
+(defn ^:private ^String reset-signature [function-class]
+ (str "()" (&host-generics/->type-signature function-class)))
-(def ^:private lambda-impl-signature
- (str "(" clo-field-sig ")" lambda-return-sig))
+(defn ^:private ^MethodVisitor get-num-args! [^MethodVisitor method-writer class-name]
+ (doto method-writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name num-args-field "I")))
-(defn ^:private lambda-<init>-signature [env]
- (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")"
- <init>-return))
+(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by]
+ (doto method-writer
+ (.visitLdcInsn (int by))
+ (.visitInsn Opcodes/IADD)))
-(defn ^:private add-lambda-<init> [class class-name env]
- (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "<init>" (lambda-<init>-signature env) nil nil)
- (.visitCode)
+(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name]
+ (doto method-writer
(.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
- (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
- (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
- (|case ?name+?captured
- [?name [_ (&a/$captured _ ?captured-id ?source)]])
- (doseq [?name+?captured (&/->seq env)])))
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
-
-(defn ^:private add-lambda-apply [class class-name env]
- (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "apply" &&/apply-signature nil nil)
- (.visitCode)
+ (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig)))
+
+(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk]
+ (doto method-writer
(.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" lambda-impl-signature)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
+ value-thunk
+ (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig)))
+
+(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount]
+ (doto method-writer
+ (-> (.visitInsn Opcodes/ACONST_NULL)
+ (->> (dotimes [_ amount])))))
+
+(defn ^:private lambda-impl-signature [level]
+ (str "(" (&/fold str "" (&/|repeat level field-sig)) ")" lambda-return-sig))
+
+(defn ^:private lambda-<init>-signature [env level]
+ (if (> level 1)
+ (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec level) field-sig)) ")"
+ <init>-return)
+ (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")"
+ <init>-return)))
+
+(defn ^:private add-lambda-<init> [class class-name level env]
+ (let [closure-length (&/|length env)]
+ (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "<init>" (lambda-<init>-signature env level) nil nil)
+ (.visitCode)
+ ;; Do normal object initialization
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
+ ;; Add all of the closure variables
+ (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn % Opcodes/ALOAD (inc ?captured-id)))
+ (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured])
+ (doseq [?name+?captured (&/->seq env)])))
+ (-> (doto (put-field! class-name num-args-field "I" #(.visitVarInsn % Opcodes/ILOAD (inc closure-length))) ;; Add the counter
+ ;; Add all the partial arguments
+ (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn % Opcodes/ALOAD partial-register))
+ (->> (|let [partial-register (+ (inc idx*) (inc closure-length))])
+ (dotimes [idx* (dec level)]))))
+ (->> (when (> level 1))))
+ ;; Finish
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
(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)
+ (defn ^:private add-lambda-impl [class class-name compile level impl-body]
+ (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" (lambda-impl-signature level) 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]
+(defn ^:private instance-closure [compile lambda-class level closed-over]
(|do [^MethodVisitor *writer* &/get-writer
:let [_ (doto *writer*
(.visitTypeInsn Opcodes/NEW lambda-class)
@@ -86,30 +112,127 @@
[?name [_ (&a/$captured _ _ ?source)]]
(compile ?source)))
closed-over)
- :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature)]]
+ :let [_ (when (> level 1)
+ (doto *writer*
+ (.visitLdcInsn (int 0))
+ (fill-nulls! (dec level))))]
+ :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" (lambda-<init>-signature closed-over level))]]
(return nil)))
+(defn ^:private add-lambda-reset [class-writer class-name level env]
+ (if (> level 1)
+ (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil)
+ (.visitCode)
+ (.visitTypeInsn Opcodes/NEW class-name)
+ (.visitInsn Opcodes/DUP)
+ (-> (get-field! class-name (str &&/closure-prefix cidx))
+ (->> (dotimes [cidx (&/|length env)])))
+ (.visitLdcInsn (int 0))
+ (fill-nulls! (dec level))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env level))
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
+(defn ^:private add-lambda-apply [class-writer class-name level env]
+ (if (> level 1)
+ (let [$default (new Label)
+ $labels* (map (fn [_] (new Label)) (repeat (dec level) nil))
+ $labels (vec (concat $labels* (list $default)))
+ $end (new Label)
+ method-writer (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "apply" &&/apply-signature nil nil)]
+ (doto method-writer
+ (.visitCode)
+ (get-num-args! class-name)
+ (.visitFrame Opcodes/F_NEW
+ (int 2)
+ (to-array (list class-name "java/lang/Object"))
+ (int 1)
+ (to-array [Opcodes/INTEGER]))
+ (.visitTableSwitchInsn 0 (- level 2) $default (into-array $labels*))
+ (-> (doto (.visitLabel $label)
+ (.visitFrame Opcodes/F_NEW
+ (int 2)
+ (to-array (list class-name "java/lang/Object"))
+ (int 0)
+ (to-array []))
+ (.visitTypeInsn Opcodes/NEW class-name)
+ (.visitInsn Opcodes/DUP)
+ (-> (get-field! class-name (str &&/closure-prefix cidx))
+ (->> (dotimes [cidx (&/|length env)])))
+ (get-num-args! class-name)
+ (inc-int! 1)
+ (-> (get-field! class-name (str &&/partial-prefix idx))
+ (->> (dotimes [idx stage])))
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (fill-nulls! (dec (- (dec level) stage)))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (lambda-<init>-signature env level))
+ (.visitJumpInsn Opcodes/GOTO $end))
+ (->> (cond (= stage (dec level))
+ (doto method-writer
+ (.visitLabel $label)
+ (.visitFrame Opcodes/F_NEW
+ (int 2)
+ (to-array (list class-name "java/lang/Object"))
+ (int 0)
+ (to-array []))
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name))
+ (-> (get-field! class-name (str &&/partial-prefix idx))
+ (->> (dotimes [idx stage])))
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level))
+ (.visitJumpInsn Opcodes/GOTO $end))
+
+ :else)
+ (doseq [[stage $label] (map vector (range level) $labels)])))
+ (.visitLabel $end)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "apply" &&/apply-signature nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature level))
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
;; [Exports]
(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]
+ (defn compile-function [compile level ?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 "java/lang/Object" (into-array [&&/function-class]))
- (-> (doto (.visitField datum-flags captured-name clo-field-sig nil nil)
+ (-> (doto (.visitField datum-flags captured-name field-sig nil nil)
(.visitEnd))
(->> (let [captured-name (str &&/closure-prefix ?captured-id)])
(|case ?name+?captured
- [?name [_ (&a/$captured _ ?captured-id ?source)]])
+ [?name [_ (&o/$captured _ ?captured-id ?source)]])
(doseq [?name+?captured (&/->seq ?env)])))
+ (-> (doto (-> (.visitField datum-flags num-args-field "I" nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil)
+ (doto (.visitEnd))
+ (->> (dotimes [idx (dec level)]))))
+ (->> (when (> level 1))))
(.visitSource file-name nil)
- (add-lambda-apply class-name ?env)
- (add-lambda-<init> class-name ?env)
+ (add-lambda-reset class-name level ?env)
+ (add-lambda-apply class-name level ?env)
+ (add-lambda-<init> class-name level ?env)
)]
- _ (add-lambda-impl =class compile lambda-impl-signature ?body)
+ _ (add-lambda-impl =class class-name compile level ?body)
:let [_ (.visitEnd =class)]
_ (&&/save-class! name (.toByteArray =class))]
- (instance-closure compile class-name ?env (lambda-<init>-signature ?env)))))
+ (instance-closure compile class-name level ?env))))
diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj
index f996587b5..4b617b591 100644
--- a/src/lux/optimizer.clj
+++ b/src/lux/optimizer.clj
@@ -6,7 +6,8 @@
(ns lux.optimizer
(:require (lux [base :as & :refer [|let |do return fail return* fail* |case defvariant]]
[analyser :as &analyser])
- [lux.analyser.base :as &-base]))
+ (lux.analyser [base :as &-base]
+ [case :as &a-case])))
;; [Tags]
(defvariant
@@ -15,67 +16,223 @@
("real" 1)
("char" 1)
("text" 1)
- ("variant" 1)
+ ("variant" 3)
("tuple" 1)
- ("apply" 1)
- ("case" 1)
- ("lambda" 1)
- ("ann" 1)
+ ("apply" 2)
+ ("case" 2)
+ ("function" 4)
+ ("ann" 3)
("var" 1)
- ("captured" 1)
- ("proc" 2)
+ ("captured" 3)
+ ("proc" 3)
)
+;; [Utils]
+(defn ^:private shift-pattern [pattern]
+ (|case pattern
+ (&a-case/$StoreTestAC idx)
+ (&a-case/$StoreTestAC (inc idx))
+
+ (&a-case/$TupleTestAC sub-tests)
+ (&a-case/$TupleTestAC (&/|map shift-pattern sub-tests))
+
+ (&a-case/$VariantTestAC idx num-options sub-test)
+ (&a-case/$VariantTestAC (&/T [idx num-options (shift-pattern sub-test)]))
+
+ _
+ pattern
+ ))
+
+(defn ^:private drop-scope [source]
+ (|case source
+ [meta ($captured scope idx source*)]
+ (&/T [meta ($captured (&/|but-last scope) idx (drop-scope source*))])
+
+ _
+ source))
+
+(defn ^:private de-scope [scope]
+ "(-> Scope Scope)"
+ (|case scope
+ (&/$Cons _module (&/$Cons _def (&/$Cons _level-to-remove _levels-to-keep)))
+ (&/$Cons _module (&/$Cons _def _levels-to-keep))))
+
+(defn ^:private de-meta [body]
+ "(-> Optimized Optimized)"
+ (|case body
+ [meta ($variant idx is-last? value)]
+ ($variant idx is-last? (de-meta value))
+
+ [meta ($tuple elems)]
+ ($tuple (&/|map de-meta elems))
+
+ [meta ($apply func args)]
+ ($apply (de-meta func)
+ (&/|map de-meta args))
+
+ [meta ($case value branches)]
+ ($case (de-meta value)
+ (&/|map (fn [branch]
+ (|let [[_pattern _body] branch]
+ (&/T [_pattern (de-meta _body)])))
+ branches))
+
+ [meta ($function level scope captured body*)]
+ ($function level
+ scope
+ (&/|map (fn [capture]
+ (|let [[_name _captured] capture]
+ (&/T [_name (de-meta _captured)]))
+ )
+ captured)
+ (de-meta body*))
+
+ [meta ($ann value-expr type-expr type-type)]
+ ($ann (de-meta value-expr) nil nil)
+
+ [meta ($var var-kind)]
+ ($var var-kind)
+
+ [meta ($captured scope idx source)]
+ ($captured scope idx (de-meta source))
+
+ [meta ($proc proc-ident args special-args)]
+ (&/T ($proc proc-ident (&/|map de-meta args) special-args))
+
+ [meta not-interesting]
+ not-interesting
+ ))
+
+(defn ^:private shift-function-body [own-body? body]
+ "(-> Optimized Optimized)"
+ (|case body
+ [meta ($variant idx is-last? value)]
+ (&/T [meta ($variant idx is-last? (shift-function-body own-body? value))])
+
+ [meta ($tuple elems)]
+ (&/T [meta ($tuple (&/|map (partial shift-function-body own-body?) elems))])
+
+ [meta ($apply func args)]
+ (&/T [meta ($apply (shift-function-body own-body? func)
+ (&/|map (partial shift-function-body own-body?) args))])
+
+ [meta ($case value branches)]
+ (&/T [meta ($case (shift-function-body own-body? value)
+ (&/|map (fn [branch]
+ (|let [[_pattern _body] branch]
+ (&/T [(if own-body?
+ (shift-pattern _pattern)
+ _pattern)
+ (shift-function-body own-body? _body)])))
+ branches))])
+
+ [meta ($function level scope captured body*)]
+ (&/T [meta ($function level
+ (de-scope scope)
+ (&/|map (fn [capture]
+ (|let [[_name [_meta ($captured _scope _idx _source)]] capture]
+ (&/T [_name (&/T [_meta ($captured (de-scope _scope) _idx (shift-function-body own-body? _source))])])))
+ captured)
+ (shift-function-body false body*))])
+
+ [meta ($ann value-expr type-expr type-type)]
+ (&/T [meta ($ann (shift-function-body own-body? value-expr)
+ type-expr
+ type-type)])
+
+ [meta ($var var-kind)]
+ (if own-body?
+ (|case var-kind
+ (&/$Local 0)
+ (&/T [meta ($apply body
+ (&/|list [meta ($var (&/$Local 1))]))])
+
+ (&/$Local idx)
+ (&/T [meta ($var (&/$Local (inc idx)))])
+
+ (&/$Global ?module ?name)
+ body)
+ body)
+
+ [meta ($captured scope idx source)]
+ (if own-body?
+ source
+ (|case scope
+ (&/$Cons _ (&/$Cons _ (&/$Nil)))
+ source
+
+ _
+ (&/T [meta ($captured (de-scope scope) idx (shift-function-body own-body? source))]))
+ )
+
+ [meta ($proc proc-ident args special-args)]
+ (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body own-body?) args) special-args)])
+
+ not-interesting
+ not-interesting
+ ))
+
+(defn ^:private optimize-closure [optimize closure]
+ (&/|map (fn [capture]
+ (|let [[_name _analysis] capture]
+ (&/T [_name (optimize _analysis)])))
+ closure))
+
;; [Exports]
-(defn optimize-token [analysis]
+(defn optimize [analysis]
"(-> Analysis Optimized)"
(|case analysis
[meta (&-base/$bool value)]
- (return (&/T [meta ($bool value)]))
+ (&/T [meta ($bool value)])
[meta (&-base/$int value)]
- (return (&/T [meta ($int value)]))
+ (&/T [meta ($int value)])
[meta (&-base/$real value)]
- (return (&/T [meta ($real value)]))
+ (&/T [meta ($real value)])
[meta (&-base/$char value)]
- (return (&/T [meta ($char value)]))
+ (&/T [meta ($char value)])
[meta (&-base/$text value)]
- (return (&/T [meta ($text value)]))
+ (&/T [meta ($text value)])
- [meta (&-base/$variant value)]
- (return (&/T [meta ($variant value)]))
+ [meta (&-base/$variant idx is-last? value)]
+ (&/T [meta ($variant idx is-last? (optimize value))])
- [meta (&-base/$tuple value)]
- (return (&/T [meta ($tuple value)]))
+ [meta (&-base/$tuple elems)]
+ (&/T [meta ($tuple (&/|map optimize elems))])
- [meta (&-base/$apply value)]
- (return (&/T [meta ($apply value)]))
+ [meta (&-base/$apply func args)]
+ (&/T [meta ($apply (optimize func) (&/|map optimize args))])
- [meta (&-base/$case value)]
- (return (&/T [meta ($case value)]))
+ [meta (&-base/$case value branches)]
+ (&/T [meta ($case (optimize value)
+ (&/|map (fn [branch]
+ (|let [[_pattern _body] branch]
+ (&/T [_pattern (optimize _body)])))
+ branches))])
- [meta (&-base/$lambda value)]
- (return (&/T [meta ($lambda value)]))
+ [meta (&-base/$lambda scope captured body)]
+ (|case (optimize body)
+ [_ ($function _level _scope _captured _body)]
+ (&/T [meta ($function (inc _level) scope (optimize-closure optimize captured) (shift-function-body true _body))])
+
+ =body
+ (&/T [meta ($function 1 scope (optimize-closure optimize captured) =body)]))
- [meta (&-base/$ann value)]
- (return (&/T [meta ($ann value)]))
+ [meta (&-base/$ann value-expr type-expr type-type)]
+ (&/T [meta ($ann (optimize value-expr) type-expr type-type)])
- [meta (&-base/$var value)]
- (return (&/T [meta ($var value)]))
+ [meta (&-base/$var var-kind)]
+ (&/T [meta ($var var-kind)])
- [meta (&-base/$captured value)]
- (return (&/T [meta ($captured value)]))
+ [meta (&-base/$captured scope idx source)]
+ (&/T [meta ($captured scope idx (optimize source))])
- [meta (&-base/$proc ?proc-ident ?args)]
- (return (&/T [meta ($proc ?proc-ident ?args)]))
+ [meta (&-base/$proc proc-ident args special-args)]
+ (&/T [meta ($proc proc-ident (&/|map optimize args) special-args)])
_
- (assert false (prn-str 'optimize-token (&/adt->text analysis)))
+ (assert false (prn-str 'optimize (&/adt->text analysis)))
))
-
-(defn optimize [eval! compile-module compilers]
- (|do [analyses (&analyser/analyse eval! compile-module compilers)]
- (&/map% optimize-token analyses)))
diff --git a/src/lux/repl.clj b/src/lux/repl.clj
index 3861806ed..ce835ff5e 100644
--- a/src/lux/repl.clj
+++ b/src/lux/repl.clj
@@ -54,7 +54,7 @@
(|case ((|do [analysed-tokens (&analyser/repl-analyse &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers)
optimized-tokens (->> analysed-tokens
(&/|map &a-base/expr-term)
- (&/map% &optimizer/optimize-token))
+ (&/map% &optimizer/optimize))
:let [optimized-tokens* (&/->list (map (fn [analysis optim]
(|let [[[_type _cursor] _term] analysis]
(&a-base/|meta _type _cursor optim)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 13:10:10 +0000