diff options
| -rw-r--r-- | src/lux/analyser.clj | 35 | ||||
| -rw-r--r-- | src/lux/analyser/base.clj | 2 | ||||
| -rw-r--r-- | src/lux/analyser/case.clj | 27 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 56 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 10 | ||||
| -rw-r--r-- | src/lux/base.clj | 14 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 11 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 15 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 318 | ||||
| -rw-r--r-- | src/lux/compiler/io.clj | 2 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 213 | ||||
| -rw-r--r-- | src/lux/optimizer.clj | 231 | ||||
| -rw-r--r-- | src/lux/repl.clj | 2 |
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))) |