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