diff options
Diffstat (limited to 'lux-bootstrapper')
41 files changed, 13435 insertions, 0 deletions
diff --git a/lux-bootstrapper/code_of_conduct.md b/lux-bootstrapper/code_of_conduct.md new file mode 100644 index 000000000..01b8644f1 --- /dev/null +++ b/lux-bootstrapper/code_of_conduct.md @@ -0,0 +1,22 @@ +# Contributor Code of Conduct + +As contributors and maintainers of this project, and in the interest of fostering an open and welcoming community, we pledge to respect all people who contribute through reporting issues, posting feature requests, updating documentation, submitting pull requests or patches, and other activities. + +We are committed to making participation in this project a harassment-free experience for everyone, regardless of level of experience, gender, gender identity and expression, sexual orientation, disability, personal appearance, body size, race, ethnicity, age, religion, or nationality. + +Examples of unacceptable behavior by participants include: + +* The use of sexualized language or imagery +* Personal attacks +* Trolling or insulting/derogatory comments +* Public or private harassment +* Publishing other's private information, such as physical or electronic addresses, without explicit permission +* Other unethical or unprofessional conduct. + +Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct. By adopting this Code of Conduct, project maintainers commit themselves to fairly and consistently applying these principles to every aspect of managing this project. Project maintainers who do not follow or enforce the Code of Conduct may be permanently removed from the project team. + +This code of conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. + +Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by opening an issue or contacting one or more of the project maintainers. + +This Code of Conduct is adapted from the [Contributor Covenant](http://contributor-covenant.org), version 1.2.0, available at [http://contributor-covenant.org/version/1/2/0/](http://contributor-covenant.org/version/1/2/0/) diff --git a/lux-bootstrapper/project.clj b/lux-bootstrapper/project.clj new file mode 100644 index 000000000..e0525c2bb --- /dev/null +++ b/lux-bootstrapper/project.clj @@ -0,0 +1,33 @@ +(defproject com.github.luxlang/lux-bootstrapper "0.6.0-SNAPSHOT" + :min-lein-version "2.1.0" ;; 2.1.0 introduced jar classifiers + :description "The JVM compiler for the Lux programming language." + :url "https://github.com/LuxLang/lux" + :license {:name "Lux License v0.1" + :url "https://github.com/LuxLang/lux/blob/master/license.txt"} + :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" + :creds :gpg}] + ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" + :creds :gpg}]] + :pom-addition [:developers [:developer + [:name "Eduardo Julian"] + [:url "https://github.com/eduardoejp"]]] + :dependencies [[org.clojure/clojure "1.6.0"] + [org.clojure/core.match "0.2.1"] + [org.ow2.asm/asm-all "5.0.3"]] + :warn-on-reflection true + :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"] + ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"]] + :source-paths ["src"] + + :scm {:name "git" + :url "https://github.com/LuxLang/lux.git"} + + :main lux + :profiles {:uberjar {:classifiers {:sources {:resource-paths ["src"]} + :javadoc {:resource-paths ["src"]}} + :aot [lux]}} + + :jvm-opts ^:replace ["-server" "-Xms2048m" "-Xmx2048m" + "-Xss16m" + "-XX:+OptimizeStringConcat"] + ) diff --git a/lux-bootstrapper/src/lux.clj b/lux-bootstrapper/src/lux.clj new file mode 100644 index 000000000..dc6066669 --- /dev/null +++ b/lux-bootstrapper/src/lux.clj @@ -0,0 +1,35 @@ +(ns lux + (:gen-class) + (:require [lux.base :as & :refer [|let |do return return* |case]] + [lux.compiler :as &compiler] + [lux.repl :as &repl] + [clojure.string :as string] + :reload-all) + (:import (java.io File))) + +(def unit-separator (str (char 31))) + +(defn- separate-paths + "(-> Text (List Text))" + [paths] + (-> paths + (string/replace unit-separator "\n") + string/split-lines + rest + &/->list)) + +(defn -main [& args] + (|case (&/->list args) + (&/$Cons "release" (&/$Cons program-module (&/$Cons dependencies (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) + (&compiler/compile-program &/$Build program-module + (separate-paths dependencies) + (separate-paths source-dirs) + target-dir) + + (&/$Cons "repl" (&/$Cons dependencies (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))) + (&repl/repl (separate-paths dependencies) + (separate-paths source-dirs) + target-dir) + + _ + (println "Cannot understand command."))) diff --git a/lux-bootstrapper/src/lux/analyser.clj b/lux-bootstrapper/src/lux/analyser.clj new file mode 100644 index 000000000..af272fa91 --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser.clj @@ -0,0 +1,233 @@ +(ns lux.analyser + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return return* |case]] + [reader :as &reader] + [parser :as &parser] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &&] + [lux :as &&lux] + [module :as &&module] + [parser :as &&a-parser]) + (lux.analyser.proc [common :as &&common] + [jvm :as &&jvm]))) + +;; [Utils] +(defn analyse-variant+ [analyse exo-type ident values] + (|do [[module tag-name] (&/normalize ident) + _ (&&module/ensure-can-see-tag module tag-name) + idx (&&module/tag-index module tag-name) + group (&&module/tag-group module tag-name) + :let [is-last? (= idx (dec (&/|length group)))]] + (if (= 1 (&/|length group)) + (|do [_location &/location] + (analyse exo-type (&/T [_location (&/$Tuple values)]))) + (|case exo-type + (&/$Var id) + (|do [? (&type/bound? id)] + (if (or ? (&&/type-tag? module tag-name)) + (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) + (|do [wanted-type (&&module/tag-type module tag-name) + wanted-type* (&type/instantiate-inference wanted-type) + [[variant-type variant-location] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyse (&/$Left wanted-type*) idx is-last? values)) + _ (&type/check exo-type variant-type)] + (return (&/|list (&&/|meta exo-type variant-location variant-analysis)))))) + + _ + (&&lux/analyse-variant analyse (&/$Right exo-type) idx is-last? values) + )) + )) + +(defn ^:private just-analyse [analyser syntax] + (&type/with-var + (fn [?var] + (|do [[[?output-type ?output-location] ?output-term] (&&/analyse-1 analyser ?var syntax)] + (|case [?var ?output-type] + [(&/$Var ?e-id) (&/$Var ?a-id)] + (if (= ?e-id ?a-id) + (|do [=output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-location ?output-term))) + (|do [=output-type (&type/clean ?var ?var)] + (return (&&/|meta =output-type ?output-location ?output-term)))) + + [_ _] + (|do [=output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-location ?output-term)))) + )))) + +(defn ^:private analyse-ast [optimize eval! compile-module ^"[Ljava.lang.Object;" compilers exo-type ?token] + (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) + [location token] ?token + compile-def (aget compilers 0) + compile-program (aget compilers 1) + macro-caller (aget compilers 2)] + (|case token + ;; Standard special forms + (&/$Bit ?value) + (|do [_ (&type/check exo-type &type/Bit)] + (return (&/|list (&&/|meta exo-type location (&&/$bit ?value))))) + + (&/$Nat ?value) + (|do [_ (&type/check exo-type &type/Nat)] + (return (&/|list (&&/|meta exo-type location (&&/$nat ?value))))) + + (&/$Int ?value) + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&&/|meta exo-type location (&&/$int ?value))))) + + (&/$Rev ?value) + (|do [_ (&type/check exo-type &type/Rev)] + (return (&/|list (&&/|meta exo-type location (&&/$rev ?value))))) + + (&/$Frac ?value) + (|do [_ (&type/check exo-type &type/Frac)] + (return (&/|list (&&/|meta exo-type location (&&/$frac ?value))))) + + (&/$Text ?value) + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&&/|meta exo-type location (&&/$text ?value))))) + + (&/$Tuple ?elems) + (&/with-analysis-meta location exo-type + (&&lux/analyse-tuple analyse (&/$Right exo-type) ?elems)) + + (&/$Record ?elems) + (&/with-analysis-meta location exo-type + (&&lux/analyse-record analyse exo-type ?elems)) + + (&/$Tag ?ident) + (&/with-analysis-meta location exo-type + (analyse-variant+ analyse exo-type ?ident &/$Nil)) + + (&/$Identifier ?ident) + (&/with-analysis-meta location exo-type + (&&lux/analyse-identifier analyse exo-type ?ident)) + + (&/$Form (&/$Cons [command-meta command] parameters)) + (|case command + (&/$Text ?procedure) + (case ?procedure + "lux check" + (|let [(&/$Cons ?type + (&/$Cons ?value + (&/$Nil))) parameters] + (&/with-analysis-meta location exo-type + (&&lux/analyse-ann analyse eval! exo-type ?type ?value))) + + "lux check type" + (|let [(&/$Cons ?value (&/$Nil)) parameters] + (analyse-ast optimize eval! compile-module compilers &type/Type ?value)) + + "lux coerce" + (|let [(&/$Cons ?type + (&/$Cons ?value + (&/$Nil))) parameters] + (&/with-analysis-meta location exo-type + (&&lux/analyse-coerce analyse eval! exo-type ?type ?value))) + + "lux def" + (|let [(&/$Cons [_ (&/$Identifier "" ?name)] + (&/$Cons ?value + (&/$Cons ?meta + (&/$Cons [_ (&/$Bit exported?)] + (&/$Nil))) + )) parameters] + (&/with-location location + (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value ?meta exported?))) + + "lux def alias" + (|let [(&/$Cons [_ (&/$Identifier "" ?alias)] + (&/$Cons [_ (&/$Identifier ?original)] + (&/$Nil) + )) parameters] + (&/with-location location + (&&lux/analyse-def-alias ?alias ?original))) + + "lux def type tagged" + (|let [(&/$Cons [_ (&/$Identifier "" ?name)] + (&/$Cons ?value + (&/$Cons ?meta + (&/$Cons [_ (&/$Tuple ?tags)] + (&/$Cons [_ (&/$Bit exported?)] + (&/$Nil)))) + )) parameters] + (&/with-location location + (&&lux/analyse-def-type-tagged analyse optimize eval! compile-def ?name ?value ?meta ?tags exported?))) + + "lux def program" + (|let [(&/$Cons ?program (&/$Nil)) parameters] + (&/with-location location + (&&lux/analyse-program analyse optimize compile-program ?program))) + + "lux def module" + (|let [(&/$Cons ?meta (&/$Cons ?imports (&/$Nil))) parameters] + (&/with-location location + (&&lux/analyse-module analyse optimize eval! compile-module ?meta ?imports))) + + "lux in-module" + (|let [(&/$Cons [_ (&/$Text ?module)] (&/$Cons ?expr (&/$Nil))) parameters] + (&/with-location location + (&/with-module ?module + (analyse exo-type ?expr)))) + + ;; else + (&/with-analysis-meta location exo-type + (cond (.startsWith ^String ?procedure "jvm") + (|do [_ &/jvm-host] + (&&jvm/analyse-host analyse exo-type compilers ?procedure parameters)) + + :else + (&&common/analyse-proc analyse exo-type ?procedure parameters)))) + + (&/$Nat idx) + (|let [(&/$Cons [_ (&/$Bit ?right)] parameters*) parameters] + (&/with-analysis-meta location exo-type + (&&lux/analyse-variant analyse (&/$Right exo-type) (if ?right (inc idx) idx) ?right parameters*))) + + (&/$Tag ?ident) + (&/with-analysis-meta location exo-type + (analyse-variant+ analyse exo-type ?ident parameters)) + + ;; Pattern-matching syntax. + (&/$Record ?pattern-matching) + (|let [(&/$Cons ?input (&/$Nil)) parameters] + (&/with-analysis-meta location exo-type + (&&lux/analyse-case analyse exo-type ?input ?pattern-matching))) + + ;; Function syntax. + (&/$Tuple (&/$Cons [_ (&/$Identifier "" ?self)] + (&/$Cons [_ (&/$Identifier "" ?arg)] (&/$Nil)))) + (|let [(&/$Cons ?body (&/$Nil)) parameters] + (&/with-analysis-meta location exo-type + (&&lux/analyse-function analyse exo-type ?self ?arg ?body))) + + _ + (&/with-location location + (|do [=fn (just-analyse analyse (&/T [command-meta command]))] + (&&lux/analyse-apply analyse location exo-type macro-caller =fn parameters)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (&/show-ast (&/T [(&/T ["" -1 -1]) token])))) + ))) + +;; [Resources] +(defn analyse [optimize eval! compile-module compilers] + (|do [asts &parser/parse] + (&/flat-map% (partial analyse-ast optimize eval! compile-module compilers &type/Nothing) asts))) + +(defn clean-output [?var analysis] + (|do [:let [[[?output-type ?output-location] ?output-term] analysis] + =output-type (&type/clean ?var ?output-type)] + (return (&&/|meta =output-type ?output-location ?output-term)))) + +(defn repl-analyse [optimize eval! compile-module compilers] + (|do [asts &parser/parse] + (&/flat-map% (fn [ast] + (&type/with-var + (fn [?var] + (|do [=outputs (&/with-closure + (analyse-ast optimize eval! compile-module compilers ?var ast))] + (&/map% (partial clean-output ?var) =outputs))))) + asts))) diff --git a/lux-bootstrapper/src/lux/analyser/base.clj b/lux-bootstrapper/src/lux/analyser/base.clj new file mode 100644 index 000000000..d6787280f --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/base.clj @@ -0,0 +1,127 @@ +(ns lux.analyser.base + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [defvariant |let |do return* return |case]] + [type :as &type]))) + +;; [Tags] +(defvariant + ("bit" 1) + ("nat" 1) + ("int" 1) + ("rev" 1) + ("frac" 1) + ("text" 1) + ("variant" 3) + ("tuple" 1) + ("apply" 2) + ("case" 2) + ("function" 4) + ("ann" 2) + ("def" 1) + ("var" 1) + ("captured" 1) + ("proc" 3) + ) + +;; [Exports] +(defn expr-meta [analysis] + (|let [[meta _] analysis] + meta)) + +(defn expr-type* [analysis] + (|let [[[type _] _] analysis] + type)) + +(defn expr-term [analysis] + (|let [[[type _] term] analysis] + term)) + +(defn with-type [new-type analysis] + (|let [[[type location] adt] analysis] + (&/T [(&/T [new-type location]) adt]))) + +(defn clean-analysis + "(-> Type Analysis (Lux Analysis))" + [$var an] + (|do [=an-type (&type/clean $var (expr-type* an))] + (return (with-type =an-type an)))) + +(def jvm-this "_jvm_this") + +(defn cap-1 [action] + (|do [result action] + (|case result + (&/$Cons x (&/$Nil)) + (return x) + + _ + (&/fail-with-loc "[Analyser Error] Macro cannot expand to more than 1 output.")))) + +(defn analyse-1 [analyse exo-type elem] + (&/with-expected-type exo-type + (cap-1 (analyse exo-type elem)))) + +(defn analyse-1+ [analyse ?token] + (&type/with-var + (fn [$var] + (|do [=expr (analyse-1 analyse $var ?token)] + (clean-analysis $var =expr))))) + +(defn resolved-ident [ident] + (|do [:let [[?module ?name] ident] + module* (if (.equals "" ?module) + &/get-module-name + (return ?module))] + (return (&/T [module* ?name])))) + +(let [tag-names #{"Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"}] + (defn type-tag? [module name] + (and (= "lux" module) + (contains? tag-names name)))) + +(defn |meta [type location analysis] + (&/T [(&/T [type location]) analysis])) + +(defn de-meta + "(-> Analysis Analysis)" + [analysis] + (|let [[meta analysis-] analysis] + (|case analysis- + ($variant idx is-last? value) + ($variant idx is-last? (de-meta value)) + + ($tuple elems) + ($tuple (&/|map de-meta elems)) + + ($apply func args) + ($apply (de-meta func) + (&/|map de-meta args)) + + ($case value branches) + ($case (de-meta value) + (&/|map (fn [branch] + (|let [[_pattern _body] branch] + (&/T [_pattern (de-meta _body)]))) + branches)) + + ($function _register-offset scope captured body) + ($function _register-offset scope + (&/|map (fn [branch] + (|let [[_name _captured] branch] + (&/T [_name (de-meta _captured)]))) + captured) + (de-meta body)) + + ($ann value-expr type-expr) + (de-meta value-expr) + + ($captured scope idx source) + ($captured scope idx (de-meta source)) + + ($proc proc-ident args special-args) + ($proc proc-ident (&/|map de-meta args) special-args) + + _ + analysis- + ))) diff --git a/lux-bootstrapper/src/lux/analyser/case.clj b/lux-bootstrapper/src/lux/analyser/case.clj new file mode 100644 index 000000000..d059ce189 --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/case.clj @@ -0,0 +1,637 @@ +(ns lux.analyser.case + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [defvariant |do return |let |case]] + [parser :as &parser] + [type :as &type]) + (lux.analyser [base :as &&] + [env :as &env] + [module :as &module] + [record :as &&record]))) + +;; [Tags] +(defvariant + ("DefaultTotal" 1) + ("BitTotal" 2) + ("NatTotal" 2) + ("IntTotal" 2) + ("RevTotal" 2) + ("FracTotal" 2) + ("TextTotal" 2) + ("TupleTotal" 2) + ("VariantTotal" 2)) + +(defvariant + ("NoTestAC" 0) + ("StoreTestAC" 1) + ("BitTestAC" 1) + ("NatTestAC" 1) + ("IntTestAC" 1) + ("RevTestAC" 1) + ("FracTestAC" 1) + ("TextTestAC" 1) + ("TupleTestAC" 1) + ("VariantTestAC" 1)) + +;; [Utils] +(def ^:private unit-tuple + (&/T [(&/T ["" -1 -1]) (&/$Tuple &/$Nil)])) + +(defn ^:private resolve-type [type] + (if (&type/type= &type/Any type) + (return type) + (|case type + (&/$Var ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (&/fail-with-loc "##1##")))] + (resolve-type type*)) + + (&/$UnivQ _) + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + + (&/$ExQ _ _) + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + + _ + (&type/actual-type type)))) + +(defn update-up-frame [frame] + (|let [[_env _idx _var] frame] + (&/T [_env (+ 2 _idx) _var]))) + +(defn clean! [level ?tid parameter-idx type] + (|case type + (&/$Var ?id) + (if (= ?tid ?id) + (&/$Parameter (+ (* 2 level) parameter-idx)) + type) + + (&/$Primitive ?name ?params) + (&/$Primitive ?name (&/|map (partial clean! level ?tid parameter-idx) + ?params)) + + (&/$Function ?arg ?return) + (&/$Function (clean! level ?tid parameter-idx ?arg) + (clean! level ?tid parameter-idx ?return)) + + (&/$Apply ?param ?lambda) + (&/$Apply (clean! level ?tid parameter-idx ?param) + (clean! level ?tid parameter-idx ?lambda)) + + (&/$Product ?left ?right) + (&/$Product (clean! level ?tid parameter-idx ?left) + (clean! level ?tid parameter-idx ?right)) + + (&/$Sum ?left ?right) + (&/$Sum (clean! level ?tid parameter-idx ?left) + (clean! level ?tid parameter-idx ?right)) + + (&/$UnivQ ?env ?body) + (&/$UnivQ (&/|map (partial clean! level ?tid parameter-idx) ?env) + (clean! (inc level) ?tid parameter-idx ?body)) + + (&/$ExQ ?env ?body) + (&/$ExQ (&/|map (partial clean! level ?tid parameter-idx) ?env) + (clean! (inc level) ?tid parameter-idx ?body)) + + _ + type + )) + +(defn beta-reduce! [level env type] + (|case type + (&/$Primitive ?name ?params) + (&/$Primitive ?name (&/|map (partial beta-reduce! level env) ?params)) + + (&/$Sum ?left ?right) + (&/$Sum (beta-reduce! level env ?left) + (beta-reduce! level env ?right)) + + (&/$Product ?left ?right) + (&/$Product (beta-reduce! level env ?left) + (beta-reduce! level env ?right)) + + (&/$Apply ?type-arg ?type-fn) + (&/$Apply (beta-reduce! level env ?type-arg) + (beta-reduce! level env ?type-fn)) + + (&/$UnivQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (&/$UnivQ ?local-env (beta-reduce! (inc level) env ?local-def)) + + _ + type) + + (&/$ExQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (&/$ExQ ?local-env (beta-reduce! (inc level) env ?local-def)) + + _ + type) + + (&/$Function ?input ?output) + (&/$Function (beta-reduce! level env ?input) + (beta-reduce! level env ?output)) + + (&/$Parameter ?idx) + (|case (&/|at (- ?idx (* 2 level)) env) + (&/$Some parameter) + (beta-reduce! level env parameter) + + _ + type) + + _ + type + )) + +(defn apply-type! [type-fn param] + (|case type-fn + (&/$UnivQ local-env local-def) + (return (beta-reduce! 0 (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$ExQ local-env local-def) + (return (beta-reduce! 0 (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$Apply A F) + (|do [type-fn* (apply-type! F A)] + (apply-type! type-fn* param)) + + (&/$Named ?name ?type) + (apply-type! ?type param) + + (&/$Ex id) + (return (&/$Apply param type-fn)) + + (&/$Var id) + (|do [=type-fun (deref id)] + (apply-type! =type-fun param)) + + _ + (&/fail-with-loc (str "[Type System] Not a type-function:\n" (&type/show-type type-fn) "\n")))) + +(defn adjust-type* [up type] + "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" + (|case type + (&/$UnivQ _aenv _abody) + (&type/with-var + (fn [$var] + (|do [=type (apply-type! type $var) + ==type (adjust-type* (&/$Cons (&/T [_aenv 1 $var]) + (&/|map update-up-frame up)) + =type)] + (&type/clean $var ==type)))) + + (&/$ExQ _aenv _abody) + (|do [$var &type/existential + =type (apply-type! type $var)] + (adjust-type* up =type)) + + (&/$Product ?left ?right) + (let [=type (&/fold (fn [_abody ena] + (|let [[_aenv _aidx (&/$Var _avar)] ena] + (clean! 0 _avar _aidx _abody))) + type + up) + distributor (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aidx _avar] ena] + (&/$UnivQ _aenv _abody))) + v + up))] + (return (&type/Tuple$ (&/|map distributor + (&type/flatten-prod =type))))) + + (&/$Sum ?left ?right) + (let [=type (&/fold (fn [_abody ena] + (|let [[_aenv _aidx (&/$Var _avar)] ena] + (clean! 0 _avar _aidx _abody))) + type + up) + distributor (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aidx _avar] ena] + (&/$UnivQ _aenv _abody))) + v + up))] + (return (&type/Variant$ (&/|map distributor + (&type/flatten-sum =type))))) + + (&/$Apply ?targ ?tfun) + (|do [=type (apply-type! ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$Var ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (&/fail-with-loc (str "##2##: " ?id))))] + (adjust-type* up type*)) + + (&/$Named ?name ?type) + (adjust-type* up ?type) + + _ + (&/fail-with-loc (str "[Pattern-matching Error] Cannot pattern-match against type: " (&type/show-type type))) + )) + +(defn adjust-type [type] + "(-> Type (Lux Type))" + (adjust-type* &/$Nil type)) + +(defn ^:private analyse-pattern [var?? value-type pattern kont] + (|let [[meta pattern*] pattern] + (|case pattern* + (&/$Identifier "" name) + (|case var?? + (&/$Some var-analysis) + (|do [=kont (&env/with-alias name var-analysis + kont)] + (return (&/T [$NoTestAC =kont]))) + + _ + (|do [=kont (&env/with-local name value-type + kont) + idx &env/next-local-idx] + (return (&/T [($StoreTestAC idx) =kont])))) + + (&/$Identifier ident) + (&/fail-with-loc (str "[Pattern-matching Error] Identifiers must be unqualified: " (&/ident->text ident))) + + (&/$Bit ?value) + (|do [_ (&type/check value-type &type/Bit) + =kont kont] + (return (&/T [($BitTestAC ?value) =kont]))) + + (&/$Nat ?value) + (|do [_ (&type/check value-type &type/Nat) + =kont kont] + (return (&/T [($NatTestAC ?value) =kont]))) + + (&/$Int ?value) + (|do [_ (&type/check value-type &type/Int) + =kont kont] + (return (&/T [($IntTestAC ?value) =kont]))) + + (&/$Rev ?value) + (|do [_ (&type/check value-type &type/Rev) + =kont kont] + (return (&/T [($RevTestAC ?value) =kont]))) + + (&/$Frac ?value) + (|do [_ (&type/check value-type &type/Frac) + =kont kont] + (return (&/T [($FracTestAC ?value) =kont]))) + + (&/$Text ?value) + (|do [_ (&type/check value-type &type/Text) + =kont kont] + (return (&/T [($TextTestAC ?value) =kont]))) + + (&/$Tuple ?members) + (|case ?members + (&/$Nil) + (|do [_ (&type/check value-type &type/Any) + =kont kont] + (return (&/T [($TupleTestAC (&/|list)) =kont]))) + + (&/$Cons ?member (&/$Nil)) + (analyse-pattern var?? value-type ?member kont) + + _ + (|do [must-infer? (&type/unknown? value-type) + value-type* (if must-infer? + (|do [member-types (&/map% (fn [_] &type/create-var+) (&/|range (&/|length ?members)))] + (return (&type/fold-prod member-types))) + (adjust-type value-type))] + (|case value-type* + (&/$Product _) + (|let [num-elems (&/|length ?members) + [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?members) value-type*)] + (if (= num-elems _shorter) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern &/$None v m kont*)] + (return (&/T [(&/$Cons =test =tests) =kont]))))) + (|do [=kont kont] + (return (&/T [&/$Nil =kont]))) + (&/|reverse (&/zip2 _tuple-types ?members)))] + (return (&/T [($TupleTestAC =tests) =kont]))) + (&/fail-with-loc (str "[Pattern-matching Error] Pattern-matching mismatch. Requires tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "].\n" + " At: " (&/show-ast pattern) "\n" + "Expected type: " (&type/show-type value-type*) "\n" + " Actual type: " (&type/show-type value-type))))) + + _ + (&/fail-with-loc (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type)))))) + + (&/$Record pairs) + (|do [[rec-members rec-type] (&&record/order-record pairs) + must-infer? (&type/unknown? value-type) + rec-type* (if must-infer? + (&type/instantiate-inference rec-type) + (return value-type)) + _ (&type/check value-type rec-type*)] + (analyse-pattern &/$None rec-type* (&/T [meta (&/$Tuple rec-members)]) kont)) + + (&/$Tag ?ident) + (|do [[=module =name] (&&/resolved-ident ?ident) + must-infer? (&type/unknown? value-type) + variant-type (if must-infer? + (|do [variant-type (&module/tag-type =module =name) + variant-type* (&type/instantiate-inference variant-type) + _ (&type/check value-type variant-type*)] + (return variant-type*)) + (return value-type)) + value-type* (adjust-type variant-type) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/sum-at idx value-type*) + [=test =kont] (analyse-pattern &/$None case-type unit-tuple kont)] + (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + + (&/$Form (&/$Cons [_ (&/$Nat idx)] (&/$Cons [_ (&/$Bit right?)] ?values))) + (let [idx (if right? (inc idx) idx)] + (|do [value-type* (adjust-type value-type) + case-type (&type/sum-at idx value-type*) + [=test =kont] (case (int (&/|length ?values)) + 0 (analyse-pattern &/$None case-type unit-tuple kont) + 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$Tuple ?values)]) kont))] + (return (&/T [($VariantTestAC (&/T [idx (&/|length (&type/flatten-sum value-type*)) =test])) =kont])))) + + (&/$Form (&/$Cons [_ (&/$Tag ?ident)] ?values)) + (|do [[=module =name] (&&/resolved-ident ?ident) + must-infer? (&type/unknown? value-type) + variant-type (if must-infer? + (|do [variant-type (&module/tag-type =module =name) + variant-type* (&type/instantiate-inference variant-type) + _ (&type/check value-type variant-type*)] + (return variant-type*)) + (return value-type)) + value-type* (adjust-type variant-type) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/sum-at idx value-type*) + [=test =kont] (case (int (&/|length ?values)) + 0 (analyse-pattern &/$None case-type unit-tuple kont) + 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$Tuple ?values)]) kont))] + (return (&/T [($VariantTestAC (&/T [idx (&/|length group) =test])) =kont]))) + + _ + (&/fail-with-loc (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) + ))) + +(defn ^:private analyse-branch [analyse exo-type var?? value-type pattern body patterns] + (|do [pattern+body (analyse-pattern var?? value-type pattern + (&&/analyse-1 analyse exo-type body))] + (return (&/$Cons pattern+body patterns)))) + +(defn ^:private merge-total [struct test+body] + (|let [[test ?body] test+body] + (|case [struct test] + [($DefaultTotal total?) ($NoTestAC)] + (return ($DefaultTotal true)) + + [($BitTotal total? ?values) ($NoTestAC)] + (return ($BitTotal true ?values)) + + [($NatTotal total? ?values) ($NoTestAC)] + (return ($NatTotal true ?values)) + + [($IntTotal total? ?values) ($NoTestAC)] + (return ($IntTotal true ?values)) + + [($RevTotal total? ?values) ($NoTestAC)] + (return ($RevTotal true ?values)) + + [($FracTotal total? ?values) ($NoTestAC)] + (return ($FracTotal 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)) + + [($BitTotal total? ?values) ($StoreTestAC ?idx)] + (return ($BitTotal true ?values)) + + [($NatTotal total? ?values) ($StoreTestAC ?idx)] + (return ($NatTotal true ?values)) + + [($IntTotal total? ?values) ($StoreTestAC ?idx)] + (return ($IntTotal true ?values)) + + [($RevTotal total? ?values) ($StoreTestAC ?idx)] + (return ($RevTotal true ?values)) + + [($FracTotal total? ?values) ($StoreTestAC ?idx)] + (return ($FracTotal true ?values)) + + [($TextTotal total? ?values) ($StoreTestAC ?idx)] + (return ($TextTotal true ?values)) + + [($TupleTotal total? ?values) ($StoreTestAC ?idx)] + (return ($TupleTotal true ?values)) + + [($VariantTotal total? ?values) ($StoreTestAC ?idx)] + (return ($VariantTotal true ?values)) + + [($DefaultTotal total?) ($BitTestAC ?value)] + (return ($BitTotal total? (&/|list ?value))) + + [($BitTotal total? ?values) ($BitTestAC ?value)] + (return ($BitTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($NatTestAC ?value)] + (return ($NatTotal total? (&/|list ?value))) + + [($NatTotal total? ?values) ($NatTestAC ?value)] + (return ($NatTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($IntTestAC ?value)] + (return ($IntTotal total? (&/|list ?value))) + + [($IntTotal total? ?values) ($IntTestAC ?value)] + (return ($IntTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($RevTestAC ?value)] + (return ($RevTotal total? (&/|list ?value))) + + [($RevTotal total? ?values) ($RevTestAC ?value)] + (return ($RevTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($FracTestAC ?value)] + (return ($FracTotal total? (&/|list ?value))) + + [($FracTotal total? ?values) ($FracTestAC ?value)] + (return ($FracTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($TextTestAC ?value)] + (return ($TextTotal total? (&/|list ?value))) + + [($TextTotal total? ?values) ($TextTestAC ?value)] + (return ($TextTotal total? (&/$Cons ?value ?values))) + + [($DefaultTotal total?) ($TupleTestAC ?tests)] + (|do [structs (&/map% (fn [t] + (merge-total ($DefaultTotal total?) (&/T [t ?body]))) + ?tests)] + (return ($TupleTotal total? structs))) + + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T [t ?body]))) + ?values ?tests)] + (return ($TupleTotal total? structs))) + (&/fail-with-loc (str "[Pattern-matching Error] Inconsistent tuple-size.\n" + "Expected: " (&/|length ?values) "\n" + " Actual: " (&/|length ?tests)))) + + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total ($DefaultTotal total?) + (&/T [?test ?body])) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?))) + (&/$Some list) + (return list) + + (&/$None) + (assert false))] + (return ($VariantTotal total? structs))) + + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) + (&/$Some sub) + sub + + (&/$None) + ($DefaultTotal total?)) + (&/T [?test ?body])) + structs (|case (&/|list-put ?tag sub-struct ?branches) + (&/$Some list) + (return list) + + (&/$None) + (assert false))] + (return ($VariantTotal total? structs))) + ))) + +(defn check-totality+ [check-totality] + (fn [?token] + (&type/with-var + (fn [$var] + (|do [=output (check-totality $var ?token) + ?type (&type/deref+ $var) + =type (&type/clean $var ?type)] + (return (&/T [=output =type]))))))) + +(defn ^:private check-totality [value-type struct] + (|case struct + ($DefaultTotal ?total) + (return ?total) + + ($BitTotal ?total ?values) + (|do [_ (&type/check value-type &type/Bit)] + (return (or ?total + (= #{true false} (set (&/->seq ?values)))))) + + ($NatTotal ?total _) + (|do [_ (&type/check value-type &type/Nat)] + (return ?total)) + + ($IntTotal ?total _) + (|do [_ (&type/check value-type &type/Int)] + (return ?total)) + + ($RevTotal ?total _) + (|do [_ (&type/check value-type &type/Rev)] + (return ?total)) + + ($FracTotal ?total _) + (|do [_ (&type/check value-type &type/Frac)] + (return ?total)) + + ($TextTotal ?total _) + (|do [_ (&type/check value-type &type/Text)] + (return ?total)) + + ($TupleTotal ?total ?structs) + (|case ?structs + (&/$Nil) + (|do [value-type* (resolve-type value-type)] + (if (&type/type= &type/Any value-type*) + (return true) + (&/fail-with-loc "[Pattern-maching Error] Unit is not total."))) + + _ + (|do [unknown? (&type/unknown? value-type)] + (if unknown? + (|do [=structs (&/map% (check-totality+ check-totality) ?structs) + _ (&type/check value-type (|case (->> (&/|map &/|second =structs) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$Product left right)) + last prevs)))] + (return (or ?total + (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$Product _) + (|let [num-elems (&/|length ?structs) + [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*) + _ (&/assert! (= num-elems _shorter) + (&/fail-with-loc (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]")))] + (|do [totals (&/map2% check-totality _tuple-types ?structs)] + (return (&/fold #(and %1 %2) true totals)))) + + _ + (&/fail-with-loc (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*))))))))) + + ($VariantTotal ?total ?structs) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$Sum _) + (|do [totals (&/map2% check-totality + (&type/flatten-sum value-type*) + ?structs)] + (return (&/fold #(and %1 %2) true totals))) + + _ + (&/fail-with-loc "[Pattern-maching Error] Variant is not total.")))) + )) + +;; [Exports] +(defn analyse-branches [analyse exo-type var?? value-type branches] + (|do [patterns (&/fold% (fn [patterns branch] + (|let [[pattern body] branch] + (analyse-branch analyse exo-type var?? value-type pattern body patterns))) + &/$Nil + branches) + struct (&/fold% merge-total ($DefaultTotal false) patterns) + ? (check-totality value-type struct) + _ (&/assert! ? "[Pattern-maching Error] Pattern-matching is not total.")] + (return patterns))) diff --git a/lux-bootstrapper/src/lux/analyser/env.clj b/lux-bootstrapper/src/lux/analyser/env.clj new file mode 100644 index 000000000..a2b6e5ad3 --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/env.clj @@ -0,0 +1,78 @@ +(ns lux.analyser.env + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return return* |case |let]]) + [lux.analyser.base :as &&])) + +;; [Exports] +(def next-local-idx + (fn [state] + (return* state (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) + +(defn with-local [name type body] + (fn [state] + (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$scopes + (fn [stack] + (let [var-analysis (&&/|meta type &/empty-location (&&/$var (&/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&/T [type var-analysis]) m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] + (|case =return + (&/$Right ?state ?value) + (return* (&/update$ &/$scopes (fn [stack*] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) + ?value) + + _ + =return)))) + +(defn with-alias [name var-analysis body] + (fn [state] + (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$scopes + (fn [stack] + (&/$Cons (&/update$ &/$locals #(->> % + (&/update$ &/$mappings (fn [m] (&/|put name + (&/T [(&&/expr-type* var-analysis) + var-analysis]) + m)))) + (&/|head stack)) + (&/|tail stack))) + state))] + (|case =return + (&/$Right ?state ?value) + (return* (&/update$ &/$scopes (fn [stack*] + (&/$Cons (&/update$ &/$locals #(->> % + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) + ?value) + + _ + =return)))) + +(def captured-vars + (fn [state] + (|case (&/get$ &/$scopes state) + (&/$Nil) + ((&/fail-with-loc "[Analyser Error] Cannot obtain captured vars without environments.") + state) + + (&/$Cons env _) + (return* state (->> env + (&/get$ &/$captured) + (&/get$ &/$mappings) + (&/|map (fn [mapping] + (|let [[k v] mapping] + (&/T [k (&/|second v)]))))))) + )) diff --git a/lux-bootstrapper/src/lux/analyser/function.clj b/lux-bootstrapper/src/lux/analyser/function.clj new file mode 100644 index 000000000..3db24acef --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/function.clj @@ -0,0 +1,28 @@ +(ns lux.analyser.function + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return |case]] + [host :as &host]) + (lux.analyser [base :as &&] + [env :as &env]))) + +;; [Resource] +(defn with-function [self self-type arg arg-type body] + (&/with-closure + (|do [scope-name &/get-scope-name] + (&env/with-local self self-type + (&env/with-local arg arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T [scope-name =captured =return])))))))) + +(defn close-over [scope name register frame] + (|let [[[register-type register-location] _] register + register* (&&/|meta register-type register-location + (&&/$captured (&/T [scope + (->> frame (&/get$ &/$captured) (&/get$ &/$counter)) + register])))] + (&/T [register* (&/update$ &/$captured #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name (&/T [register-type register*]) mps)))) + frame)]))) diff --git a/lux-bootstrapper/src/lux/analyser/lux.clj b/lux-bootstrapper/src/lux/analyser/lux.clj new file mode 100644 index 000000000..b7d78aa23 --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/lux.clj @@ -0,0 +1,726 @@ +(ns lux.analyser.lux + (:require (clojure [template :refer [do-template]] + [set :as set]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return return* |let |list |case]] + [parser :as &parser] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &&] + [function :as &&function] + [case :as &&case] + [env :as &&env] + [module :as &&module] + [record :as &&record]))) + +;; [Utils] +;; TODO: Walk the type to set up the parameter-type, instead of doing a +;; rough calculation like this one. +(defn ^:private count-univq + "(-> Type Int)" + [type] + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +;; TODO: This technique will not work if the body of the type contains +;; nested quantifications that cannot be directly counted. +(defn ^:private next-parameter-type + "(-> Type Type)" + [type] + (&/$Parameter (->> (count-univq type) (* 2) (+ 1)))) + +(defn ^:private embed-inferred-input + "(-> Type Type Type)" + [input output] + (|case output + (&/$UnivQ env output*) + (&/$UnivQ env (embed-inferred-input input output*)) + + _ + (&/$Function input output))) + +;; [Exports] +(defn analyse-unit [analyse ?exo-type] + (|do [_location &/location + _ (&type/check ?exo-type &type/Any)] + (return (&/|list (&&/|meta ?exo-type _location + (&&/$tuple (&/|list))))))) + +(defn analyse-tuple [analyse ?exo-type ?elems] + (|case ?elems + (&/$Nil) + (analyse-unit analyse (|case ?exo-type + (&/$Left exo-type) exo-type + (&/$Right exo-type) exo-type)) + + (&/$Cons ?elem (&/$Nil)) + (analyse (|case ?exo-type + (&/$Left exo-type) exo-type + (&/$Right exo-type) exo-type) + ?elem) + + _ + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left exo-type**) ?elems)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$Var iid) + (|do [:let [=var* (next-parameter-type tuple-type)] + _ (&type/set-var iid =var*) + tuple-type* (&type/clean $var tuple-type)] + (return (&/$UnivQ &/$Nil tuple-type*))) + + _ + (&type/clean $var tuple-type))] + (return (&/|list (&&/|meta inferred-type tuple-location + tuple-analysis)))))) + + _ + (analyse-tuple analyse (&/$Right exo-type*) ?elems))) + + (&/$Right exo-type) + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (|case (->> (&/|map &&/expr-type* =elems) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$Product left right)) + last prevs))) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$tuple =elems) + )))) + (|do [exo-type* (&type/actual-type exo-type)] + (&/with-attempt + (|case exo-type* + (&/$Product _) + (|let [num-elems (&/|length ?elems) + [_shorter _tuple-types] (&type/tuple-types-for num-elems exo-type*)] + (if (= num-elems _shorter) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + _tuple-types + ?elems) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$tuple =elems) + )))) + (|do [=direct-elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) + (&/|take (dec _shorter) _tuple-types) + (&/|take (dec _shorter) ?elems)) + =indirect-elems (analyse-tuple analyse + (&/$Right (&/|last _tuple-types)) + (&/|drop (dec _shorter) ?elems)) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$tuple (&/|++ =direct-elems =indirect-elems)) + )))))) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)) + =tuple-analysis (&&/clean-analysis $var (&&/|meta exo-type tuple-location + tuple-analysis))] + (return (&/|list =tuple-analysis))))) + + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$Ex $var-id) $var] + exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-location] tuple-analysis] (&/with-scope-type-var $var-id + (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)))] + (return (&/|list (&&/|meta exo-type tuple-location + tuple-analysis)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))) + ) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type))))))))) + )) + +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [_location &/location + output (|case ?values + (&/$Nil) + (analyse-unit analyse exo-type) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse (&/$Right exo-type) ?values))] + (|case output + (&/$Cons x (&/$Nil)) + (return x) + + _ + (&/fail-with-loc "[Analyser Error] Macro cannot expand to more than 1 output.")))) + +(defn analyse-variant [analyse ?exo-type idx is-last? ?values] + (|case ?exo-type + (&/$Left exo-type) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[variant-type variant-location] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) idx is-last? ?values)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$Var iid) + (|do [:let [=var* (next-parameter-type variant-type)] + _ (&type/set-var iid =var*) + variant-type* (&type/clean $var variant-type)] + (return (&/$UnivQ &/$Nil variant-type*))) + + _ + (&type/clean $var variant-type))] + (return (&/|list (&&/|meta inferred-type variant-location + variant-analysis)))))) + + _ + (analyse-variant analyse (&/$Right exo-type*) idx is-last? ?values))) + + (&/$Right exo-type) + (|do [exo-type* (|case exo-type + (&/$Var ?id) + (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + (|do [_ (&type/set-var ?id &type/Type)] + (&type/actual-type &type/Type)))) + + _ + (&type/actual-type exo-type))] + (&/with-attempt + (|case exo-type* + (&/$Sum _) + (|do [vtype (&type/sum-at idx exo-type*) + =value (analyse-variant-body analyse vtype ?values) + _location &/location] + (if (= 1 (&/|length (&type/flatten-sum exo-type*))) + (return (&/|list =value)) + (return (&/|list (&&/|meta exo-type _location (&&/$variant idx is-last? =value)))) + )) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + =exprs (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)] + (&/map% (partial &&/clean-analysis $var) =exprs)))) + + _ + (&/fail-with-loc (str "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type exo-type*) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) + (fn [err] + (|case exo-type + (&/$Var ?id) + (|do [=exo-type (&type/deref ?id)] + (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type =exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) + + _ + (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type exo-type) " " idx " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + ))) + +(defn analyse-record [analyse exo-type ?elems] + (|do [[rec-members rec-type] (&&record/order-record ?elems)] + (|case exo-type + (&/$Var id) + (|do [? (&type/bound? id)] + (if ? + (analyse-tuple analyse (&/$Right exo-type) rec-members) + (|do [[[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members)) + _ (&type/check exo-type tuple-type)] + (return (&/|list (&&/|meta exo-type tuple-location + tuple-analysis)))))) + + _ + (analyse-tuple analyse (&/$Right exo-type) rec-members) + ))) + +(defn ^:private analyse-global [analyse exo-type module name] + (|do [[[r-module r-name] [exported? endo-type ?meta ?value]] (&&module/find-def module name) + ;; This is a small shortcut to optimize analysis of typing code. + _ (if (and (&type/type= &type/Type endo-type) + (&type/type= &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type)) + _location &/location] + (return (&/|list (&&/|meta endo-type _location + (&&/$def (&/T [r-module r-name]))))))) + +(defn ^:private analyse-local [analyse exo-type name] + (fn [state] + (|let [stack (&/get$ &/$scopes state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$captured) (&/get$ &/$mappings) (&/|contains? name) not)) + [inner outer] (&/|split-with no-binding? stack)] + (|case outer + (&/$Nil) + (&/run-state (|do [module-name &/get-module-name] + (analyse-global analyse exo-type module-name name)) + state) + + (&/$Cons bottom-outer _) + (|let [scopes (&/|map #(&/get$ &/$name %) (&/|reverse inner)) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&function/close-over in-scope name register frame)] + (&/T [register* (&/$Cons frame* new-inner)]))) + (&/T [(&/|second (or (->> bottom-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> bottom-outer (&/get$ &/$captured) (&/get$ &/$mappings) (&/|get name)))) + &/$Nil]) + (&/|reverse inner) scopes)] + ((|do [_ (&type/check exo-type (&&/expr-type* =local))] + (return (&/|list =local))) + (&/set$ &/$scopes (&/|++ inner* outer) state))) + )))) + +(defn analyse-identifier [analyse exo-type ident] + (|do [:let [[?module ?name] ident]] + (if (= "" ?module) + (analyse-local analyse exo-type ?name) + (analyse-global analyse exo-type ?module ?name)) + )) + +(defn ^:private analyse-apply* [analyse exo-type fun-type ?args] + (|case ?args + (&/$Nil) + (|do [_ (&type/check exo-type fun-type)] + (return (&/T [fun-type &/$Nil]))) + + (&/$Cons ?arg ?args*) + (|do [?fun-type* (&type/actual-type fun-type)] + (&/with-attempt + (|case ?fun-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + [=output-t =args] (analyse-apply* analyse exo-type type* ?args) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (|case $var + (&/$Var ?id) + (|do [? (&type/bound? ?id) + type** (if ? + (&type/clean $var =output-t) + (|do [_ (&type/set-var ?id (next-parameter-type =output-t)) + cleaned-output* (&type/clean $var =output-t) + :let [cleaned-output (&/$UnivQ &/$Nil cleaned-output*)]] + (return cleaned-output))) + _ (&type/clean $var exo-type)] + (return (&/T [type** ==args]))) + )))) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [type* (&type/apply-type ?fun-type* $var) + [=output-t =args] (analyse-apply* analyse exo-type type* ?args) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (|case $var + (&/$Var ?id) + (|do [? (&type/bound? ?id) + type** (if ? + (&type/clean $var =output-t) + (|do [idT &type/existential + _ (&type/set-var ?id idT)] + (&type/clean $var =output-t))) + _ (&type/clean $var exo-type)] + (return (&/T [type** ==args]))) + )))) + + (&/$Function ?input-t ?output-t) + (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) + =arg (&/with-attempt + (&&/analyse-1 analyse ?input-t ?arg) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Argument expected: " (&type/show-type ?input-t)))))] + (return (&/T [=output-t (&/$Cons =arg =args)]))) + + _ + (&/fail-with-loc (str "[Analyser Error] Cannot apply a non-function: " (&type/show-type ?fun-type*)))) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot apply function " (&type/show-type fun-type) " to args: " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + )) + +(defn ^:private do-analyse-apply [analyse exo-type =fn ?args] + (|do [:let [[[=fn-type =fn-location] =fn-form] =fn] + [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&&/|meta =output-t =fn-location + (&&/$apply =fn =args) + ))))) + +(defn analyse-apply [analyse location exo-type macro-caller =fn ?args] + (|case =fn + [_ (&&/$def ?module ?name)] + (|do [[real-name [exported? ?type ?meta ?value]] (&&module/find-def! ?module ?name)] + (if (&type/type= &type/Macro ?type) + (|do [macro-expansion (fn [state] + (|case (macro-caller ?value ?args state) + (&/$Right state* output) + (&/$Right (&/T [state* output])) + + (&/$Left error) + ((&/fail-with-loc error) state))) + module-name &/get-module-name + ;; :let [[r-prefix r-name] real-name + ;; _ (when (= "module:" r-name) + ;; (->> macro-expansion + ;; (&/|map (fn [ast] (str (&/show-ast ast) "\n"))) + ;; (&/fold str "") + ;; (&/|log! (str 'macro-expansion " " (&/ident->text real-name) " @ " module-name))))] + ] + (&/flat-map% (partial analyse exo-type) macro-expansion)) + (do-analyse-apply analyse exo-type =fn ?args))) + + _ + (do-analyse-apply analyse exo-type =fn ?args)) + ) + +(defn analyse-case [analyse exo-type ?value ?branches] + (|do [_ (&/assert! (> (&/|length ?branches) 0) "[Analyser Error] Cannot have empty branches in \"case\" expression.") + =value (&&/analyse-1+ analyse ?value) + :let [var?? (|case =value + [_ (&&/$var =var-kind)] + (&/$Some =value) + + _ + &/$None)] + =match (&&case/analyse-branches analyse exo-type var?? (&&/expr-type* =value) ?branches) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$case =value =match) + ))))) + +(defn ^:private unravel-inf-appt [type] + (|case type + (&/$Apply (&/$Var _inf-var) =input+) + (&/$Cons _inf-var (unravel-inf-appt =input+)) + + _ + (&/|list))) + +(defn ^:private clean-func-inference [$input $output =input =func] + (|case =input + (&/$Var iid) + (|do [:let [=input* (next-parameter-type =func)] + _ (&type/set-var iid =input*) + =func* (&type/clean $input =func) + =func** (&type/clean $output =func*)] + (return (&/$UnivQ &/$Nil =func**))) + + (&/$Apply (&/$Var _inf-var) =input+) + (&/fold% (fn [_func _inf-var] + (|do [:let [$inf-var (&/$Var _inf-var)] + =inf-var (&type/resolve-type $inf-var) + _func* (clean-func-inference $inf-var $output =inf-var _func)] + (return _func*))) + =func + (unravel-inf-appt =input)) + + (&/$Product _ _) + (&/fold% (fn [_func _inf-var] + (|do [:let [$inf-var (&/$Var _inf-var)] + =inf-var (&type/resolve-type $inf-var) + _func* (clean-func-inference $inf-var $output =inf-var _func)] + (return _func*))) + =func + (&/|reverse (&type/flatten-prod =input))) + + _ + (|do [=func* (&type/clean $input =func) + =func** (&type/clean $output =func*)] + (return =func**)))) + +(defn analyse-function* [analyse exo-type ?self ?arg ?body] + (|case exo-type + (&/$Var id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/deref id)] + (analyse-function* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (&type/with-var + (fn [$input] + (&type/with-var + (fn [$output] + (|do [[[function-type function-location] function-analysis] (analyse-function* analyse (&/$Function $input $output) ?self ?arg ?body) + =input (&type/resolve-type $input) + =output (&type/resolve-type $output) + inferred-type (clean-func-inference $input $output =input (embed-inferred-input =input =output)) + _ (&type/check exo-type inferred-type)] + (return (&&/|meta inferred-type function-location + function-analysis))) + )))))) + + _ + (&/with-attempt + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$Ex $var-id) $var] + exo-type** (&type/apply-type exo-type* $var)] + (&/with-scope-type-var $var-id + (analyse-function* analyse exo-type** ?self ?arg ?body))) + + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + =expr (analyse-function* analyse exo-type** ?self ?arg ?body)] + (&&/clean-analysis $var =expr)))) + + (&/$Function ?arg-t ?return-t) + (|do [[=scope =captured =body] (&&function/with-function ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body)) + _location &/location + register-offset &&env/next-local-idx] + (return (&&/|meta exo-type* _location + (&&/$function register-offset =scope =captured =body)))) + + _ + (&/fail ""))) + (fn [err] + (&/fail-with-loc (str err "\n" "[Analyser Error] Functions require function types: " (&type/show-type exo-type))))) + )) + +(defn analyse-function** [analyse exo-type ?self ?arg ?body] + (|case exo-type + (&/$UnivQ _) + (|do [$var &type/existential + :let [(&/$Ex $var-id) $var] + exo-type* (&type/apply-type exo-type $var) + [_ _expr] (&/with-scope-type-var $var-id + (analyse-function** analyse exo-type* ?self ?arg ?body)) + _location &/location] + (return (&&/|meta exo-type _location _expr))) + + (&/$Var id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-function* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (analyse-function* analyse exo-type ?self ?arg ?body))) + + _ + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-function* analyse exo-type* ?self ?arg ?body)) + )) + +(defn analyse-function [analyse exo-type ?self ?arg ?body] + (|do [output (analyse-function** analyse exo-type ?self ?arg ?body)] + (return (&/|list output)))) + +(defn ^:private ensure-undefined! [module-name local-name] + (|do [verdict (&&module/defined? module-name local-name)] + (if verdict + (|do [[[real-module real-name] _] (&&module/find-def module-name local-name) + :let [wanted-name (str module-name &/+name-separator+ local-name) + source-name (str real-module &/+name-separator+ real-name)]] + (&/assert! false (str "[Analyser Error] Cannot re-define " wanted-name + (if (= wanted-name source-name) + "" + (str "\nThis is an alias for " source-name))))) + (return &/$Nil)))) + +(defn analyse-def* [analyse optimize eval! compile-def ?name ?value ?meta exported? & [?expected-type]] + (|do [_ &/ensure-directive + module-name &/get-module-name + _ (ensure-undefined! module-name ?name) + =value (&/without-repl-closure + (&/with-scope ?name + (if ?expected-type + (&/with-expected-type ?expected-type + (&&/analyse-1 analyse ?expected-type ?value)) + (&&/analyse-1+ analyse ?value)))) + =meta (&&/analyse-1 analyse &type/Code ?meta) + ==meta (eval! (optimize =meta)) + def-value (compile-def ?name (optimize =value) ==meta exported?) + _ &type/reset-mappings] + (return (&/T [module-name (&&/expr-type* =value) def-value])))) + +(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta exported?] + (|do [_ (analyse-def* analyse optimize eval! compile-def ?name ?value ?meta exported?)] + (return &/$Nil))) + +(defn analyse-def-type-tagged [analyse optimize eval! compile-def ?name ?value ?meta tags* exported?] + (|do [[module-name def-type def-value] (analyse-def* analyse optimize eval! compile-def ?name ?value ?meta exported? &type/Type) + _ (&/assert! (&type/type= &type/Type def-type) + "[Analyser Error] Cannot define tags for non-type.") + tags (&/map% (fn [tag*] + (|case tag* + [_ (&/$Text tag)] + (return tag) + + _ + (&/fail-with-loc "[Analyser Error] Incorrect format for tags."))) + tags*) + _ (&&module/declare-tags module-name tags exported? def-value)] + (return &/$Nil))) + +(defn analyse-def-alias [?alias ?original] + (|let [[r-module r-name] ?original] + (|do [module-name &/get-module-name + _ (ensure-undefined! module-name ?alias) + _ (&&module/find-def r-module r-name) + _ (&/without-repl-closure + (&&module/define-alias module-name ?alias ?original))] + (return &/$Nil)))) + +(defn ^:private merge-module-states + "(-> Host Host Host)" + [new old] + (|let [merged-module-states (&/fold (fn [total new-module] + (|let [[_name _module] new-module] + (|case (&/get$ &&module/$module-state _module) + (&&module/$Cached) + (&/|put _name _module total) + + (&&module/$Compiled) + (&/|put _name _module total) + + _ + total))) + (&/get$ &/$modules old) + (&/get$ &/$modules new))] + (&/set$ &/$modules merged-module-states old))) + +(defn ^:private merge-modules + "(-> Text Module Module Module)" + [current-module new old] + (&/fold (fn [total* entry] + (|let [[_name _module] entry] + (if (or (= current-module _name) + (->> _module + (&/get$ &&module/$defs) + &/|length + (= 0))) + ;; Do not modify the entry of the current module, to + ;; avoid overwritting it's data in improper ways. + ;; Since it's assumed the "original" old module + ;; contains all the proper own-module information. + total* + (&/|put _name _module total*)))) + old new)) + +(defn ^:private merge-compilers + "(-> Text Lux Lux Lux)" + [current-module new old] + (->> old + (&/set$ &/$modules (merge-modules current-module + (&/get$ &/$modules new) + (&/get$ &/$modules old))) + (&/set$ &/$seed (max (&/get$ &/$seed new) + (&/get$ &/$seed old))) + (merge-module-states new))) + +(def ^:private get-compiler + (fn [compiler] + (return* compiler compiler))) + +(defn ^:private set-compiler [compiler*] + (fn [_] + (return* compiler* compiler*))) + +(defn try-async-compilation [path compile-module] + (|do [already-compiled? (&&module/exists? path)] + (if (not already-compiled?) + (compile-module path) + (|do [_compiler get-compiler] + (return (doto (promise) + (deliver (&/$Right _compiler)))))))) + +(defn analyse-module [analyse optimize eval! compile-module ?meta ?imports] + (|do [_ &/ensure-directive + =anns (&&/analyse-1 analyse &type/Code ?meta) + ==anns (eval! (optimize =anns)) + module-name &/get-module-name + _ (&&module/set-anns ==anns module-name) + _imports (&&module/fetch-imports ?imports) + current-module &/get-module-name + =asyncs (&/map% (fn [_import] + (|let [[path alias] _import] + (&/without-repl + (&/save-module + (|do [_ (&/assert! (not (= current-module path)) + (&/fail-with-loc (str "[Analyser Error] Module cannot import itself: " path))) + active? (&&module/active-module? path) + ;; TODO: Enrich this error-message + ;; to explicitly show the cyclic dependency. + _ (&/assert! (not active?) + (str "[Analyser Error] Cannot import a module that is mid-compilation { cyclic dependency }: " path " @ " current-module)) + _ (&&module/add-import path) + _ (if (= "" alias) + (return nil) + (&&module/alias current-module alias path))] + (try-async-compilation path compile-module)))))) + _imports) + _compiler get-compiler + _ (&/fold% (fn [compiler _async] + (|case @_async + (&/$Right _new-compiler) + (set-compiler (merge-compilers current-module _new-compiler compiler)) + + (&/$Left ?error) + (&/fail ?error))) + _compiler + =asyncs)] + (return &/$Nil))) + +(defn ^:private coerce + "(-> Type Analysis Analysis)" + [new-type analysis] + (|let [[[_type _location] _analysis] analysis] + (&&/|meta new-type _location + _analysis))) + +(defn analyse-ann [analyse eval! exo-type ?type ?value] + (|do [=type (&&/analyse-1 analyse &type/Type ?type) + ==type (eval! =type) + _ (&type/check exo-type ==type) + =value (&&/analyse-1 analyse ==type ?value) + _location &/location] + (return (&/|list (&&/|meta ==type _location + (&&/$ann =value =type) + ))))) + +(defn analyse-coerce [analyse eval! exo-type ?type ?value] + (|do [=type (&&/analyse-1 analyse &type/Type ?type) + ==type (eval! =type) + _ (&type/check exo-type ==type) + =value (&&/analyse-1+ analyse ?value)] + (return (&/|list (coerce ==type =value))))) + +(let [program-type (&/$Function (&/$Apply &type/Text &type/List) + (&/$Apply &type/Any &type/IO))] + (defn analyse-program [analyse optimize compile-program ?program] + (|do [_ &/ensure-directive + =program (&&/analyse-1 analyse program-type ?program) + _ (compile-program (optimize =program))] + (return &/$Nil)))) diff --git a/lux-bootstrapper/src/lux/analyser/module.clj b/lux-bootstrapper/src/lux/analyser/module.clj new file mode 100644 index 000000000..d41eb73d5 --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/module.clj @@ -0,0 +1,431 @@ +(ns lux.analyser.module + (:refer-clojure :exclude [alias]) + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [defvariant deftuple |let |do return return* |case]] + [type :as &type] + [host :as &host]) + [lux.host.generics :as &host-generics])) + +;; [Utils] +;; ModuleState +(defvariant + ("Active" 0) + ("Compiled" 0) + ("Cached" 0)) + +;; Module +(deftuple + ["module-hash" + "module-aliases" + "defs" + "imports" + "tags" + "types" + "module-annotations" + "module-state"]) + +(defn ^:private new-module [hash] + (&/T [;; lux;module-hash + hash + ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + &/$Nil + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + ;; module-annotations + &/$None + ;; "module-state" + $Active] + )) + +(do-template [<flagger> <asker> <tag>] + (do (defn <flagger> + "(-> Text (Lux Any))" + [module-name] + (fn [state] + (let [state* (&/update$ &/$modules + (fn [modules] + (&/|update module-name + (fn [=module] + (&/set$ $module-state <tag> =module)) + modules)) + state)] + (&/$Right (&/T [state* &/unit-tag]))))) + (defn <asker> + "(-> Text (Lux Bit))" + [module-name] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module-name))] + (&/$Right (&/T [state (|case (&/get$ $module-state =module) + (<tag>) true + _ false)])) + (&/$Right (&/T [state false]))) + ))) + + flag-active-module active-module? $Active + flag-compiled-module compiled-module? $Compiled + flag-cached-module cached-module? $Cached + ) + +;; [Exports] +(defn add-import + "(-> Text (Lux Null))" + [module] + (|do [current-module &/get-module-name] + (fn [state] + (if (&/|member? module (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $imports))) + ((&/fail-with-loc (str "[Analyser Error] Cannot import module " (pr-str module) " twice @ " current-module)) + state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $imports (partial &/$Cons module) m)) + ms)) + state) + nil))))) + +(defn set-imports + "(-> (List Text) (Lux Null))" + [imports] + (|do [current-module &/get-module-name] + (fn [state] + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) + nil)))) + +(defn define-alias [module name de-aliased] + (fn [state] + (|case (&/get$ &/$scopes state) + (&/$Cons ?env (&/$Nil)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/$Left de-aliased) %) + m)) + ms)))) + nil) + + _ + ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) + state)))) + +(defn define [module name exported? def-type def-meta def-value] + (fn [state] + (|case (&/get$ &/$scopes state) + (&/$Cons ?env (&/$Nil)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/$Right (&/T [exported? def-type def-meta def-value])) %) + m)) + ms)))) + nil) + + _ + ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) + state)))) + +(defn type-def + "(-> Text Text (Lux [Bit Type]))" + [module name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + (&/$Left [o-module o-name]) + ((type-def o-module o-name) state) + + (&/$Right [exported? ?type ?meta ?value]) + (if (&type/type= &type/Type ?type) + (return* state (&/T [exported? ?value])) + ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])) + "\nMETA: " (&/show-ast ?meta))) + state))) + ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name])))) + state)) + ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) + state)))) + +(defn exists? + "(-> Text (Lux Bit))" + [name] + (fn [state] + (return* state + (->> state (&/get$ &/$modules) (&/|contains? name))))) + +(defn dealias [name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] + (return* state real-name) + ((&/fail-with-loc (str "[Analyser Error] Unknown alias: " name)) + state))))) + +(defn alias [module alias reference] + (fn [state] + (let [_module_ (->> state (&/get$ &/$modules) (&/|get module))] + (if (&/|member? module (->> _module_ (&/get$ $imports))) + ((&/fail-with-loc (str "[Analyser Error] Cannot create alias that is the same as a module nameL " (pr-str alias) " for " reference)) + state) + (if-let [real-name (->> _module_ (&/get$ $module-aliases) (&/|get alias))] + ((&/fail-with-loc (str "[Analyser Error] Cannot re-use alias \"" alias "\" @ " module)) + state) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) + nil)))) + )) + +(defn ^:private imports? [state imported-module-name source-module-name] + (->> state + (&/get$ &/$modules) + (&/|get source-module-name) + (&/get$ $imports) + (&/|any? (partial = imported-module-name)))) + +(defn get-anns [module-name] + (fn [state] + (if-let [module (->> state + (&/get$ &/$modules) + (&/|get module-name))] + (return* state (&/get$ $module-annotations module)) + ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module-name)) + state)))) + +(defn set-anns [anns module-name] + (fn [state] + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module-name + #(&/set$ $module-annotations (&/$Some anns) %) + ms)))) + nil))) + +(defn find-def! [module name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + (&/$Left [?r-module ?r-name]) + ((find-def! ?r-module ?r-name) + state) + + (&/$Right $def*) + (return* state (&/T [(&/T [module name]) $def*]))) + ((&/fail-with-loc (str "[Analyser Error @ find-def!] Definition does not exist: " (str module &/+name-separator+ name) + " at module: " current-module)) + state)) + ((&/fail-with-loc (str "[Analyser Error @ find-def!] Module does not exist: " module + " at module: " current-module)) + state))))) + +(defn find-def [module name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + (&/$Left [?r-module ?r-name]) + (if (.equals ^Object current-module module) + ((find-def! ?r-module ?r-name) + state) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use (private) alias: " (str module &/+name-separator+ name) + " at module: " current-module)) + state)) + + (&/$Right [exported? ?type ?meta ?value]) + (if (or (.equals ^Object current-module module) + (and exported? + (or (.equals ^Object module &/prelude) + (imports? state module current-module)))) + (return* state (&/T [(&/T [module name]) + (&/T [exported? ?type ?meta ?value])])) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use private definition: " (str module &/+name-separator+ name) + " at module: " current-module)) + state))) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name) + " at module: " current-module)) + state)) + ((&/fail-with-loc (str "[Analyser Error @ find-def] Module does not exist: " module + " at module: " current-module)) + state))))) + +(defn defined? [module name] + (&/try-all% (&/|list (|do [_ (find-def! module name)] + (return true)) + (return false)))) + +(defn create-module + "(-> Text Hash-Code (Lux Null))" + [name hash] + (fn [state] + (return* (->> state + (&/update$ &/$modules #(&/|put name (new-module hash) %)) + (&/set$ &/$scopes (&/|list (&/env name &/$Nil))) + (&/set$ &/$current-module (&/$Some name))) + nil))) + +(do-template [<name> <tag> <type>] + (defn <name> + <type> + [module] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ <tag> =module)) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state)) + )) + + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + module-hash $module-hash "(-> Text (Lux Int))" + ) + +(def imports + (|do [module &/get-module-name + _imports (fn [state] + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports))))] + (&/map% (fn [_module] + (|do [_hash (module-hash _module)] + (return (&/T [_module _hash])))) + _imports))) + +(defn ensure-undeclared-tags [module tags] + (|do [tags-table (tags-by-module module) + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (&/fail-with-loc (str "[Analyser Error] Cannot re-declare tag: " (&/ident->text (&/T [module tag])))) + (return nil))) + tags)] + (return nil))) + +(defn ensure-undeclared-type [module name] + (|do [types-table (types-by-module module) + _ (&/assert! (nil? (&/|get name types-table)) + (str "[Analyser Error] Cannot re-declare type: " (&/ident->text (&/T [module name]))))] + (return nil))) + +(defn declare-tags + "(-> Text (List Text) Bit Type (Lux Null))" + [module tag-names was-exported? type] + (|do [_ (ensure-undeclared-tags module tag-names) + type-name (&type/type-name type) + :let [[_module _name] type-name] + _ (&/assert! (= module _module) + (str "[Module Error] Cannot define tags for a type belonging to a foreign module: " (&/ident->text type-name))) + _ (ensure-undeclared-type _module _name)] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T [module tag-name])) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T [idx tags was-exported? type]) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T [tags was-exported? type])))) + =modules)) + state) + nil)) + ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) + state))))) + +(defn ensure-can-see-tag + "(-> Text Text (Lux Any))" + [module tag-name] + (|do [current-module &/get-module-name] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] + (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] + (if (or ?exported + (= module current-module)) + (return* state &/unit-tag) + ((&/fail-with-loc (str "[Analyser Error] Cannot access tag #" (&/ident->text (&/T [module tag-name])) " from module " current-module)) + state))) + ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) + state)) + ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) + state))))) + +(do-template [<name> <part> <doc>] + (defn <name> + <doc> + [module tag-name] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))] + (|let [[?idx ?tags ?exported ?type] idx+tags+exported+type] + (return* state <part>)) + ((&/fail-with-loc (str "[Module Error] Unknown tag: " (&/ident->text (&/T [module tag-name])))) + state)) + ((&/fail-with-loc (str "[Module Error] Unknown module: " module)) + state)))) + + tag-index ?idx "(-> Text Text (Lux Int))" + tag-group ?tags "(-> Text Text (Lux (List Ident)))" + tag-type ?type "(-> Text Text (Lux Type))" + ) + +(def defs + (|do [module &/get-module-name] + (fn [state] + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs)))))) + +(defn fetch-imports [imports] + (|case imports + [_ (&/$Tuple _parts)] + (&/map% (fn [_part] + (|case _part + [_ (&/$Tuple (&/$Cons [[_ (&/$Text _module)] + (&/$Cons [[_ (&/$Text _alias)] + (&/$Nil)])]))] + (return (&/T [_module _alias])) + + _ + (&/fail-with-loc "[Analyser Error] Incorrect import syntax."))) + _parts) + + _ + (&/fail-with-loc "[Analyser Error] Incorrect import syntax."))) + +(def ^{:doc "(Lux (List [Text (List Text)]))"} + tag-groups + (|do [module &/get-current-module] + (return (&/|map (fn [pair] + (|case pair + [name [tags exported? _]] + (&/T [name (&/|map (fn [tag] + (|let [[t-prefix t-name] tag] + t-name)) + tags)]))) + (&/get$ $types module))))) diff --git a/lux-bootstrapper/src/lux/analyser/parser.clj b/lux-bootstrapper/src/lux/analyser/parser.clj new file mode 100644 index 000000000..6a46bab3c --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/parser.clj @@ -0,0 +1,478 @@ +(ns lux.analyser.parser + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser]))) + +(declare parse-gclass) + +;; [Parsers] +(def ^:private _space_ (&reader/read-text " ")) + +(defn ^:private with-pre-space [action] + (|do [_ _space_] + action)) + +(defn ^:private repeat% [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (&/$Right (&/T [state &/$Nil])) + + (&/$Right state* head) + ((|do [tail (repeat% action)] + (return (&/$Cons head tail))) + state*)))) + +(defn ^:private spaced [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (&/$Right (&/T [state &/$Nil])) + + (&/$Right state* head) + ((&/try-all% (&/|list (|do [_ _space_ + tail (spaced action)] + (return (&/$Cons head tail))) + (return (&/|list head)))) + state*)))) + +(def ^:private parse-name + (|do [[_ _ =name] (&reader/read-regex #"^([a-zA-Z0-9_\.]+)")] + (return =name))) + +(def ^:private parse-name? + (|do [[_ _ =name] (&reader/read-regex? #"^([a-zA-Z0-9_\.]+)")] + (return =name))) + +(def ^:private parse-ident + (|do [[_ _ =name] (&reader/read-regex &lexer/+ident-re+)] + (return =name))) + +(defn ^:private with-parens [body] + (|do [_ (&reader/read-text "(") + output body + _ (&reader/read-text ")")] + (return output))) + +(defn ^:private with-brackets [body] + (|do [_ (&reader/read-text "[") + output body + _ (&reader/read-text "]")] + (return output))) + +(defn ^:private with-braces [body] + (|do [_ (&reader/read-text "{") + output body + _ (&reader/read-text "}")] + (return output))) + +(def ^:private parse-type-param + (with-parens + (|do [=name parse-name + =bounds (with-pre-space + (spaced parse-gclass))] + (return (&/T [=name =bounds]))))) + +(def ^:private parse-gclass-decl + (with-parens + (|do [=class-name parse-name + =params (with-pre-space + (spaced parse-type-param))] + (return (&/T [=class-name =params]))))) + +(def ^:private parse-bound-kind + (&/try-all% (&/|list (|do [_ (&reader/read-text "<")] + (return &/$UpperBound)) + + (|do [_ (&reader/read-text ">")] + (return &/$LowerBound)) + ))) + +(def parse-gclass + (&/try-all% (&/|list (|do [=bound-kind parse-bound-kind + =bound parse-gclass] + (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound]))))) + + (|do [_ (&reader/read-text "?")] + (return (&/$GenericWildcard &/$None))) + + (|do [var-name parse-name] + (return (&/$GenericTypeVar var-name))) + + (with-parens + (|do [class-name parse-name + =params (with-pre-space + (spaced parse-gclass))] + (return (&/$GenericClass class-name =params)))) + + (with-parens + (|do [_ (&reader/read-text "#Array") + =param (with-pre-space + parse-gclass)] + (return (&/$GenericArray =param)))) + ))) + +(def ^:private parse-gclass-super + (with-parens + (|do [class-name parse-name + =params (with-pre-space + (spaced parse-gclass))] + (return (&/T [class-name =params]))))) + +(def ^:private parse-ctor-arg + (with-brackets + (|do [=class parse-gclass + (&/$Cons =term (&/$Nil)) (with-pre-space + &parser/parse)] + (return (&/T [=class =term]))))) + +(def ^:private parse-ann-param + (|do [param-name parse-name + _ (&reader/read-text "=") + param-value (&/try-all% (&/|list (|do [[_ (&lexer/$Bit param-value*)] &lexer/lex-bit] + (return (boolean param-value*))) + + (|do [[_ (&lexer/$Int param-value*)] &lexer/lex-int] + (return (int param-value*))) + + (|do [_ (&reader/read-text "l") + [_ (&lexer/$Int param-value*)] &lexer/lex-int] + (return (long param-value*))) + + (|do [[_ (&lexer/$Frac param-value*)] &lexer/lex-frac] + (return (float param-value*))) + + (|do [_ (&reader/read-text "d") + [_ (&lexer/$Frac param-value*)] &lexer/lex-frac] + (return (double param-value*))) + + (|do [[_ (&lexer/$Text param-value*)] &lexer/lex-text] + (return param-value*)) + ))] + (return (&/T [param-name param-value])))) + +(def ^:private parse-ann + (with-parens + (|do [ann-name parse-name + =ann-params (with-pre-space + (with-braces + (spaced parse-ann-param)))] + (return {:name ann-name + :params =ann-params})))) + +(def ^:private parse-arg-decl + (with-parens + (|do [=arg-name parse-ident + _ (&reader/read-text " ") + =gclass parse-gclass] + (return (&/T [=arg-name =gclass]))))) + +(def ^:private parse-gvars + (|do [?=head parse-name?] + (|case ?=head + (&/$Some =head) + (|do [[_ _ ?] (&reader/read-text? " ")] + (if ? + (|do [=tail parse-gvars] + (return (&/$Cons =head =tail))) + (return (&/|list =head)))) + + (&/$None) + (return (&/|list))))) + +(def ^:private parse-method-decl + (with-parens + (|do [=method-name parse-name + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =gvars (with-pre-space + (with-brackets + parse-gvars)) + =exceptions (with-pre-space + (with-brackets + (spaced parse-gclass))) + =inputs (with-pre-space + (with-brackets + (spaced parse-gclass))) + =output (with-pre-space + parse-gclass)] + (return (&/T [=method-name =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-privacy-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultPM)) + + (|do [_ (&reader/read-text "public")] + (return &/$PublicPM)) + + (|do [_ (&reader/read-text "protected")] + (return &/$ProtectedPM)) + + (|do [_ (&reader/read-text "private")] + (return &/$PrivatePM)) + ))) + +(def ^:private parse-state-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultSM)) + + (|do [_ (&reader/read-text "volatile")] + (return &/$VolatileSM)) + + (|do [_ (&reader/read-text "final")] + (return &/$FinalSM)) + ))) + +(def ^:private parse-inheritance-modifier + (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] + (return &/$DefaultIM)) + + (|do [_ (&reader/read-text "abstract")] + (return &/$AbstractIM)) + + (|do [_ (&reader/read-text "final")] + (return &/$FinalIM)) + ))) + +(def ^:private parse-method-init-def + (|do [_ (&reader/read-text "init") + =privacy-modifier (with-pre-space + parse-privacy-modifier) + [_ (&lexer/$Bit =strict*)] (with-pre-space + &lexer/lex-bit) + :let [=strict (Boolean/parseBoolean =strict*)] + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =gvars (with-pre-space + (with-brackets + (spaced parse-type-param))) + =exceptions (with-pre-space + (with-brackets + (spaced parse-gclass))) + =inputs (with-pre-space + (with-brackets + (spaced parse-arg-decl))) + =ctor-args (with-pre-space + (with-brackets + (spaced parse-ctor-arg))) + (&/$Cons =body (&/$Nil)) (with-pre-space + &parser/parse)] + (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =strict =anns =gvars =exceptions =inputs =ctor-args =body]))))) + +(def ^:private parse-method-virtual-def + (|do [_ (&reader/read-text "virtual") + =name (with-pre-space + parse-name) + =privacy-modifier (with-pre-space + parse-privacy-modifier) + [_ (&lexer/$Bit =final?*)] (with-pre-space + &lexer/lex-bit) + :let [=final? (Boolean/parseBoolean =final?*)] + [_ (&lexer/$Bit =strict*)] (with-pre-space + &lexer/lex-bit) + :let [=strict (Boolean/parseBoolean =strict*)] + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =gvars (with-pre-space + (with-brackets + (spaced parse-type-param))) + =exceptions (with-pre-space + (with-brackets + (spaced parse-gclass))) + =inputs (with-pre-space + (with-brackets + (spaced parse-arg-decl))) + =output (with-pre-space + parse-gclass) + (&/$Cons =body (&/$Nil)) (with-pre-space + &parser/parse)] + (return (&/$VirtualMethodSyntax (&/T [=name =privacy-modifier =final? =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-override-def + (|do [_ (&reader/read-text "override") + =class-decl (with-pre-space + parse-gclass-decl) + =name (with-pre-space + parse-name) + [_ (&lexer/$Bit =strict*)] (with-pre-space + &lexer/lex-bit) + :let [=strict (Boolean/parseBoolean =strict*)] + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =gvars (with-pre-space + (with-brackets + (spaced parse-type-param))) + =exceptions (with-pre-space + (with-brackets + (spaced parse-gclass))) + =inputs (with-pre-space + (with-brackets + (spaced parse-arg-decl))) + =output (with-pre-space + parse-gclass) + (&/$Cons =body (&/$Nil)) (with-pre-space + &parser/parse)] + (return (&/$OverridenMethodSyntax (&/T [=class-decl =name =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-static-def + (|do [_ (&reader/read-text "static") + =name (with-pre-space + parse-name) + =privacy-modifier (with-pre-space + parse-privacy-modifier) + [_ (&lexer/$Bit =strict*)] (with-pre-space + &lexer/lex-bit) + :let [=strict (Boolean/parseBoolean =strict*)] + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =gvars (with-pre-space + (with-brackets + (spaced parse-type-param))) + =exceptions (with-pre-space + (with-brackets + (spaced parse-gclass))) + =inputs (with-pre-space + (with-brackets + (spaced parse-arg-decl))) + =output (with-pre-space + parse-gclass) + (&/$Cons =body (&/$Nil)) (with-pre-space + &parser/parse)] + (return (&/$StaticMethodSyntax (&/T [=name =privacy-modifier =strict =anns =gvars =exceptions =inputs =output =body]))))) + +(def ^:private parse-method-abstract-def + (|do [_ (&reader/read-text "abstract") + =name (with-pre-space + parse-name) + =privacy-modifier (with-pre-space + parse-privacy-modifier) + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =gvars (with-pre-space + (with-brackets + (spaced parse-type-param))) + =exceptions (with-pre-space + (with-brackets + (spaced parse-gclass))) + =inputs (with-pre-space + (with-brackets + (spaced parse-arg-decl))) + =output (with-pre-space + parse-gclass)] + (return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-method-native-def + (|do [_ (&reader/read-text "native") + =name (with-pre-space + parse-name) + =privacy-modifier (with-pre-space + parse-privacy-modifier) + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =gvars (with-pre-space + (with-brackets + (spaced parse-type-param))) + =exceptions (with-pre-space + (with-brackets + (spaced parse-gclass))) + =inputs (with-pre-space + (with-brackets + (spaced parse-arg-decl))) + =output (with-pre-space + parse-gclass)] + (return (&/$NativeMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) + +(def ^:private parse-method-def + (with-parens + (&/try-all% (&/|list parse-method-init-def + parse-method-virtual-def + parse-method-override-def + parse-method-static-def + parse-method-abstract-def + parse-method-native-def + )))) + +(def ^:private parse-field + (with-parens + (&/try-all% (&/|list (|do [_ (&reader/read-text "constant") + =name (with-pre-space + parse-name) + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =type (with-pre-space + parse-gclass) + (&/$Cons =value (&/$Nil)) (with-pre-space + &parser/parse)] + (return (&/$ConstantFieldSyntax =name =anns =type =value))) + + (|do [_ (&reader/read-text "variable") + =name (with-pre-space + parse-name) + =privacy-modifier (with-pre-space + parse-privacy-modifier) + =state-modifier (with-pre-space + parse-state-modifier) + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =type (with-pre-space + parse-gclass)] + (return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type))) + )))) + +(def parse-interface-def + (|do [=gclass-decl parse-gclass-decl + =supers (with-pre-space + (with-brackets + (spaced parse-gclass-super))) + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =methods (with-pre-space + (spaced parse-method-decl))] + (return (&/T [=gclass-decl =supers =anns =methods])))) + +(def parse-class-def + (|do [=gclass-decl parse-gclass-decl + =super-class (with-pre-space + parse-gclass-super) + =interfaces (with-pre-space + (with-brackets + (spaced parse-gclass-super))) + =inheritance-modifier (with-pre-space + parse-inheritance-modifier) + =anns (with-pre-space + (with-brackets + (spaced parse-ann))) + =fields (with-pre-space + (with-brackets + (spaced parse-field))) + =methods (with-pre-space + (with-brackets + (spaced parse-method-def)))] + (return (&/T [=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods])))) + +(def parse-anon-class-def + (|do [=super-class parse-gclass-super + =interfaces (with-pre-space + (with-brackets + (spaced parse-gclass-super))) + =ctor-args (with-pre-space + (with-brackets + (spaced parse-ctor-arg))) + =methods (with-pre-space + (with-brackets + (spaced parse-method-def)))] + (return (&/T [=super-class =interfaces =ctor-args =methods])))) diff --git a/lux-bootstrapper/src/lux/analyser/proc/common.clj b/lux-bootstrapper/src/lux/analyser/proc/common.clj new file mode 100644 index 000000000..6a1521909 --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/proc/common.clj @@ -0,0 +1,299 @@ +(ns lux.analyser.proc.common + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type]) + (lux.analyser [base :as &&] + [module :as &&module]))) + +(defn- analyse-lux-is [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons reference (&/$Cons sample (&/$Nil))) ?values] + =reference (&&/analyse-1 analyse $var reference) + =sample (&&/analyse-1 analyse $var sample) + _ (&type/check exo-type &type/Bit) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["lux" "is"]) (&/|list =sample =reference) (&/|list))))))))) + +(defn- analyse-lux-try [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons op (&/$Nil)) ?values] + =op (&&/analyse-1 analyse (&/$Apply $var &type/IO) op) + _ (&type/check exo-type (&/$Sum &type/Text ;; lux.Left + $var ;; lux.Right + )) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list))))))))) + +(defn- analyse-lux-macro [analyse exo-type ?values] + (|do [:let [(&/$Cons macro (&/$Nil)) ?values] + [_real-name [_exported? _def-type _meta macro-type]] (&&module/find-def! &/prelude "Macro'") + [[=macro*-type =location] =macro] (&&/analyse-1 analyse macro-type macro) + _ (&type/check exo-type &type/Macro)] + (return (&/|list (&&/|meta exo-type =location + =macro))))) + +(do-template [<name> <proc> <input-type> <output-type>] + (defn- <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons reference (&/$Cons sample (&/$Nil))) ?values] + =reference (&&/analyse-1 analyse <input-type> reference) + =sample (&&/analyse-1 analyse <input-type> sample) + _ (&type/check exo-type <output-type>) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T <proc>) (&/|list =sample =reference) (&/|list))))))) + + analyse-text-eq ["text" "="] &type/Text &type/Bit + analyse-text-lt ["text" "<"] &type/Text &type/Bit + ) + +(defn- analyse-text-concat [analyse exo-type ?values] + (|do [:let [(&/$Cons parameter (&/$Cons subject (&/$Nil))) ?values] + =parameter (&&/analyse-1 analyse &type/Text parameter) + =subject (&&/analyse-1 analyse &type/Text subject) + _ (&type/check exo-type &type/Text) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["text" "concat"]) (&/|list =parameter =subject) (&/|list))))))) + +(defn- analyse-text-index [analyse exo-type ?values] + (|do [:let [(&/$Cons start (&/$Cons part (&/$Cons text (&/$Nil)))) ?values] + =start (&&/analyse-1 analyse &type/Nat start) + =part (&&/analyse-1 analyse &type/Text part) + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type (&/$Apply &type/Nat &type/Maybe)) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["text" "index"]) + (&/|list =text =part =start) + (&/|list))))))) + +(defn- analyse-text-clip [analyse exo-type ?values] + (|do [:let [(&/$Cons from (&/$Cons to (&/$Cons text (&/$Nil)))) ?values] + =from (&&/analyse-1 analyse &type/Nat from) + =to (&&/analyse-1 analyse &type/Nat to) + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Text) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["text" "clip"]) + (&/|list =text =from =to) + (&/|list))))))) + +(do-template [<name> <proc>] + (defn- <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Nat) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["text" <proc>]) + (&/|list =text) + (&/|list))))))) + + analyse-text-size "size" + ) + +(defn- analyse-text-char [analyse exo-type ?values] + (|do [:let [(&/$Cons idx (&/$Cons text (&/$Nil))) ?values] + =idx (&&/analyse-1 analyse &type/Nat idx) + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Nat) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["text" "char"]) + (&/|list =text =idx) + (&/|list))))))) + +(do-template [<name> <op>] + (let [inputT (&/$Apply &type/Any &type/I64) + outputT &type/I64] + (defn- <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons mask (&/$Cons input (&/$Nil))) ?values] + =mask (&&/analyse-1 analyse inputT mask) + =input (&&/analyse-1 analyse inputT input) + _ (&type/check exo-type outputT) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["i64" <op>]) (&/|list =input =mask) (&/|list)))))))) + + analyse-i64-and "and" + analyse-i64-or "or" + analyse-i64-xor "xor" + ) + +(do-template [<name> <op>] + (let [inputT (&/$Apply &type/Any &type/I64) + outputT &type/I64] + (defn- <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons shift (&/$Cons input (&/$Nil))) ?values] + =shift (&&/analyse-1 analyse &type/Nat shift) + =input (&&/analyse-1 analyse inputT input) + _ (&type/check exo-type outputT) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["i64" <op>]) (&/|list =input =shift) (&/|list)))))))) + + analyse-i64-left-shift "left-shift" + analyse-i64-arithmetic-right-shift "arithmetic-right-shift" + analyse-i64-logical-right-shift "logical-right-shift" + ) + +(do-template [<name> <proc> <input-type> <output-type>] + (let [inputT <input-type> + outputT <output-type>] + (defn- <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons parameterC (&/$Cons subjectC (&/$Nil))) ?values] + parameterA (&&/analyse-1 analyse <input-type> parameterC) + subjectA (&&/analyse-1 analyse <input-type> subjectC) + _ (&type/check exo-type <output-type>) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T <proc>) (&/|list subjectA parameterA) (&/|list)))))))) + + analyse-i64-eq ["i64" "="] (&/$Apply &type/Any &type/I64) &type/Bit + analyse-i64-add ["i64" "+"] (&/$Apply &type/Any &type/I64) &type/I64 + analyse-i64-sub ["i64" "-"] (&/$Apply &type/Any &type/I64) &type/I64 + + analyse-int-mul ["i64" "*"] &type/Int &type/Int + analyse-int-div ["i64" "/"] &type/Int &type/Int + analyse-int-rem ["i64" "%"] &type/Int &type/Int + analyse-int-lt ["i64" "<"] &type/Int &type/Bit + + analyse-frac-add ["f64" "+"] &type/Frac &type/Frac + analyse-frac-sub ["f64" "-"] &type/Frac &type/Frac + analyse-frac-mul ["f64" "*"] &type/Frac &type/Frac + analyse-frac-div ["f64" "/"] &type/Frac &type/Frac + analyse-frac-rem ["f64" "%"] &type/Frac &type/Frac + analyse-frac-eq ["f64" "="] &type/Frac &type/Bit + analyse-frac-lt ["f64" "<"] &type/Frac &type/Bit + ) + +(do-template [<encode> <encode-op> <decode> <decode-op> <type>] + (do (defn- <encode> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse <type> x) + _ (&type/check exo-type &type/Text) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T <encode-op>) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$Apply <type> &type/Maybe)] + (defn- <decode> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list))))))))) + + analyse-frac-encode ["f64" "encode"] analyse-frac-decode ["f64" "decode"] &type/Frac + ) + +(do-template [<name> <from-type> <to-type> <op>] + (defn- <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse <from-type> x) + _ (&type/check exo-type <to-type>) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T <op>) (&/|list =x) (&/|list))))))) + + analyse-int-char &type/Int &type/Text ["i64" "char"] + analyse-int-frac &type/Int &type/Frac ["i64" "f64"] + analyse-frac-int &type/Frac &type/Int ["f64" "i64"] + + analyse-io-log &type/Text &type/Any ["io" "log"] + analyse-io-error &type/Text &type/Nothing ["io" "error"] + analyse-io-exit &type/Int &type/Nothing ["io" "exit"] + ) + +(defn- analyse-io-current-time [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Int) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["io" "current-time"]) (&/|list) (&/|list))))))) + +(defn- analyse-syntax-char-case! [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Cons [_ (&/$Tuple ?pairs)] (&/$Cons ?else (&/$Nil)))) ?values] + _location &/location + =input (&&/analyse-1 analyse &type/Nat ?input) + _ (assert! (even? (&/|length ?pairs)) "The number of matches must be even!") + =pairs (&/map% (fn [?pair] + (|let [[[_ (&/$Tuple ?patterns)] ?match] ?pair] + (|do [=match (&&/analyse-1 analyse exo-type ?match)] + (return (&/T [(&/|map (fn [?pattern] + (|let [[_ (&/$Text ^String ?pattern-char)] ?pattern] + (int (.charAt ?pattern-char 0)))) + ?patterns) + =match]))))) + (&/|as-pairs ?pairs)) + =else (&&/analyse-1 analyse exo-type ?else)] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["lux" "syntax char case!"]) + (&/|list =input + (&&/|meta exo-type _location (&&/$tuple (&/|map &/|second =pairs))) + =else) + (&/|map &/|first =pairs))))))) + +(defn analyse-proc [analyse exo-type proc ?values] + (try (case proc + "lux is" (analyse-lux-is analyse exo-type ?values) + "lux try" (analyse-lux-try analyse exo-type ?values) + "lux macro" (analyse-lux-macro analyse exo-type ?values) + + "lux io log" (analyse-io-log analyse exo-type ?values) + "lux io error" (analyse-io-error analyse exo-type ?values) + "lux io exit" (analyse-io-exit analyse exo-type ?values) + "lux io current-time" (analyse-io-current-time analyse exo-type ?values) + + "lux text =" (analyse-text-eq analyse exo-type ?values) + "lux text <" (analyse-text-lt analyse exo-type ?values) + "lux text concat" (analyse-text-concat analyse exo-type ?values) + "lux text clip" (analyse-text-clip analyse exo-type ?values) + "lux text index" (analyse-text-index analyse exo-type ?values) + "lux text size" (analyse-text-size analyse exo-type ?values) + "lux text char" (analyse-text-char analyse exo-type ?values) + + "lux i64 and" (analyse-i64-and analyse exo-type ?values) + "lux i64 or" (analyse-i64-or analyse exo-type ?values) + "lux i64 xor" (analyse-i64-xor analyse exo-type ?values) + "lux i64 left-shift" (analyse-i64-left-shift analyse exo-type ?values) + "lux i64 arithmetic-right-shift" (analyse-i64-arithmetic-right-shift analyse exo-type ?values) + "lux i64 logical-right-shift" (analyse-i64-logical-right-shift analyse exo-type ?values) + "lux i64 +" (analyse-i64-add analyse exo-type ?values) + "lux i64 -" (analyse-i64-sub analyse exo-type ?values) + "lux i64 =" (analyse-i64-eq analyse exo-type ?values) + + "lux i64 *" (analyse-int-mul analyse exo-type ?values) + "lux i64 /" (analyse-int-div analyse exo-type ?values) + "lux i64 %" (analyse-int-rem analyse exo-type ?values) + "lux i64 <" (analyse-int-lt analyse exo-type ?values) + "lux i64 f64" (analyse-int-frac analyse exo-type ?values) + "lux i64 char" (analyse-int-char analyse exo-type ?values) + + "lux f64 +" (analyse-frac-add analyse exo-type ?values) + "lux f64 -" (analyse-frac-sub analyse exo-type ?values) + "lux f64 *" (analyse-frac-mul analyse exo-type ?values) + "lux f64 /" (analyse-frac-div analyse exo-type ?values) + "lux f64 %" (analyse-frac-rem analyse exo-type ?values) + "lux f64 =" (analyse-frac-eq analyse exo-type ?values) + "lux f64 <" (analyse-frac-lt analyse exo-type ?values) + "lux f64 encode" (analyse-frac-encode analyse exo-type ?values) + "lux f64 decode" (analyse-frac-decode analyse exo-type ?values) + "lux f64 i64" (analyse-frac-int analyse exo-type ?values) + + ;; Special extensions for performance reasons + ;; Will be replaced by custom extensions in the future. + "lux syntax char case!" (analyse-syntax-char-case! analyse exo-type ?values) + + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " proc))) + (catch Exception ex + (&/fail-with-loc (str "[Analyser Error] Invalid syntax for procedure: " proc))))) diff --git a/lux-bootstrapper/src/lux/analyser/proc/jvm.clj b/lux-bootstrapper/src/lux/analyser/proc/jvm.clj new file mode 100644 index 000000000..cc77bf72c --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/proc/jvm.clj @@ -0,0 +1,1082 @@ +(ns lux.analyser.proc.jvm + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type] + [host :as &host] + [lexer :as &lexer] + [parser :as &parser] + [reader :as &reader]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &&] + [env :as &&env] + [parser :as &&a-parser]) + [lux.compiler.jvm.base :as &c!base]) + (:import (java.lang.reflect Type TypeVariable))) + +;; [Utils] +(defn- ensure-object + "(-> Type (Lux (, Text (List Type))))" + [type] + (|case type + (&/$Primitive payload) + (return payload) + + (&/$Var id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$Ex id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$Named _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) + + (&/$Apply A F) + (|do [type* (&type/apply-type F A)] + (ensure-object type*)) + + _ + (&/fail-with-loc (str "[Analyser Error] Was expecting object type. Instead got: " (&type/show-type type))))) + +(defn- as-object + "(-> Type Type)" + [type] + (|case type + (&/$Primitive class params) + (&/$Primitive (&host-type/as-obj class) params) + + _ + type)) + +(defn- as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn- as-otype+ + "(-> Type Type)" + [type] + (|case type + (&/$Primitive name params) + (&/$Primitive (as-otype name) params) + + _ + type)) + +(defn- clean-gtype-var [idx gtype-var] + (|let [(&/$Var id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T [idx real-type]))) + (return (&/T [(+ 2 idx) (&/$Parameter idx)])))))) + +(defn- clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T [idx* (&/$Cons real-type types)])))) + (&/T [1 &/$Nil]) + gtype-vars)] + (return clean-types))) + +(defn- make-gtype + "(-> Text (List Type) Type)" + [class-name type-args] + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$Parameter _) + (&/$UnivQ &type/empty-env base-type) + + _ + base-type)) + (&/$Primitive class-name type-args) + type-args)) + +;; [Resources] +(defn- analyse-field-access-helper + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + [obj-type gvars gtype] + (|case obj-type + (&/$Primitive class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters for " (&type/show-type obj-type) "\n" + "Expected: " (&/|length targs) "\n" + " Actual: " (&/|length gvars)))) + + _ + (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + +(defn generic-class->simple-class [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar var-name) + "java.lang.Object" + + (&/$GenericWildcard _) + "java.lang.Object" + + (&/$GenericClass name params) + name + + (&/$GenericArray param) + (|case param + (&/$GenericArray _) + (str "[" (generic-class->simple-class param)) + + (&/$GenericClass "boolean" _) + "[Z" + + (&/$GenericClass "byte" _) + "[B" + + (&/$GenericClass "short" _) + "[S" + + (&/$GenericClass "int" _) + "[I" + + (&/$GenericClass "long" _) + "[J" + + (&/$GenericClass "float" _) + "[F" + + (&/$GenericClass "double" _) + "[D" + + (&/$GenericClass "char" _) + "[C" + + (&/$GenericClass name params) + (str "[L" name ";") + + (&/$GenericTypeVar var-name) + "[Ljava.lang.Object;" + + (&/$GenericWildcard _) + "[Ljava.lang.Object;") + )) + +(defn generic-class->type [env gclass] + "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" + (|case gclass + (&/$GenericTypeVar var-name) + (if-let [ex (&/|get var-name env)] + (return ex) + (&/fail-with-loc (str "[Analysis Error] Unknown type-var: " var-name))) + + (&/$GenericClass name params) + (case name + "boolean" (return (&/$Primitive "java.lang.Boolean" &/$Nil)) + "byte" (return (&/$Primitive "java.lang.Byte" &/$Nil)) + "short" (return (&/$Primitive "java.lang.Short" &/$Nil)) + "int" (return (&/$Primitive "java.lang.Integer" &/$Nil)) + "long" (return (&/$Primitive "java.lang.Long" &/$Nil)) + "float" (return (&/$Primitive "java.lang.Float" &/$Nil)) + "double" (return (&/$Primitive "java.lang.Double" &/$Nil)) + "char" (return (&/$Primitive "java.lang.Character" &/$Nil)) + "void" (return &type/Any) + ;; else + (|do [=params (&/map% (partial generic-class->type env) params)] + (return (&/$Primitive name =params)))) + + (&/$GenericArray param) + (|do [=param (generic-class->type env param)] + (return (&/$Primitive &host-type/array-data-tag (&/|list =param)))) + + (&/$GenericWildcard _) + (return (&/$ExQ &/$Nil (&/$Parameter 1))) + )) + +(defn gen-super-env + "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" + [class-env supers class-decl] + (|let [[class-name class-vars] class-decl] + (|case (&/|some (fn [super] + (|let [[super-name super-params] super] + (if (= class-name super-name) + (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) + &/$None))) + supers) + (&/$None) + (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) + + (&/$Some vars+gtypes) + (&/map% (fn [var+gtype] + (|do [:let [[var gtype] var+gtype] + =gtype (generic-class->type class-env gtype)] + (return (&/T [var =gtype])))) + vars+gtypes) + ))) + +(defn- make-type-env + "(-> (List TypeParam) (Lux (List [Text Type])))" + [type-params] + (&/map% (fn [gvar] + (|do [:let [[gvar-name _] gvar] + ex &type/existential] + (return (&/T [gvar-name ex])))) + type-params)) + +(defn- double-register-gclass? [gclass] + (|case gclass + (&/$GenericClass name _) + (|case name + "long" true + "double" true + _ false) + + _ + false)) + +(defn- method-input-folder [full-env] + (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type full-env itype*)] + (if (double-register-gclass? itype*) + (&&env/with-local iname itype + (&&env/with-local "" &type/Nothing + body*)) + (&&env/with-local iname itype + body*))))) + +(defn- analyse-method + "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" + [analyse class-decl class-env all-supers method] + (|let [[?cname ?cparams] class-decl + class-type (&/$Primitive ?cname (&/|map &/|second class-env))] + (|case method + (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + :let [output-type &type/Any] + =ctor-args (&/map% (fn [ctor-arg] + (|do [:let [[ca-type ca-term] ctor-arg] + =ca-type (generic-class->type full-env ca-type) + =ca-term (&&/analyse-1 analyse =ca-type ca-term)] + (return (&/T [ca-type =ca-term])))) + ?ctor-args) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))] + (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) + + (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))] + (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [super-env (gen-super-env class-env all-supers ?class-decl) + method-env (make-type-env ?gvars) + :let [full-env (&/|++ super-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))] + (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env method-env] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs)))] + (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + + (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + ))) + +(defn- mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn- check-method-completion + "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" + [supers methods] + (|do [abstract-methods (mandatory-methods supers) + :let [methods-map (&/fold (fn [mmap mentry] + (|case mentry + (&/$ConstructorMethodAnalysis _) + mmap + + (&/$VirtualMethodAnalysis _) + mmap + + (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) + + (&/$StaticMethodAnalysis _) + mmap + + (&/$AbstractMethodSyntax _) + mmap + + (&/$NativeMethodSyntax _) + mmap + )) + {} + methods) + missing-method (&/fold (fn [missing abs-meth] + (or missing + (|let [[am-name am-inputs] abs-meth] + (if-let [meth-struct (get methods-map am-name)] + (if (some (fn [=inputs] + (and (= (&/|length =inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] + (|let [[iname itype] mi] + (and prev (= (generic-class->simple-class itype) ai)))) + true + =inputs am-inputs))) + meth-struct) + nil + abs-meth) + abs-meth)))) + nil + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (|let [[am-name am-inputs] missing-method] + (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) + +(defn- analyse-field + "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" + [analyse gtype-env field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) + =value (&&/analyse-1 analyse =gtype ?value)] + (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) + + (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) + (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) + )) + +(do-template [<name> <proc> <from-class> <to-class>] + (let [output-type (&/$Primitive <to-class> &/$Nil)] + (defn- <name> [analyse exo-type _?value] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + =value (&&/analyse-1 analyse (&/$Primitive <from-class> &/$Nil) ?value) + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta output-type _location (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value) (&/|list)))))))) + + analyse-jvm-double-to-float "double-to-float" "java.lang.Double" "java.lang.Float" + analyse-jvm-double-to-int "double-to-int" "java.lang.Double" "java.lang.Integer" + analyse-jvm-double-to-long "double-to-long" "java.lang.Double" "java.lang.Long" + + analyse-jvm-float-to-double "float-to-double" "java.lang.Float" "java.lang.Double" + analyse-jvm-float-to-int "float-to-int" "java.lang.Float" "java.lang.Integer" + analyse-jvm-float-to-long "float-to-long" "java.lang.Float" "java.lang.Long" + + analyse-jvm-int-to-byte "int-to-byte" "java.lang.Integer" "java.lang.Byte" + analyse-jvm-int-to-char "int-to-char" "java.lang.Integer" "java.lang.Character" + analyse-jvm-int-to-double "int-to-double" "java.lang.Integer" "java.lang.Double" + analyse-jvm-int-to-float "int-to-float" "java.lang.Integer" "java.lang.Float" + analyse-jvm-int-to-long "int-to-long" "java.lang.Integer" "java.lang.Long" + analyse-jvm-int-to-short "int-to-short" "java.lang.Integer" "java.lang.Short" + + analyse-jvm-long-to-double "long-to-double" "java.lang.Long" "java.lang.Double" + analyse-jvm-long-to-float "long-to-float" "java.lang.Long" "java.lang.Float" + analyse-jvm-long-to-int "long-to-int" "java.lang.Long" "java.lang.Integer" + analyse-jvm-long-to-short "long-to-short" "java.lang.Long" "java.lang.Short" + analyse-jvm-long-to-byte "long-to-byte" "java.lang.Long" "java.lang.Byte" + + analyse-jvm-char-to-byte "char-to-byte" "java.lang.Character" "java.lang.Byte" + analyse-jvm-char-to-short "char-to-short" "java.lang.Character" "java.lang.Short" + analyse-jvm-char-to-int "char-to-int" "java.lang.Character" "java.lang.Integer" + analyse-jvm-char-to-long "char-to-long" "java.lang.Character" "java.lang.Long" + + analyse-jvm-short-to-long "short-to-long" "java.lang.Short" "java.lang.Long" + + analyse-jvm-byte-to-long "byte-to-long" "java.lang.Byte" "java.lang.Long" + ) + +(do-template [<name> <proc> <v1-class> <v2-class> <to-class>] + (let [output-type (&/$Primitive <to-class> &/$Nil)] + (defn- <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] + =value1 (&&/analyse-1 analyse (&/$Primitive <v1-class> &/$Nil) ?value1) + =value2 (&&/analyse-1 analyse (&/$Primitive <v2-class> &/$Nil) ?value2) + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta output-type _location (&&/$proc (&/T ["jvm" <proc>]) (&/|list =value1 =value2) (&/|list)))))))) + + analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + + analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" + analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ) + +(do-template [<name> <proc> <input-class> <output-class>] + (let [input-type (&/$Primitive <input-class> &/$Nil) + output-type (&/$Primitive <output-class> &/$Nil)] + (defn- <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta output-type _location + (&&/$proc (&/T ["jvm" <proc>]) (&/|list =x =y) (&/|list)))))))) + + analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ieq "ieq" "java.lang.Integer" "#Bit" + analyse-jvm-ilt "ilt" "java.lang.Integer" "#Bit" + analyse-jvm-igt "igt" "java.lang.Integer" "#Bit" + + analyse-jvm-ceq "ceq" "java.lang.Character" "#Bit" + analyse-jvm-clt "clt" "java.lang.Character" "#Bit" + analyse-jvm-cgt "cgt" "java.lang.Character" "#Bit" + + analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" + analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" + analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" + analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" + analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" + analyse-jvm-leq "leq" "java.lang.Long" "#Bit" + analyse-jvm-llt "llt" "java.lang.Long" "#Bit" + analyse-jvm-lgt "lgt" "java.lang.Long" "#Bit" + + analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" + analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" + analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" + analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" + analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" + analyse-jvm-feq "feq" "java.lang.Float" "#Bit" + analyse-jvm-flt "flt" "java.lang.Float" "#Bit" + analyse-jvm-fgt "fgt" "java.lang.Float" "#Bit" + + analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" + analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" + analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" + analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" + analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" + analyse-jvm-deq "deq" "java.lang.Double" "#Bit" + analyse-jvm-dlt "dlt" "java.lang.Double" "#Bit" + analyse-jvm-dgt "dgt" "java.lang.Double" "#Bit" + ) + +(let [length-type &type/Nat + idx-type &type/Nat] + (do-template [<elem-class> <array-class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>] + (let [elem-type (&/$Primitive <elem-class> &/$Nil) + array-type (&/$Primitive <array-class> &/$Nil)] + (defn- <new-name> [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" <new-tag>]) (&/|list =length) (&/|list))))))) + + (defn- <load-name> [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$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] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" <store-tag>]) (&/|list =array =idx =elem) (&/|list))))))) + ) + + "java.lang.Boolean" "[Z" analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" + "java.lang.Byte" "[B" analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" + "java.lang.Short" "[S" analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" + "java.lang.Integer" "[I" analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" + "java.lang.Long" "[J" analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" + "java.lang.Float" "[F" analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" + "java.lang.Double" "[D" analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" + "java.lang.Character" "[C" analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" + )) + +(defn- array-class? [class-name] + (or (= &host-type/array-data-tag class-name) + (case class-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true + ;; else + false))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn- analyse-jvm-anewarray [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$Text _gclass)] (&/$Cons length (&/$Nil))) ?values] + gclass (&reader/with-source "jvm-anewarray" _gclass + &&a-parser/parse-gclass) + gtype-env &/get-type-env + =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) + :let [array-type (&/$Primitive &host-type/array-data-tag (&/|list =gclass))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn- analyse-jvm-aaload [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) + + (defn- analyse-jvm-aastore [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn- analyse-jvm-arraylength [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Nil)) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Nat) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) + ))))) + +(defn- analyse-jvm-object-null? [analyse exo-type ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bit] + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "object null?"]) (&/|list =object) (&/|list))))))) + +(defn- analyse-jvm-object-null [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$Primitive &host-type/null-data-tag &/$Nil)] + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "object null"]) (&/|list) (&/|list))))))) + +(defn analyse-jvm-object-synchronized [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + =expr (&&/analyse-1 analyse exo-type ?expr) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "object synchronized"]) (&/|list =monitor =expr) (&/|list))))))) + +(defn- analyse-jvm-throw [analyse exo-type ?values] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] + =ex (&&/analyse-1+ analyse ?ex) + _ (&type/check (&/$Primitive "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) + [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) + _location &/location + _ (&type/check exo-type &type/Nothing)] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) + +(defn- analyse-jvm-getstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Nil) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + =type (&host-type/instance-param &type/existential &/$Nil gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) + +(defn- analyse-jvm-getfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Nil)) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader !class! field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) + +(defn- analyse-jvm-putstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons value (&/$Nil)) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (&host-type/instance-param &type/existential &/$Nil gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &type/Any] + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) + +(defn- analyse-jvm-putfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + :let [obj-type (&&/expr-type* =object)] + _ (ensure-object obj-type) + [gvars gtype] (&host/lookup-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (analyse-field-access-helper obj-type gvars gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &type/Any] + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) + +(defn- analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =arg-types (&/map% &type/show-type+ arg-types) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret) + _ (&type/check exo-type (as-otype+ =gret))] + (return (&/T [=gret =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [(&/$Var _id) $var + gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(defn- up-cast [class parent-gvars class-loader !class! object-type] + (|do [[sub-class sub-params] (ensure-object object-type) + (&/$Primitive super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) + !class! + sub-class) + sub-params)] + (return (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + parent-gvars + super-params*)))) + +(defn- check-method! [only-interface? class method] + (|do [!class!* (&/de-alias-class class) + :let [!class! (string/replace !class!* "/" ".")] + class-loader &/loader + _ (try (assert! (let [=class (Class/forName !class! true class-loader)] + (= only-interface? (.isInterface =class))) + (if only-interface? + (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") + (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " !class!))))] + (return (&/T [!class! class-loader])))) + +(let [dummy-type-param (&/$Primitive "java.lang.Object" &/$Nil)] + (do-template [<name> <tag> <only-interface?>] + (defn- <name> [analyse exo-type class method classes ?values] + (|do [:let [(&/$Cons object args) ?values] + [!class! class-loader] (check-method! <only-interface?> class method) + [gret exceptions parent-gvars gvars gargs] (if (= "<init>" method) + (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) + (&host/lookup-virtual-method class-loader !class! method classes)) + =object (&&/analyse-1+ analyse object) + gtype-env (up-cast class parent-gvars class-loader !class! (&&/expr-type* =object)) + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" <tag>]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) + + analyse-jvm-invokevirtual "invokevirtual" false + analyse-jvm-invokespecial "invokespecial" false + analyse-jvm-invokeinterface "invokeinterface" true + )) + +(defn- analyse-jvm-invokestatic [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) + :let [gtype-env (&/|table)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) + +(defn- analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T [(make-gtype gtype gtype-vars*) + =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(defn- analyse-jvm-new [analyse exo-type class classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta exo-type _location + (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) + +(defn- analyse-jvm-instanceof [analyse exo-type class ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bit] + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta output-type _location + (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) + +(defn- analyse-jvm-object-class [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$Text _class-name)] (&/$Nil)) ?values] + ^ClassLoader class-loader &/loader + _ (try (do (.loadClass class-loader _class-name) + (return nil)) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) + :let [output-type (&/$Primitive "java.lang.Class" (&/|list (&/$Primitive _class-name (&/|list))))] + _ (&type/check exo-type output-type) + _location &/location] + (return (&/|list (&&/|meta output-type _location + (&&/$proc (&/T ["jvm" "object class"]) (&/|list) (&/|list _class-name output-type))))))) + +(defn- 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 'INTERFACE (str module "." (&/|first interface-decl)))] + _location &/location] + (return (&/|list (&&/|meta &type/Any _location + (&&/$tuple (&/|list))))))) + +(defn- analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] + (&/with-closure + (|do [module &/get-module-name + :let [[?name ?params] class-decl + full-name (str (string/replace module "/" ".") "." ?name) + class-decl* (&/T [full-name ?params]) + all-supers (&/$Cons super-class interfaces)] + class-env (make-type-env ?params) + =fields (&/map% (partial analyse-field analyse class-env) ?fields) + _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) + =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) + _ (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 'CLASS full-name)] + _location &/location] + (return (&/|list (&&/|meta &type/Any _location + (&&/$tuple (&/|list)))))))) + +(defn- captured-source [env-entry] + (|case env-entry + [name [_ (&&/$captured _ _ source)]] + source)) + +(defn- analyse-methods [analyse class-decl all-supers methods] + (|do [=methods (&/map% (partial analyse-method analyse class-decl &/$Nil all-supers) methods) + _ (check-method-completion all-supers =methods) + =captured &&env/captured-vars] + (return (&/T [=methods =captured])))) + +(defn- get-names [] + (|do [module &/get-module-name + scope &/get-scope-name] + (return (&/T [module scope])))) + +(let [default-<init> (&/$ConstructorMethodSyntax (&/T [&/$PublicPM + false + &/$Nil + &/$Nil + &/$Nil + &/$Nil + &/$Nil + (&/$Tuple &/$Nil)])) + captured-slot-class "java.lang.Object" + captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] + (defn- analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] + (&/with-closure + (|do [[module scope] (get-names) + :let [name (->> scope &/|reverse &/|tail &host/location) + class-decl (&/T [name &/$Nil]) + anon-class (str (string/replace module "/" ".") "." name) + class-type-decl (&/T [anon-class &/$Nil]) + anon-class-type (&/$Primitive anon-class &/$Nil)] + =ctor-args (&/map% (fn [ctor-arg] + (|let [[arg-type arg-term] ctor-arg] + (|do [=arg-term (&&/analyse-1+ analyse arg-term)] + (return (&/T [arg-type =arg-term]))))) + ctor-args) + _ (->> methods + (&/$Cons default-<init>) + (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) + [=methods =captured] (let [all-supers (&/$Cons super-class interfaces)] + (analyse-methods analyse class-type-decl all-supers methods)) + _ (let [=fields (&/|map (fn [^objects idx+capt] + (|let [[idx _] idx+capt] + (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) + &/$PublicPM + &/$FinalSM + &/$Nil + captured-slot-type))) + (&/enumerate =captured))] + (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args))) + _ &/pop-dummy-name + _location &/location] + (let [sources (&/|map captured-source =captured)] + (return (&/|list (&&/|meta anon-class-type _location + (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))))))) + )))) + +(defn analyse-host [analyse exo-type compilers proc ?values] + (|let [[_ _ _ compile-class compile-interface] compilers] + (try (case proc + "jvm object synchronized" (analyse-jvm-object-synchronized analyse exo-type ?values) + "jvm object class" (analyse-jvm-object-class analyse exo-type ?values) + "jvm throw" (analyse-jvm-throw analyse exo-type ?values) + "jvm object null?" (analyse-jvm-object-null? analyse exo-type ?values) + "jvm object null" (analyse-jvm-object-null analyse exo-type ?values) + "jvm anewarray" (analyse-jvm-anewarray analyse exo-type ?values) + "jvm aaload" (analyse-jvm-aaload analyse exo-type ?values) + "jvm aastore" (analyse-jvm-aastore analyse exo-type ?values) + "jvm arraylength" (analyse-jvm-arraylength analyse exo-type ?values) + "jvm znewarray" (analyse-jvm-znewarray analyse exo-type ?values) + "jvm bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) + "jvm snewarray" (analyse-jvm-snewarray analyse exo-type ?values) + "jvm inewarray" (analyse-jvm-inewarray analyse exo-type ?values) + "jvm lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) + "jvm fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) + "jvm dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) + "jvm cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) + "jvm zaload" (analyse-jvm-zaload analyse exo-type ?values) + "jvm zastore" (analyse-jvm-zastore analyse exo-type ?values) + "jvm baload" (analyse-jvm-baload analyse exo-type ?values) + "jvm bastore" (analyse-jvm-bastore analyse exo-type ?values) + "jvm saload" (analyse-jvm-saload analyse exo-type ?values) + "jvm sastore" (analyse-jvm-sastore analyse exo-type ?values) + "jvm iaload" (analyse-jvm-iaload analyse exo-type ?values) + "jvm iastore" (analyse-jvm-iastore analyse exo-type ?values) + "jvm laload" (analyse-jvm-laload analyse exo-type ?values) + "jvm lastore" (analyse-jvm-lastore analyse exo-type ?values) + "jvm faload" (analyse-jvm-faload analyse exo-type ?values) + "jvm fastore" (analyse-jvm-fastore analyse exo-type ?values) + "jvm daload" (analyse-jvm-daload analyse exo-type ?values) + "jvm dastore" (analyse-jvm-dastore analyse exo-type ?values) + "jvm caload" (analyse-jvm-caload analyse exo-type ?values) + "jvm castore" (analyse-jvm-castore analyse exo-type ?values) + "jvm iadd" (analyse-jvm-iadd analyse exo-type ?values) + "jvm isub" (analyse-jvm-isub analyse exo-type ?values) + "jvm imul" (analyse-jvm-imul analyse exo-type ?values) + "jvm idiv" (analyse-jvm-idiv analyse exo-type ?values) + "jvm irem" (analyse-jvm-irem analyse exo-type ?values) + "jvm ieq" (analyse-jvm-ieq analyse exo-type ?values) + "jvm ilt" (analyse-jvm-ilt analyse exo-type ?values) + "jvm igt" (analyse-jvm-igt analyse exo-type ?values) + "jvm ceq" (analyse-jvm-ceq analyse exo-type ?values) + "jvm clt" (analyse-jvm-clt analyse exo-type ?values) + "jvm cgt" (analyse-jvm-cgt analyse exo-type ?values) + "jvm ladd" (analyse-jvm-ladd analyse exo-type ?values) + "jvm lsub" (analyse-jvm-lsub analyse exo-type ?values) + "jvm lmul" (analyse-jvm-lmul analyse exo-type ?values) + "jvm ldiv" (analyse-jvm-ldiv analyse exo-type ?values) + "jvm lrem" (analyse-jvm-lrem analyse exo-type ?values) + "jvm leq" (analyse-jvm-leq analyse exo-type ?values) + "jvm llt" (analyse-jvm-llt analyse exo-type ?values) + "jvm lgt" (analyse-jvm-lgt analyse exo-type ?values) + "jvm fadd" (analyse-jvm-fadd analyse exo-type ?values) + "jvm fsub" (analyse-jvm-fsub analyse exo-type ?values) + "jvm fmul" (analyse-jvm-fmul analyse exo-type ?values) + "jvm fdiv" (analyse-jvm-fdiv analyse exo-type ?values) + "jvm frem" (analyse-jvm-frem analyse exo-type ?values) + "jvm feq" (analyse-jvm-feq analyse exo-type ?values) + "jvm flt" (analyse-jvm-flt analyse exo-type ?values) + "jvm fgt" (analyse-jvm-fgt analyse exo-type ?values) + "jvm dadd" (analyse-jvm-dadd analyse exo-type ?values) + "jvm dsub" (analyse-jvm-dsub analyse exo-type ?values) + "jvm dmul" (analyse-jvm-dmul analyse exo-type ?values) + "jvm ddiv" (analyse-jvm-ddiv analyse exo-type ?values) + "jvm drem" (analyse-jvm-drem analyse exo-type ?values) + "jvm deq" (analyse-jvm-deq analyse exo-type ?values) + "jvm dlt" (analyse-jvm-dlt analyse exo-type ?values) + "jvm dgt" (analyse-jvm-dgt analyse exo-type ?values) + "jvm iand" (analyse-jvm-iand analyse exo-type ?values) + "jvm ior" (analyse-jvm-ior analyse exo-type ?values) + "jvm ixor" (analyse-jvm-ixor analyse exo-type ?values) + "jvm ishl" (analyse-jvm-ishl analyse exo-type ?values) + "jvm ishr" (analyse-jvm-ishr analyse exo-type ?values) + "jvm iushr" (analyse-jvm-iushr analyse exo-type ?values) + "jvm land" (analyse-jvm-land analyse exo-type ?values) + "jvm lor" (analyse-jvm-lor analyse exo-type ?values) + "jvm lxor" (analyse-jvm-lxor analyse exo-type ?values) + "jvm lshl" (analyse-jvm-lshl analyse exo-type ?values) + "jvm lshr" (analyse-jvm-lshr analyse exo-type ?values) + "jvm lushr" (analyse-jvm-lushr analyse exo-type ?values) + "jvm convert double-to-float" (analyse-jvm-double-to-float analyse exo-type ?values) + "jvm convert double-to-int" (analyse-jvm-double-to-int analyse exo-type ?values) + "jvm convert double-to-long" (analyse-jvm-double-to-long analyse exo-type ?values) + "jvm convert float-to-double" (analyse-jvm-float-to-double analyse exo-type ?values) + "jvm convert float-to-int" (analyse-jvm-float-to-int analyse exo-type ?values) + "jvm convert float-to-long" (analyse-jvm-float-to-long analyse exo-type ?values) + "jvm convert int-to-byte" (analyse-jvm-int-to-byte analyse exo-type ?values) + "jvm convert int-to-char" (analyse-jvm-int-to-char analyse exo-type ?values) + "jvm convert int-to-double" (analyse-jvm-int-to-double analyse exo-type ?values) + "jvm convert int-to-float" (analyse-jvm-int-to-float analyse exo-type ?values) + "jvm convert int-to-long" (analyse-jvm-int-to-long analyse exo-type ?values) + "jvm convert int-to-short" (analyse-jvm-int-to-short analyse exo-type ?values) + "jvm convert long-to-double" (analyse-jvm-long-to-double analyse exo-type ?values) + "jvm convert long-to-float" (analyse-jvm-long-to-float analyse exo-type ?values) + "jvm convert long-to-int" (analyse-jvm-long-to-int analyse exo-type ?values) + "jvm convert long-to-short" (analyse-jvm-long-to-short analyse exo-type ?values) + "jvm convert long-to-byte" (analyse-jvm-long-to-byte analyse exo-type ?values) + "jvm convert char-to-byte" (analyse-jvm-char-to-byte analyse exo-type ?values) + "jvm convert char-to-short" (analyse-jvm-char-to-short analyse exo-type ?values) + "jvm convert char-to-int" (analyse-jvm-char-to-int analyse exo-type ?values) + "jvm convert char-to-long" (analyse-jvm-char-to-long analyse exo-type ?values) + "jvm convert byte-to-long" (analyse-jvm-byte-to-long analyse exo-type ?values) + "jvm convert short-to-long" (analyse-jvm-short-to-long analyse exo-type ?values) + ;; else + (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " ["jvm" proc])) + (if-let [[_ _def-code] (re-find #"^jvm interface:(.*)$" proc)] + (|do [[_module _line _column] &/location] + (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] + (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) + + (if-let [[_ _def-code] (re-find #"^jvm class:(.*)$" proc)] + (|do [[_module _line _column] &/location] + (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] + (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) + + (if-let [[_ _def-code] (re-find #"^jvm anon-class:(.*)$" proc)] + (|do [[_module _line _column] &/location] + (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] + (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) + + (if-let [[_ _class] (re-find #"^jvm instanceof:([^:]+)$" proc)] + (analyse-jvm-instanceof analyse exo-type _class ?values)) + + (if-let [[_ _class _arg-classes] (re-find #"^jvm new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^jvm invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^jvm invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^jvm invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^jvm invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _field] (re-find #"^jvm getstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^jvm getfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getfield analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^jvm putstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^jvm putfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putfield analyse exo-type _class _field ?values)))) + (catch Exception ex + (&/fail-with-loc (str "[Analyser Error] Invalid syntax for procedure: " proc)))) + )) diff --git a/lux-bootstrapper/src/lux/analyser/record.clj b/lux-bootstrapper/src/lux/analyser/record.clj new file mode 100644 index 000000000..3d3d8169f --- /dev/null +++ b/lux-bootstrapper/src/lux/analyser/record.clj @@ -0,0 +1,42 @@ +(ns lux.analyser.record + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return |case]] + [type :as &type]) + (lux.analyser [base :as &&] + [module :as &&module]))) + +;; [Exports] +(defn order-record [pairs] + "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" + (|do [[tag-group tag-type] (|case pairs + (&/$Nil) + (return (&/T [&/$Nil &type/Any])) + + (&/$Cons [[_ (&/$Tag tag1)] _] _) + (|do [[module name] (&&/resolved-ident tag1) + tags (&&module/tag-group module name) + type (&&module/tag-type module name)] + (return (&/T [tags type]))) + + _ + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + =pairs (&/map% (fn [kv] + (|case kv + [[_ (&/$Tag k)] v] + (|do [=k (&&/resolved-ident k)] + (return (&/T [(&/ident->text =k) v]))) + + _ + (&/fail-with-loc "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + pairs) + _ (let [num-expected (&/|length tag-group) + num-got (&/|length =pairs)] + (&/assert! (= num-expected num-got) + (str "[Analyser Error] Wrong number of record members. Expected " num-expected ", but got " num-got "."))) + =members (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (&/fail-with-loc (str "[Analyser Error] Missing tag: " tag)))) + (&/|map &/ident->text tag-group))] + (return (&/T [=members tag-type])))) diff --git a/lux-bootstrapper/src/lux/base.clj b/lux-bootstrapper/src/lux/base.clj new file mode 100644 index 000000000..5ef710a03 --- /dev/null +++ b/lux-bootstrapper/src/lux/base.clj @@ -0,0 +1,1490 @@ +(ns lux.base + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array)) + +(def prelude + "lux") + +(def !log! (atom false)) +(defn flag-prn! [& args] + (when @!log! + (apply prn args))) + +;; [Tags] +(def unit-tag (.intern "")) + +(defn T [elems] + (case (count elems) + 0 + unit-tag + + 1 + (first elems) + + ;; else + (to-array elems))) + +(defmacro defvariant [& names] + (assert (> (count names) 1)) + `(do ~@(for [[[name num-params] idx] (map vector names (range (count names))) + :let [last-idx (dec (count names)) + is-last? (if (= idx last-idx) + "" + nil) + def-name (with-meta (symbol (str "$" name)) + {::idx idx + ::is-last? is-last?})]] + (cond (= 0 num-params) + `(def ~def-name + (to-array [(int ~idx) ~is-last? unit-tag])) + + (= 1 num-params) + `(defn ~def-name [arg#] + (to-array [(int ~idx) ~is-last? arg#])) + + :else + (let [g!args (map (fn [_] (gensym "arg")) + (range num-params))] + `(defn ~def-name [~@g!args] + (to-array [(int ~idx) ~is-last? (T [~@g!args])]))) + )))) + +(defmacro deftuple [names] + (assert (vector? names)) + `(do ~@(for [[name idx] (map vector names (range (count names)))] + `(def ~(symbol (str "$" name)) + (int ~idx))))) + +;; List +(defvariant + ("Nil" 0) + ("Cons" 2)) + +;; Maybe +(defvariant + ("None" 0) + ("Some" 1)) + +;; Either +(defvariant + ("Left" 1) + ("Right" 1)) + +;; Code +(defvariant + ("Bit" 1) + ("Nat" 1) + ("Int" 1) + ("Rev" 1) + ("Frac" 1) + ("Text" 1) + ("Identifier" 1) + ("Tag" 1) + ("Form" 1) + ("Tuple" 1) + ("Record" 1)) + +;; Type +(defvariant + ("Primitive" 2) + ("Sum" 2) + ("Product" 2) + ("Function" 2) + ("Parameter" 1) + ("Var" 1) + ("Ex" 1) + ("UnivQ" 2) + ("ExQ" 2) + ("Apply" 2) + ("Named" 2)) + +;; Vars +(defvariant + ("Local" 1) + ("Captured" 1)) + +;; Binding +(deftuple + ["counter" + "mappings"]) + +;; Type-Context +(deftuple + ["ex-counter" + "var-counter" + "var-bindings"]) + +;; Env +(deftuple + ["name" + "inner" + "locals" + "captured"]) + +;; Host +(deftuple + ["writer" + "loader" + "classes" + "type-env" + "dummy-mappings" + ]) + +(defvariant + ("Build" 0) + ("Eval" 0) + ("REPL" 0)) + +(deftuple + ["target" + "version" + "mode"]) + +;; Hosts +(defvariant + ("Jvm" 1) + ("Js" 1)) + +(deftuple + ["info" + "source" + "location" + "current-module" + "modules" + "scopes" + "type-context" + "expected" + "seed" + "scope-type-vars" + "extensions" + "host"]) + +(defvariant + ("UpperBound" 0) + ("LowerBound" 0)) + +(defvariant + ("GenericTypeVar" 1) + ("GenericClass" 2) + ("GenericArray" 1) + ("GenericWildcard" 1)) + +;; Privacy Modifiers +(defvariant + ("DefaultPM" 0) + ("PublicPM" 0) + ("PrivatePM" 0) + ("ProtectedPM" 0)) + +;; State Modifiers +(defvariant + ("DefaultSM" 0) + ("VolatileSM" 0) + ("FinalSM" 0)) + +;; Inheritance Modifiers +(defvariant + ("DefaultIM" 0) + ("AbstractIM" 0) + ("FinalIM" 0)) + +;; Fields +(defvariant + ("ConstantFieldSyntax" 4) + ("VariableFieldSyntax" 5)) + +(defvariant + ("ConstantFieldAnalysis" 4) + ("VariableFieldAnalysis" 5)) + +;; Methods +(defvariant + ("ConstructorMethodSyntax" 1) + ("VirtualMethodSyntax" 1) + ("OverridenMethodSyntax" 1) + ("StaticMethodSyntax" 1) + ("AbstractMethodSyntax" 1) + ("NativeMethodSyntax" 1)) + +(defvariant + ("ConstructorMethodAnalysis" 1) + ("VirtualMethodAnalysis" 1) + ("OverridenMethodAnalysis" 1) + ("StaticMethodAnalysis" 1) + ("AbstractMethodAnalysis" 1) + ("NativeMethodAnalysis" 1)) + +;; [Exports] +(def ^:const value-field "_value") +(def ^:const module-class-name "_") +(def ^:const +name-separator+ ".") + +(def ^:const ^String version "0.6.0") + +;; Constructors +(def empty-location (T ["" -1 -1])) + +(defn get$ [slot ^objects record] + (aget record slot)) + +(defn set$ [slot value ^objects record] + (doto (aclone ^objects record) + (aset slot value))) + +(defmacro update$ [slot f record] + `(let [record# ~record] + (set$ ~slot (~f (get$ ~slot record#)) + record#))) + +(defn fail* [message] + ($Left message)) + +(defn return* [state value] + ($Right (T [state value]))) + +(defn transform-pattern [pattern] + (cond (vector? pattern) (case (count pattern) + 0 + unit-tag + + 1 + (transform-pattern (first pattern)) + + ;; else + (mapv transform-pattern pattern)) + (seq? pattern) [(if-let [tag-var (ns-resolve *ns* (first pattern))] + (-> tag-var + meta + ::idx) + (assert false (str "Unknown var: " (first pattern)))) + '_ + (transform-pattern (vec (rest pattern)))] + :else pattern)) + +(defmacro |case [value & branches] + (assert (= 0 (mod (count branches) 2))) + (let [value* (if (vector? value) + [`(T [~@value])] + [value])] + `(matchv ::M/objects ~value* + ~@(mapcat (fn [[pattern body]] + (list [(transform-pattern pattern)] + body)) + (partition 2 branches))))) + +(defmacro |let [bindings body] + (reduce (fn [inner [left right]] + `(|case ~right + ~left + ~inner)) + body + (reverse (partition 2 bindings)))) + +(defmacro |list [& elems] + (reduce (fn [tail head] + `($Cons ~head ~tail)) + `$Nil + (reverse elems))) + +(defmacro |table [& elems] + (reduce (fn [table [k v]] + `(|put ~k ~v ~table)) + `$Nil + (reverse (partition 2 elems)))) + +(defn |get [slot table] + (|case table + ($Nil) + nil + + ($Cons [k v] table*) + (if (= k slot) + v + (recur slot table*)))) + +(defn |put [slot value table] + (|case table + ($Nil) + ($Cons (T [slot value]) $Nil) + + ($Cons [k v] table*) + (if (= k slot) + ($Cons (T [slot value]) table*) + ($Cons (T [k v]) (|put slot value table*))) + )) + +(defn |remove [slot table] + (|case table + ($Nil) + table + + ($Cons [k v] table*) + (if (= k slot) + table* + ($Cons (T [k v]) (|remove slot table*))))) + +(defn |update [k f table] + (|case table + ($Nil) + table + + ($Cons [k* v] table*) + (if (= k k*) + ($Cons (T [k* (f v)]) table*) + ($Cons (T [k* v]) (|update k f table*))))) + +(defn |head [xs] + (|case xs + ($Nil) + (assert false (prn-str '|head)) + + ($Cons x _) + x)) + +(defn |tail [xs] + (|case xs + ($Nil) + (assert false (prn-str '|tail)) + + ($Cons _ xs*) + xs*)) + +;; [Resources/Monads] +(defn fail [message] + (fn [_] + ($Left message))) + +(defn return [value] + (fn [state] + ($Right (T [state value])))) + +(defn bind [m-value step] + (fn [state] + (let [inputs (m-value state)] + (|case inputs + ($Right ?state ?datum) + ((step ?datum) ?state) + + ($Left _) + inputs + )))) + +(defmacro |do [steps return] + (assert (= 0 (rem (count steps) 2)) "The number of steps must be even!") + (reduce (fn [inner [label computation]] + (case label + :let `(|let ~computation ~inner) + ;; else + `(bind ~computation + (fn [val#] + (|case val# + ~label + ~inner))))) + return + (reverse (partition 2 steps)))) + +;; [Resources/Combinators] +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + +(defn |++ [xs ys] + (|case xs + ($Nil) + ys + + ($Cons x xs*) + ($Cons x (|++ xs* ys)))) + +(defn |map [f xs] + (|case xs + ($Nil) + xs + + ($Cons x xs*) + ($Cons (f x) (|map f xs*)) + + _ + (assert false (prn-str '|map f (adt->text xs))))) + +(defn |empty? + "(All [a] (-> (List a) Bit))" + [xs] + (|case xs + ($Nil) + true + + ($Cons _ _) + false)) + +(defn |filter + "(All [a] (-> (-> a Bit) (List a) (List a)))" + [p xs] + (|case xs + ($Nil) + xs + + ($Cons x xs*) + (if (p x) + ($Cons x (|filter p xs*)) + (|filter p xs*)))) + +(defn flat-map + "(All [a b] (-> (-> a (List b)) (List a) (List b)))" + [f xs] + (|case xs + ($Nil) + xs + + ($Cons x xs*) + (|++ (f x) (flat-map f xs*)))) + +(defn |split-with [p xs] + (|case xs + ($Nil) + (T [xs xs]) + + ($Cons x xs*) + (if (p x) + (|let [[pre post] (|split-with p xs*)] + (T [($Cons x pre) post])) + (T [$Nil xs])))) + +(defn |contains? [k table] + (|case table + ($Nil) + false + + ($Cons [k* _] table*) + (or (= k k*) + (|contains? k table*)))) + +(defn |member? [x xs] + (|case xs + ($Nil) + false + + ($Cons x* xs*) + (or (= x x*) (|member? x xs*)))) + +(defn fold [f init xs] + (|case xs + ($Nil) + init + + ($Cons x xs*) + (recur f (f init x) xs*))) + +(defn fold% [f init xs] + (|case xs + ($Nil) + (return init) + + ($Cons x xs*) + (|do [init* (f init x)] + (fold% f init* xs*)))) + +(defn folds [f init xs] + (|case xs + ($Nil) + (|list init) + + ($Cons x xs*) + ($Cons init (folds f (f init x) xs*)))) + +(defn |length [xs] + (fold (fn [acc _] (inc acc)) 0 xs)) + +(defn |range* [from to] + (if (<= from to) + ($Cons from (|range* (inc from) to)) + $Nil)) + +(let [|range* (fn |range* [from to] + (if (< from to) + ($Cons from (|range* (inc from) to)) + $Nil))] + (defn |range [n] + (|range* 0 n))) + +(defn |first [pair] + (|let [[_1 _2] pair] + _1)) + +(defn |second [pair] + (|let [[_1 _2] pair] + _2)) + +(defn zip2 [xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + ($Cons (T [x y]) (zip2 xs* ys*)) + + [_ _] + $Nil)) + +(defn |keys [plist] + (|case plist + ($Nil) + $Nil + + ($Cons [k v] plist*) + ($Cons k (|keys plist*)))) + +(defn |vals [plist] + (|case plist + ($Nil) + $Nil + + ($Cons [k v] plist*) + ($Cons v (|vals plist*)))) + +(defn |interpose [sep xs] + (|case xs + ($Nil) + xs + + ($Cons _ ($Nil)) + xs + + ($Cons x xs*) + ($Cons x ($Cons sep (|interpose sep xs*))))) + +(do-template [<name> <joiner>] + (defn <name> [f xs] + (|case xs + ($Nil) + (return xs) + + ($Cons x xs*) + (|do [y (f x) + ys (<name> f xs*)] + (return (<joiner> y ys))))) + + map% $Cons + flat-map% |++) + +(defn list-join [xss] + (fold |++ $Nil xss)) + +(defn |as-pairs [xs] + (|case xs + ($Cons x ($Cons y xs*)) + ($Cons (T [x y]) (|as-pairs xs*)) + + _ + $Nil)) + +(defn |reverse [xs] + (fold (fn [tail head] + ($Cons head tail)) + $Nil + xs)) + +(defn add-loc [meta ^String msg] + (if (.startsWith msg "@") + msg + (|let [[file line col] meta] + (str "@ " file "," line "," col "\n" msg)))) + +(defn fail-with-loc [msg] + (fn [state] + (fail* (add-loc (get$ $location state) msg)))) + +(defn assert! [test message] + (if test + (return unit-tag) + (fail-with-loc message))) + +(def get-state + (fn [state] + (return* state state))) + +(defn try-all% [monads] + (|case monads + ($Nil) + (fail "[Error] There are no alternatives to try!") + + ($Cons m monads*) + (fn [state] + (let [output (m state)] + (|case [output monads*] + [($Right _) _] + output + + [_ ($Nil)] + output + + [_ _] + ((try-all% monads*) state) + ))) + )) + +(defn try-all-% [prefix monads] + (|case monads + ($Nil) + (fail "[Error] There are no alternatives to try!") + + ($Cons m monads*) + (fn [state] + (let [output (m state)] + (|case [output monads*] + [($Right _) _] + output + + [_ ($Nil)] + output + + [($Left ^String error) _] + (if (.contains error prefix) + ((try-all-% prefix monads*) state) + output) + ))) + )) + +(defn exhaust% [step] + (fn [state] + (|case (step state) + ($Right state* _) + ((exhaust% step) state*) + + ($Left ^String msg) + (if (.contains msg "[Reader Error] EOF") + (return* state unit-tag) + (fail* msg))))) + +(defn |some + "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" + [f xs] + (|case xs + ($Nil) + $None + + ($Cons x xs*) + (|case (f x) + ($None) (|some f xs*) + output output) + )) + +(defn ^:private normalize-char [char] + (case char + \* "_AS" + \+ "_PL" + \- "_DS" + \/ "_SL" + \\ "_BS" + \_ "_US" + \% "_PC" + \$ "_DL" + \' "_QU" + \` "_BQ" + \@ "_AT" + \^ "_CR" + \& "_AA" + \= "_EQ" + \! "_BG" + \? "_QM" + \: "_CO" + \; "_SC" + \. "_PD" + \, "_CM" + \< "_LT" + \> "_GT" + \~ "_TI" + \| "_PI" + ;; default + char)) + +(defn normalize-name [ident] + (reduce str "" (map normalize-char ident))) + +(def +init-bindings+ + (T [;; "lux;counter" + 0 + ;; "lux;mappings" + (|table)])) + +(def +init-type-context+ + (T [;; ex-counter + 0 + ;; var-counter + 0 + ;; var-bindings + (|table)])) + +(defn env [name old-name] + (T [;; name + ($Cons name old-name) + ;; inner + 0 + ;; locals + +init-bindings+ + ;; captured + +init-bindings+] + )) + +(do-template [<tag> <host-desc> <host> <ask> <change> <with>] + (do (def <host> + (fn [compiler] + (|case (get$ $host compiler) + (<tag> host-data) + (return* compiler host-data) + + _ + ((fail-with-loc (str "[Error] Wrong host.\nExpected: " <host-desc>)) + compiler)))) + + (def <ask> + (fn [compiler] + (|case (get$ $host compiler) + (<tag> host-data) + (return* compiler true) + + _ + (return* compiler false)))) + + (defn <change> [slot updater] + (|do [host <host>] + (fn [compiler] + (return* (set$ $host (<tag> (update$ slot updater host)) compiler) + (get$ slot host))))) + + (defn <with> [slot updater body] + (|do [old-val (<change> slot updater) + ?output-val body + new-val (<change> slot (fn [_] old-val))] + (return ?output-val)))) + + $Jvm "JVM" jvm-host jvm? change-jvm-host-slot with-jvm-host-slot + $Js "JS" js-host js? change-js-host-slot with-js-host-slot + ) + +(do-template [<name> <slot>] + (def <name> + (|do [host jvm-host] + (return (get$ <slot> host)))) + + loader $loader + classes $classes + get-type-env $type-env + ) + +(def get-writer + (|do [host jvm-host] + (|case (get$ $writer host) + ($Some writer) + (return writer) + + _ + (fail-with-loc "[Error] Writer has not been set.")))) + +(defn with-writer [writer body] + (with-jvm-host-slot $writer (fn [_] ($Some writer)) body)) + +(defn with-type-env + "(All [a] (-> TypeEnv (Meta a) (Meta a)))" + [type-env body] + (with-jvm-host-slot $type-env (partial |++ type-env) body)) + +(defn push-dummy-name [real-name store-name] + (change-jvm-host-slot $dummy-mappings (partial $Cons (T [real-name store-name])))) + +(def pop-dummy-name + (change-jvm-host-slot $dummy-mappings |tail)) + +(defn de-alias-class [class-name] + (|do [host jvm-host] + (return (|case (|some #(|let [[real-name store-name] %] + (if (= real-name class-name) + ($Some store-name) + $None)) + (get$ $dummy-mappings host)) + ($Some store-name) + store-name + + _ + class-name)))) + +(defn default-info [target mode] + (T [;; target + target + ;; version + version + ;; mode + mode] + )) + +(defn init-state [name mode host-data] + (T [;; "lux;info" + (default-info name mode) + ;; "lux;source" + $Nil + ;; "lux;location" + (T ["" -1 -1]) + ;; "current-module" + $None + ;; "lux;modules" + (|table) + ;; "lux;scopes" + $Nil + ;; "lux;type-context" + +init-type-context+ + ;; "lux;expected" + $None + ;; "lux;seed" + 0 + ;; scope-type-vars + $Nil + ;; extensions + nil + ;; "lux;host" + host-data] + )) + +(defn save-module [body] + (fn [state] + (|case (body state) + ($Right state* output) + (return* (->> state* + (set$ $scopes (get$ $scopes state)) + (set$ $source (get$ $source state))) + output) + + ($Left msg) + (fail* msg)))) + +(do-template [<name> <tag>] + (defn <name> + "(-> CompilerMode Bit)" + [mode] + (|case mode + (<tag>) true + _ false)) + + in-eval? $Eval + in-repl? $REPL + ) + +(defn with-eval [body] + (fn [state] + (let [old-mode (->> state (get$ $info) (get$ $mode))] + (|case (body (update$ $info #(set$ $mode $Eval %) state)) + ($Right state* output) + (return* (update$ $info #(set$ $mode old-mode %) state*) output) + + ($Left msg) + (fail* msg))))) + +(def get-eval + (fn [state] + (return* state (->> state (get$ $info) (get$ $mode) in-eval?)))) + +(def get-mode + (fn [state] + (return* state (->> state (get$ $info) (get$ $mode))))) + +(def get-top-local-env + (fn [state] + (try (let [top (|head (get$ $scopes state))] + (return* state top)) + (catch Throwable _ + ((fail-with-loc "[Error] No local environment.") + state))))) + +(def gen-id + (fn [state] + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) + +(defn ->seq [xs] + (|case xs + ($Nil) + (list) + + ($Cons x xs*) + (cons x (->seq xs*)))) + +(defn ->list [seq] + (if (empty? seq) + $Nil + ($Cons (first seq) (->list (rest seq))))) + +(defn |repeat [n x] + (if (> n 0) + ($Cons x (|repeat (dec n) x)) + $Nil)) + +(def get-module-name + (fn [state] + (|case (get$ $current-module state) + ($None) + ((fail-with-loc "[Analyser Error] Cannot get the module-name without a module.") + state) + + ($Some module-name) + (return* state module-name)))) + +(defn find-module + "(-> Text (Meta (Module Lux)))" + [name] + (fn [state] + (if-let [module (|get name (get$ $modules state))] + (return* state module) + ((fail-with-loc (str "[Error] Unknown module: " name)) + state)))) + +(def ^{:doc "(Meta (Module Lux))"} + get-current-module + (|do [module-name get-module-name] + (find-module module-name))) + +(defn with-scope [name body] + (fn [state] + (let [old-name (->> state (get$ $scopes) |head (get$ $name)) + output (body (update$ $scopes #($Cons (env name old-name) %) state))] + (|case output + ($Right state* datum) + (return* (update$ $scopes |tail state*) datum) + + _ + output)))) + +(defn run-state [monad state] + (monad state)) + +(defn with-closure [body] + (|do [closure-name (|do [top get-top-local-env] + (return (->> top (get$ $inner) str)))] + (fn [state] + (let [body* (with-scope closure-name body)] + (run-state body* (update$ $scopes #($Cons (update$ $inner inc (|head %)) + (|tail %)) + state)))))) + +(let [!out! *out*] + (defn |log! [& parts] + (binding [*out* !out!] + (do (print (str (apply str parts) "\n")) + (flush))))) + +(defn |last [xs] + (|case xs + ($Cons x ($Nil)) + x + + ($Cons x xs*) + (|last xs*) + + _ + (assert false (adt->text xs)))) + +(def get-scope-name + (fn [state] + (return* state (->> state (get$ $scopes) |head (get$ $name))))) + +(defn without-repl-closure [body] + (|do [_mode get-mode + current-scope get-scope-name] + (fn [state] + (let [output (body (if (and (in-repl? _mode) + (->> current-scope |last (= "REPL"))) + (update$ $scopes |tail state) + state))] + (|case output + ($Right state* datum) + (return* (set$ $scopes (get$ $scopes state) state*) datum) + + _ + output))))) + +(defn without-repl [body] + (|do [_mode get-mode] + (fn [state] + (let [output (body (if (in-repl? _mode) + (update$ $info #(set$ $mode $Build %) state) + state))] + (|case output + ($Right state* datum) + (return* (update$ $info #(set$ $mode _mode %) state*) datum) + + _ + output))))) + +(defn with-expected-type + "(All [a] (-> Type (Meta a)))" + [type body] + (fn [state] + (let [output (body (set$ $expected ($Some type) state))] + (|case output + ($Right ?state ?value) + (return* (set$ $expected (get$ $expected state) ?state) + ?value) + + _ + output)))) + +(defn with-location + "(All [a] (-> Location (Meta a)))" + [^objects location body] + (|let [[_file-name _ _] location] + (if (= "" _file-name) + body + (fn [state] + (let [output (body (set$ $location location state))] + (|case output + ($Right ?state ?value) + (return* (set$ $location (get$ $location state) ?state) + ?value) + + _ + output)))))) + +(defn with-analysis-meta + "(All [a] (-> Location Type (Meta a)))" + [^objects location type body] + (|let [[_file-name _ _] location] + (if (= "" _file-name) + (fn [state] + (let [output (body (->> state + (set$ $expected ($Some type))))] + (|case output + ($Right ?state ?value) + (return* (->> ?state + (set$ $expected (get$ $expected state))) + ?value) + + _ + output))) + (fn [state] + (let [output (body (->> state + (set$ $location location) + (set$ $expected ($Some type))))] + (|case output + ($Right ?state ?value) + (return* (->> ?state + (set$ $location (get$ $location state)) + (set$ $expected (get$ $expected state))) + ?value) + + _ + output)))))) + +(def ^{:doc "(Meta Any)"} + ensure-directive + (fn [state] + (|case (get$ $expected state) + ($None) + (return* state unit-tag) + + ($Some _) + ((fail-with-loc "[Error] All directives must be top-level forms.") + state)))) + +(def location + ;; (Meta Location) + (fn [state] + (return* state (get$ $location state)))) + +(def rev-bits 64) + +(let [clean-separators (fn [^String input] + (.replaceAll input "_" "")) + rev-text-to-digits (fn [^String input] + (loop [output (vec (repeat rev-bits 0)) + index (dec (.length input))] + (if (>= index 0) + (let [digit (Byte/parseByte (.substring input index (inc index)))] + (recur (assoc output index digit) + (dec index))) + output))) + times5 (fn [index digits] + (loop [index index + carry 0 + digits digits] + (if (>= index 0) + (let [raw (->> (get digits index) (* 5) (+ carry))] + (recur (dec index) + (int (/ raw 10)) + (assoc digits index (rem raw 10)))) + digits))) + rev-digit-power (fn [level] + (loop [output (-> (vec (repeat rev-bits 0)) + (assoc level 1)) + times level] + (if (>= times 0) + (recur (times5 level output) + (dec times)) + output))) + rev-digits-lt (fn rev-digits-lt + ([subject param index] + (and (< index rev-bits) + (or (< (get subject index) + (get param index)) + (and (= (get subject index) + (get param index)) + (rev-digits-lt subject param (inc index)))))) + ([subject param] + (rev-digits-lt subject param 0))) + rev-digits-sub-once (fn [subject param-digit index] + (if (>= (get subject index) + param-digit) + (update-in subject [index] #(- % param-digit)) + (recur (update-in subject [index] #(- 10 (- param-digit %))) + 1 + (dec index)))) + rev-digits-sub (fn [subject param] + (loop [target subject + index (dec rev-bits)] + (if (>= index 0) + (recur (rev-digits-sub-once target (get param index) index) + (dec index)) + target))) + rev-digits-to-text (fn [digits] + (loop [output "" + index (dec rev-bits)] + (if (>= index 0) + (recur (-> (get digits index) + (Character/forDigit 10) + (str output)) + (dec index)) + output))) + add-rev-digit-powers (fn [dl dr] + (loop [index (dec rev-bits) + output (vec (repeat rev-bits 0)) + carry 0] + (if (>= index 0) + (let [raw (+ carry + (get dl index) + (get dr index))] + (recur (dec index) + (assoc output index (rem raw 10)) + (int (/ raw 10)))) + output)))] + ;; Based on the LuxRT.encode_rev method + (defn encode-rev [input] + (if (= 0 input) + ".0" + (loop [index (dec rev-bits) + output (vec (repeat rev-bits 0))] + (if (>= index 0) + (recur (dec index) + (if (bit-test input index) + (->> (- (dec rev-bits) index) + rev-digit-power + (add-rev-digit-powers output)) + output)) + (-> output rev-digits-to-text + (->> (str ".")) + (.split "0*$") + (aget 0)))))) + + ;; Based on the LuxRT.decode_rev method + (defn decode-rev [^String input] + (if (and (.startsWith input ".") + (<= (.length input) (inc rev-bits))) + (loop [digits-left (-> input + (.substring 1) + clean-separators + rev-text-to-digits) + index 0 + ouput 0] + (if (< index rev-bits) + (let [power-slice (rev-digit-power index)] + (if (not (rev-digits-lt digits-left power-slice)) + (recur (rev-digits-sub digits-left power-slice) + (inc index) + (bit-set ouput (- (dec rev-bits) index))) + (recur digits-left + (inc index) + ouput))) + ouput)) + (throw (new java.lang.Exception (str "Bad format for Rev number: " input))))) + ) + +(defn show-ast [ast] + (|case ast + [_ ($Bit ?value)] + (pr-str ?value) + + [_ ($Nat ?value)] + (Long/toUnsignedString ?value) + + [_ ($Int ?value)] + (if (< ?value 0) + (pr-str ?value) + (str "+" (pr-str ?value))) + + [_ ($Rev ?value)] + (encode-rev ?value) + + [_ ($Frac ?value)] + (pr-str ?value) + + [_ ($Text ?value)] + (str "\"" ?value "\"") + + [_ ($Tag ?module ?tag)] + (if (.equals "" ?module) + (str "#" ?tag) + (str "#" ?module +name-separator+ ?tag)) + + [_ ($Identifier ?module ?name)] + (if (.equals "" ?module) + ?name + (str ?module +name-separator+ ?name)) + + [_ ($Tuple ?elems)] + (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") + + [_ ($Record ?elems)] + (str "{" (->> ?elems + (|map (fn [elem] + (|let [[k v] elem] + (str (show-ast k) " " (show-ast v))))) + (|interpose " ") (fold str "")) "}") + + [_ ($Form ?elems)] + (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") + + _ + (assert false (prn-str 'show-ast (adt->text ast))) + )) + +(defn ident->text [ident] + (|let [[?module ?name] ident] + (if (= "" ?module) + ?name + (str ?module +name-separator+ ?name)))) + +(defn fold2% [f init xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (|do [init* (f init x y)] + (fold2% f init* xs* ys*)) + + [($Nil) ($Nil)] + (return init) + + [_ _] + (assert false "Lists do not match in size."))) + +(defn map2% [f xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (|do [z (f x y) + zs (map2% f xs* ys*)] + (return ($Cons z zs))) + + [($Nil) ($Nil)] + (return $Nil) + + [_ _] + (assert false "Lists do not match in size."))) + +(defn map2 [f xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + ($Cons (f x y) (map2 f xs* ys*)) + + [_ _] + $Nil)) + +(defn fold2 [f init xs ys] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] + (and init + (fold2 f (f init x y) xs* ys*)) + + [($Nil) ($Nil)] + init + + [_ _] + init + ;; (assert false) + )) + +(defn ^:private enumerate* + "(All [a] (-> Int (List a) (List (, Int a))))" + [idx xs] + (|case xs + ($Cons x xs*) + ($Cons (T [idx x]) + (enumerate* (inc idx) xs*)) + + ($Nil) + xs + )) + +(defn enumerate + "(All [a] (-> (List a) (List (, Int a))))" + [xs] + (enumerate* 0 xs)) + +(def ^{:doc "(Meta (List Text))"} + modules + (fn [state] + (return* state (|keys (get$ $modules state))))) + +(defn when% + "(-> Bit (Meta Any) (Meta Any))" + [test body] + (if test + body + (return unit-tag))) + +(defn |at + "(All [a] (-> Int (List a) (Maybe a)))" + [idx xs] + (|case xs + ($Cons x xs*) + (cond (< idx 0) + $None + + (= idx 0) + ($Some x) + + :else ;; > 1 + (|at (dec idx) xs*)) + + ($Nil) + $None)) + +(defn normalize + "(-> Ident (Meta Ident))" + [ident] + (|case ident + ["" name] (|do [module get-module-name] + (return (T [module name]))) + _ (return ident))) + +(defn ident= [x y] + (|let [[xmodule xname] x + [ymodule yname] y] + (and (= xmodule ymodule) + (= xname yname)))) + +(defn |list-put [idx val xs] + (|case xs + ($Nil) + $None + + ($Cons x xs*) + (if (= idx 0) + ($Some ($Cons val xs*)) + (|case (|list-put (dec idx) val xs*) + ($None) $None + ($Some xs**) ($Some ($Cons x xs**))) + ))) + +(do-template [<name> <default> <op>] + (defn <name> + "(All [a] (-> (-> a Bit) (List a) Bit))" + [p xs] + (|case xs + ($Nil) + <default> + + ($Cons x xs*) + (<op> (p x) (<name> p xs*)))) + + |every? true and + |any? false or) + +(defn m-comp + "(All [a b c] (-> (-> b (Meta c)) (-> a (Meta b)) (-> a (Meta c))))" + [f g] + (fn [x] + (|do [y (g x)] + (f y)))) + +(defn with-attempt + "(All [a] (-> (Meta a) (-> Text (Meta a)) (Meta a)))" + [m-value on-error] + (fn [state] + (|case (m-value state) + ($Left msg) + ((on-error msg) state) + + output + output))) + +(defn |take [n xs] + (|case (T [n xs]) + [0 _] $Nil + [_ ($Nil)] $Nil + [_ ($Cons x xs*)] ($Cons x (|take (dec n) xs*)) + )) + +(defn |drop [n xs] + (|case (T [n xs]) + [0 _] xs + [_ ($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)))) + +(defn |partition [n xs] + (->> xs ->seq (partition-all n) (map ->list) ->list)) + +(defn with-scope-type-var [id body] + (fn [state] + (|case (body (set$ $scope-type-vars + ($Cons id (get$ $scope-type-vars state)) + state)) + ($Right [state* output]) + ($Right (T [(set$ $scope-type-vars + (get$ $scope-type-vars state) + state*) + output])) + + ($Left msg) + ($Left msg)))) + +(defn with-module [name body] + (fn [state] + (|case (body (set$ $current-module ($Some name) state)) + ($Right [state* output]) + ($Right (T [(set$ $current-module (get$ $current-module state) state*) + output])) + + ($Left msg) + ($Left msg)))) + +(defn |eitherL [left right] + (fn [compiler] + (|case (run-state left compiler) + ($Left _error) + (run-state right compiler) + + _output + _output))) + +(defn timed% [what when operation] + (fn [state] + (let [pre (System/currentTimeMillis)] + (|case (operation state) + ($Right state* output) + (let [post (System/currentTimeMillis) + duration (- post pre) + _ (|log! (str what " [" when "]: +" duration "ms"))] + ($Right (T [state* output]))) + + ($Left ^String msg) + (fail* msg))))) diff --git a/lux-bootstrapper/src/lux/compiler.clj b/lux-bootstrapper/src/lux/compiler.clj new file mode 100644 index 000000000..a3e60e463 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler.clj @@ -0,0 +1,29 @@ +(ns lux.compiler + (:refer-clojure :exclude [compile]) + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case]]) + (lux.compiler [core :as &&core] + [io :as &&io] + [parallel :as &¶llel] + [jvm :as &&jvm]))) + +(defn init! [dependencies ^String target-dir] + (do (reset! &&core/!output-dir target-dir) + (&¶llel/setup!) + (&&io/init-libs! dependencies) + (.mkdirs (new java.io.File target-dir)) + (&&jvm/init!))) + +(def all-compilers + &&jvm/all-compilers) + +(defn eval! [expr] + (&&jvm/eval! expr)) + +(defn compile-module [source-dirs name] + (&&jvm/compile-module source-dirs name)) + +(defn compile-program [mode program-module dependencies source-dirs target-dir] + (init! dependencies target-dir) + (&&jvm/compile-program mode program-module source-dirs)) diff --git a/lux-bootstrapper/src/lux/compiler/cache.clj b/lux-bootstrapper/src/lux/compiler/cache.clj new file mode 100644 index 000000000..01e05c8de --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/cache.clj @@ -0,0 +1,244 @@ +(ns lux.compiler.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |case |let]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module]) + (lux.compiler [core :as &&core] + [io :as &&io]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) + (:import (java.io File) + )) + +;; [Resources] +(defn ^:private delete-all-module-files [^File file] + (doseq [^File f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) + +(defn ^:private ^String module-path [module] + (str @&&core/!output-dir + java.io.File/separator + (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) + +(defn cached? + "(-> Text Bit)" + [module] + (.exists (new File (str (module-path module) java.io.File/separator &&core/lux-module-descriptor-name)))) + +(defn delete + "(-> Text (Lux Null))" + [module] + (fn [state] + (do (delete-all-module-files (new File (module-path module))) + (return* state nil)))) + +(defn ^:private module-dirs + "(-> File (clojure.Seq File))" + [^File module] + (->> module + .listFiles + (filter #(.isDirectory ^File %)) + (map module-dirs) + (apply concat) + (list* module))) + +(defn clean + "(-> Lux Null)" + [state] + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) + output-dir-prefix (str (.getAbsolutePath (new File ^String @&&core/!output-dir)) java.io.File/separator) + outdated? #(->> % (contains? needed-modules) not) + outdated-modules (->> (new File ^String @&&core/!output-dir) + .listFiles (filter #(.isDirectory ^File %)) + (map module-dirs) doall (apply concat) + (map (fn [^File dir-file] + (let [^String dir-module (-> dir-file + .getAbsolutePath + (string/replace output-dir-prefix "")) + corrected-dir-module (.replace dir-module java.io.File/separator "/")] + corrected-dir-module))) + (filter outdated?))] + (doseq [^String f outdated-modules] + (delete-all-module-files (new File (str output-dir-prefix f)))) + nil)) + +(defn ^:private parse-tag-groups [^String tags-section] + (if (= "" tags-section) + &/$Nil + (-> tags-section + (.split &&core/entry-separator) + seq + (->> (map (fn [^String _group] + (let [[_type & _tags] (.split _group &&core/datum-separator)] + (&/T [_type (->> _tags seq &/->list)]))))) + &/->list))) + +(defn ^:private process-tag-group [module group] + (|let [[_type _tags] group] + (|do [[was-exported? =type] (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags was-exported? =type)))) + +(defn make-tag [ident] + (&/T [(&/T ["" 0 0]) (&/$Tag ident)])) + +(defn make-identifier [ident] + (&/T [(&/T ["" 0 0]) (&/$Identifier ident)])) + +(defn make-record [ident] + (&/T [(&/T ["" 0 0]) (&/$Record ident)])) + +(defn ^:private process-def-entry [load-def-value module ^String _def-entry] + (let [parts (.split _def-entry &&core/datum-separator)] + (case (alength parts) + 2 (let [[_name ^String _alias] parts + [__module __name] (.split _alias &/+name-separator+)] + (&a-module/define-alias module _name (&/T [__module __name]))) + 4 (let [[_name _exported? _type _anns] parts + [def-anns _] (&&&ann/deserialize _anns) + [def-type _] (&&&type/deserialize-type _type)] + (|do [def-value (load-def-value module _name)] + (&a-module/define module _name (= "1" _exported?) def-type def-anns def-value)))))) + +(defn ^:private uninstall-cache [module] + (|do [_ (delete module)] + (return false))) + +(defn ^:private install-module [load-def-value module module-hash imports tag-groups ?module-anns def-entries] + (|do [_ (&a-module/create-module module module-hash) + _ (&a-module/flag-cached-module module) + _ (|case ?module-anns + (&/$Some module-anns) + (&a-module/set-anns module-anns module) + + (&/$None _) + (return nil)) + _ (&a-module/set-imports imports) + _ (&/map% (partial process-def-entry load-def-value module) + def-entries) + _ (&/map% (partial process-tag-group module) tag-groups)] + (return nil))) + +(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash + _imports-section _tags-section _module-anns-section _defs-section + load-def-value install-all-defs-in-module uninstall-all-defs-in-module] + (|do [^String descriptor (&&core/read-module-descriptor! module-name) + :let [imports (let [imports (vec (.split ^String _imports-section &&core/entry-separator)) + imports (if (= [""] imports) + &/$Nil + (&/->list imports))] + (&/|map #(first (vec (.split ^String % &&core/datum-separator 2))) imports))] + cache-table* (&/fold% (fn [cache-table* _module] + (|do [[file-name file-content] (&&io/read-file source-dirs _module) + output (pre-load! source-dirs cache-table* _module (hash file-content) + load-def-value install-all-defs-in-module uninstall-all-defs-in-module)] + (return output))) + cache-table + imports)] + (if (&/|every? (fn [_module] (contains? cache-table* _module)) + imports) + (let [tag-groups (parse-tag-groups _tags-section) + [?module-anns _] (if (= "..." _module-anns-section) + [&/$None nil] + (let [[module-anns _] (&&&ann/deserialize _module-anns-section)] + [(&/$Some module-anns) _])) + def-entries (let [def-entries (vec (.split ^String _defs-section &&core/entry-separator))] + (if (= [""] def-entries) + &/$Nil + (&/->list def-entries)))] + (|do [_ (install-all-defs-in-module module-name) + _ (install-module load-def-value module-name module-hash + imports tag-groups ?module-anns def-entries) + =module (&/find-module module-name)] + (return (&/T [true (assoc cache-table* module-name =module)])))) + (return (&/T [false cache-table*]))))) + +(defn ^:private enumerate-cached-modules!* [^File parent] + (if (.isDirectory parent) + (let [children (for [^File child (seq (.listFiles parent)) + entry (enumerate-cached-modules!* child)] + entry)] + (if (.exists (new File parent &&core/lux-module-descriptor-name)) + (list* (.getAbsolutePath parent) + children) + children)) + (list))) + +(defn ^:private enumerate-cached-modules! [] + (let [output-dir (new File ^String @&&core/!output-dir) + prefix-to-subtract (inc (.length (.getAbsolutePath output-dir)))] + (->> output-dir + enumerate-cached-modules!* + rest + (map #(-> ^String % + (.replace java.io.File/separator "/") + (.substring prefix-to-subtract))) + &/->list))) + +(defn ^:private pre-load! [source-dirs cache-table module-name module-hash + load-def-value install-all-defs-in-module uninstall-all-defs-in-module] + (cond (contains? cache-table module-name) + (return cache-table) + + (not (cached? module-name)) + (return cache-table) + + :else + (|do [^String descriptor (&&core/read-module-descriptor! module-name) + :let [[_compiler _hash _imports-section _tags-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator) + drop-cache! (|do [_ (uninstall-cache module-name) + _ (uninstall-all-defs-in-module module-name)] + (return cache-table))]] + (if (and (= module-hash (Long/parseUnsignedLong ^String _hash)) + (= &/version _compiler)) + (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module-name module-hash + _imports-section _tags-section _module-anns-section _defs-section + load-def-value install-all-defs-in-module uninstall-all-defs-in-module) + _ (if success? + (return nil) + drop-cache!)] + (return cache-table*)) + drop-cache!)))) + +(def ^:private !pre-loaded-cache (atom nil)) +(defn pre-load-cache! [source-dirs + load-def-value install-all-defs-in-module uninstall-all-defs-in-module] + (|do [:let [fs-cached-modules (enumerate-cached-modules!)] + pre-loaded-modules (&/fold% (fn [cache-table module-name] + (fn [_compiler] + (|case ((&&io/read-file source-dirs module-name) + _compiler) + (&/$Left error) + (return* _compiler cache-table) + + (&/$Right _compiler* [file-name file-content]) + ((pre-load! source-dirs cache-table module-name (hash file-content) + load-def-value install-all-defs-in-module uninstall-all-defs-in-module) + _compiler*)))) + {} + fs-cached-modules) + :let [_ (reset! !pre-loaded-cache pre-loaded-modules)]] + (return nil))) + +(defn ^:private inject-module + "(-> Module Lux (Lux Null))" + [module-name module] + (fn [compiler] + (return* (&/update$ &/$modules + #(&/|put module-name module %) + compiler) + nil))) + +(defn load + "(-> Text (Lux Null))" + [module-name] + (if-let [module-struct (get @!pre-loaded-cache module-name)] + (|do [_ (inject-module module-name module-struct)] + (return nil)) + (&/fail (str "[Cache Error] Module is not cached: " module-name)))) diff --git a/lux-bootstrapper/src/lux/compiler/cache/ann.clj b/lux-bootstrapper/src/lux/compiler/cache/ann.clj new file mode 100644 index 000000000..4c08af276 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/cache/ann.clj @@ -0,0 +1,138 @@ +(ns lux.compiler.cache.ann + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case]]))) + +(def ^:private stop (->> 7 char str)) +(def ^:private cons-signal (->> 5 char str)) +(def ^:private nil-signal (->> 6 char str)) + +(defn ^:private serialize-seq [serialize params] + (str (&/fold (fn [so-far param] + (str so-far cons-signal (serialize param))) + "" + params) + nil-signal)) + +(defn ^:private serialize-ident [ident] + (|let [[module name] ident] + (str module &/+name-separator+ name))) + +(defn serialize + "(-> Code Text)" + [ann] + (|case ann + [_ (&/$Bit value)] + (str "B" value stop) + + [_ (&/$Nat value)] + (str "N" value stop) + + [_ (&/$Int value)] + (str "I" value stop) + + [_ (&/$Rev value)] + (str "D" value stop) + + [_ (&/$Frac value)] + (str "F" value stop) + + [_ (&/$Text value)] + (str "T" value stop) + + [_ (&/$Identifier ident)] + (str "@" (serialize-ident ident) stop) + + [_ (&/$Tag ident)] + (str "#" (serialize-ident ident) stop) + + [_ (&/$Form elems)] + (str "(" (serialize-seq serialize elems)) + + [_ (&/$Tuple elems)] + (str "[" (serialize-seq serialize elems)) + + [_ (&/$Record kvs)] + (str "{" (serialize-seq (fn [kv] + (|let [[k v] kv] + (str (serialize k) + (serialize v)))) + kvs)) + + _ + (assert false) + )) + +(declare deserialize) + +(def dummy-location + (&/T ["" 0 0])) + +(do-template [<name> <signal> <ctor> <parser>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (let [[value* ^String input*] (.split (.substring input 1) stop 2)] + [(&/T [dummy-location (<ctor> (<parser> value*))]) input*]))) + + ^:private deserialize-bit "B" &/$Bit Boolean/parseBoolean + ^:private deserialize-nat "N" &/$Nat Long/parseLong + ^:private deserialize-int "I" &/$Int Long/parseLong + ^:private deserialize-rev "D" &/$Rev Long/parseLong + ^:private deserialize-frac "F" &/$Frac Double/parseDouble + ^:private deserialize-text "T" &/$Text identity + ) + +(do-template [<name> <marker> <tag>] + (defn <name> [^String input] + (when (.startsWith input <marker>) + (let [[^String ident* ^String input*] (.split (.substring input 1) stop 2) + [_module _name] (.split ident* "\\." 2)] + [(&/T [dummy-location (<tag> (&/T [_module _name]))]) input*]))) + + ^:private deserialize-identifier "@" &/$Identifier + ^:private deserialize-tag "#" &/$Tag) + +(defn ^:private deserialize-seq [deserializer ^String input] + (cond (.startsWith input nil-signal) + [&/$Nil (.substring input 1)] + + (.startsWith input cons-signal) + (when-let [[head ^String input*] (deserializer (.substring input 1))] + (when-let [[tail ^String input*] (deserialize-seq deserializer input*)] + [(&/$Cons head tail) input*])) + )) + +(defn ^:private deserialize-kv [input] + (when-let [[key input*] (deserialize input)] + (when-let [[ann input*] (deserialize input*)] + [(&/T [key ann]) input*]))) + +(do-template [<name> <signal> <type> <deserializer>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[elems ^String input*] (deserialize-seq <deserializer> + (.substring input 1))] + [(&/T [dummy-location (<type> elems)]) input*]))) + + ^:private deserialize-form "(" &/$Form deserialize + ^:private deserialize-tuple "[" &/$Tuple deserialize + ^:private deserialize-record "{" &/$Record deserialize-kv + ) + +(defn deserialize + "(-> Text V[Code Text])" + [input] + (or (deserialize-bit input) + (deserialize-nat input) + (deserialize-int input) + (deserialize-rev input) + (deserialize-frac input) + (deserialize-text input) + (deserialize-identifier input) + (deserialize-tag input) + (deserialize-form input) + (deserialize-tuple input) + (deserialize-record input) + (assert false "[Cache Error] Cannot deserialize annocation."))) diff --git a/lux-bootstrapper/src/lux/compiler/cache/type.clj b/lux-bootstrapper/src/lux/compiler/cache/type.clj new file mode 100644 index 000000000..7c622d2c4 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/cache/type.clj @@ -0,0 +1,143 @@ +(ns lux.compiler.cache.type + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case]] + [type :as &type]))) + +(def ^:private stop (->> 7 char str)) +(def ^:private cons-signal (->> 5 char str)) +(def ^:private nil-signal (->> 6 char str)) + +(defn ^:private serialize-list [serialize-type params] + (str (&/fold (fn [so-far param] + (str so-far cons-signal (serialize-type param))) + "" + params) + nil-signal)) + +(defn serialize-type + "(-> Type Text)" + [type] + (if (&type/type= &type/Type type) + "T" + (|case type + (&/$Primitive name params) + (str "^" name stop (serialize-list serialize-type params)) + + (&/$Product left right) + (str "*" (serialize-type left) (serialize-type right)) + + (&/$Sum left right) + (str "+" (serialize-type left) (serialize-type right)) + + (&/$Function left right) + (str ">" (serialize-type left) (serialize-type right)) + + (&/$UnivQ env body) + (str "U" (serialize-list serialize-type env) (serialize-type body)) + + (&/$ExQ env body) + (str "E" (serialize-list serialize-type env) (serialize-type body)) + + (&/$Parameter idx) + (str "$" idx stop) + + (&/$Ex idx) + (str "!" idx stop) + + (&/$Var idx) + (str "?" idx stop) + + (&/$Apply left right) + (str "%" (serialize-type left) (serialize-type right)) + + (&/$Named [module name] type*) + (str "@" module &/+name-separator+ name stop (serialize-type type*)) + + _ + (assert false (prn 'serialize-type (&type/show-type type))) + ))) + +(declare deserialize-type) + +(defn ^:private deserialize-list [^String input] + (cond (.startsWith input nil-signal) + [&/$Nil (.substring input 1)] + + (.startsWith input cons-signal) + (when-let [[head ^String input*] (deserialize-type (.substring input 1))] + (when-let [[tail ^String input*] (deserialize-list input*)] + [(&/$Cons head tail) input*])) + )) + +(defn ^:private deserialize-type* [^String input] + (when (.startsWith input "T") + [&type/Type (.substring input 1)])) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[left ^String input*] (deserialize-type (.substring input 1))] + (when-let [[right ^String input*] (deserialize-type input*)] + [(<type> left right) input*])) + )) + + ^:private deserialize-sum "+" &/$Sum + ^:private deserialize-prod "*" &/$Product + ^:private deserialize-lambda ">" &/$Function + ^:private deserialize-app "%" &/$Apply + ) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (let [[idx ^String input*] (.split (.substring input 1) stop 2)] + [(<type> (Long/parseLong idx)) input*]))) + + ^:private deserialize-parameter "$" &/$Parameter + ^:private deserialize-ex "!" &/$Ex + ^:private deserialize-var "?" &/$Var + ) + +(defn ^:private deserialize-named [^String input] + (when (.startsWith input "@") + (let [[^String module+name ^String input*] (.split (.substring input 1) stop 2) + [module name] (.split module+name "\\." 2)] + (when-let [[type* ^String input*] (deserialize-type input*)] + [(&/$Named (&/T [module name]) type*) input*])))) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[env ^String input*] (deserialize-list (.substring input 1))] + (when-let [[body ^String input*] (deserialize-type input*)] + [(<type> env body) input*])))) + + ^:private deserialize-univq "U" &/$UnivQ + ^:private deserialize-exq "E" &/$ExQ + ) + +(defn ^:private deserialize-host [^String input] + (when (.startsWith input "^") + (let [[name ^String input*] (.split (.substring input 1) stop 2)] + (when-let [[params ^String input*] (deserialize-list input*)] + [(&/$Primitive name params) input*])))) + +(defn deserialize-type + "(-> Text Type)" + [input] + (or (deserialize-type* input) + (deserialize-sum input) + (deserialize-prod input) + (deserialize-lambda input) + (deserialize-app input) + (deserialize-parameter input) + (deserialize-ex input) + (deserialize-var input) + (deserialize-named input) + (deserialize-univq input) + (deserialize-exq input) + (deserialize-host input) + (assert false (str "[Cache error] Cannot deserialize type. --- " input)))) diff --git a/lux-bootstrapper/src/lux/compiler/core.clj b/lux-bootstrapper/src/lux/compiler/core.clj new file mode 100644 index 000000000..88da626bd --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/core.clj @@ -0,0 +1,93 @@ +(ns lux.compiler.core + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.java.io :as io] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|case |let |do return* return fail*]]) + (lux.analyser [base :as &a] + [module :as &a-module]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) + (:import (java.io File + BufferedOutputStream + FileOutputStream))) + +;; [Constants] +(def !output-dir (atom nil)) + +(def ^:const section-separator (->> 29 char str)) +(def ^:const datum-separator (->> 31 char str)) +(def ^:const entry-separator (->> 30 char str)) + +;; [Utils] +(defn write-file [^String file-name ^bytes data] + (do (assert (not (.exists (File. file-name))) (str "Cannot overwrite file: " file-name)) + (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] + (.write stream data) + (.flush stream)))) + +;; [Exports] +(def ^String lux-module-descriptor-name "lux_module_descriptor") + +(defn write-module-descriptor! [^String name ^String descriptor] + (|do [_ (return nil) + :let [lmd-dir (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator)) + _ (.mkdirs (File. lmd-dir)) + _ (write-file (str lmd-dir java.io.File/separator lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]] + (return nil))) + +(defn read-module-descriptor! [^String name] + (|do [_ (return nil)] + (return (slurp (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator) java.io.File/separator lux-module-descriptor-name) + :encoding "UTF-8")))) + +(defn generate-module-descriptor [file-hash] + (|do [module-name &/get-module-name + ?module-anns (&a-module/get-anns module-name) + defs &a-module/defs + imports &a-module/imports + tag-groups &a-module/tag-groups + :let [def-entries (->> defs + (&/|map (fn [_def] + (|let [[?name _definition] _def] + (|case _definition + (&/$Left [_dmodule _dname]) + (str ?name datum-separator _dmodule &/+name-separator+ _dname) + + (&/$Right [exported? ?def-type ?def-anns ?def-value]) + (str ?name + datum-separator (if exported? "1" "0") + datum-separator (&&&type/serialize-type ?def-type) + datum-separator (&&&ann/serialize ?def-anns)))))) + (&/|interpose entry-separator) + (&/fold str "")) + import-entries (->> imports + (&/|map (fn [import] + (|let [[_module _hash] import] + (str _module datum-separator _hash)))) + (&/|interpose entry-separator) + (&/fold str "")) + tag-entries (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags + (&/|interpose datum-separator) + (&/fold str "") + (str type datum-separator))))) + (&/|interpose entry-separator) + (&/fold str "")) + module-descriptor (->> (&/|list &/version + (Long/toUnsignedString file-hash) + import-entries + tag-entries + (|case ?module-anns + (&/$Some module-anns) + (&&&ann/serialize module-anns) + + (&/$None _) + "...") + def-entries) + (&/|interpose section-separator) + (&/fold str ""))]] + (return module-descriptor))) diff --git a/lux-bootstrapper/src/lux/compiler/io.clj b/lux-bootstrapper/src/lux/compiler/io.clj new file mode 100644 index 000000000..d3658edd3 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/io.clj @@ -0,0 +1,36 @@ +(ns lux.compiler.io + (:require (lux [base :as & :refer [|case |let |do return* return fail*]]) + (lux.compiler.jvm [base :as &&]) + [lux.lib.loader :as &lib])) + +;; [Utils] +(def ^:private !libs (atom nil)) + +;; [Resources] +(defn init-libs! [dependencies] + (reset! !libs (&lib/load dependencies))) + +(defn read-file [source-dirs module-name] + (let [^String host-file-name (str module-name ".old.lux") + ^String lux-file-name (str module-name ".lux")] + (|case (&/|some (fn [^String source-dir] + (let [host-file (new java.io.File source-dir host-file-name) + lux-file (new java.io.File source-dir lux-file-name)] + (cond (.exists host-file) + (&/$Some (&/T [host-file-name host-file])) + + (.exists lux-file) + (&/$Some (&/T [lux-file-name lux-file])) + + :else + &/$None))) + source-dirs) + (&/$Some [file-name file]) + (return (&/T [file-name (slurp file)])) + + (&/$None) + (if-let [code (get @!libs host-file-name)] + (return (&/T [host-file-name code])) + (if-let [code (get @!libs lux-file-name)] + (return (&/T [lux-file-name code])) + (&/fail-with-loc (str "[I/O Error] Module does not exist: " module-name))))))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm.clj b/lux-bootstrapper/src/lux/compiler/jvm.clj new file mode 100644 index 000000000..07c28dfac --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm.clj @@ -0,0 +1,256 @@ +(ns lux.compiler.jvm + (:refer-clojure :exclude [compile]) + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case]] + [type :as &type] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &optimizer] + [host :as &host]) + [lux.host.generics :as &host-generics] + [lux.optimizer :as &o] + [lux.analyser.base :as &a] + [lux.analyser.module :as &a-module] + (lux.compiler [core :as &&core] + [io :as &&io] + [cache :as &&cache] + [parallel :as &¶llel]) + (lux.compiler.jvm [base :as &&] + [lux :as &&lux] + [case :as &&case] + [function :as &&function] + [rt :as &&rt] + [cache :as &&jvm-cache]) + (lux.compiler.jvm.proc [common :as &&proc-common] + [host :as &&proc-host])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Resources] +(def ^:private !source->last-line (atom nil)) + +(defn ^:private compile-expression [$begin syntax] + (|let [[[?type [_file-name _line _]] ?form] syntax] + (|do [^MethodVisitor *writer* &/get-writer + :let [debug-label (new Label) + _ (when (not= _line (get @!source->last-line _file-name)) + (doto *writer* + (.visitLabel debug-label) + (.visitLineNumber (int _line) debug-label)) + (swap! !source->last-line assoc _file-name _line))]] + (|case ?form + (&o/$bit ?value) + (&&lux/compile-bit ?value) + + (&o/$nat ?value) + (&&lux/compile-nat ?value) + + (&o/$int ?value) + (&&lux/compile-int ?value) + + (&o/$rev ?value) + (&&lux/compile-rev ?value) + + (&o/$frac ?value) + (&&lux/compile-frac ?value) + + (&o/$text ?value) + (&&lux/compile-text ?value) + + (&o/$tuple ?elems) + (&&lux/compile-tuple (partial compile-expression $begin) ?elems) + + (&o/$var (&/$Local ?idx)) + (&&lux/compile-local (partial compile-expression $begin) ?idx) + + (&o/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source) + + (&o/$def ?owner-class ?name) + (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name) + + (&o/$apply ?fn ?args) + (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args) + + (&o/$loop _register-offset _inits _body) + (&&lux/compile-loop compile-expression _register-offset _inits _body) + + (&o/$iter _register-offset ?args) + (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args) + + (&o/$variant ?tag ?tail ?members) + (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members) + + (&o/$case ?value [?pm ?bodies]) + (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies) + + (&o/$let _value _register _body) + (&&lux/compile-let (partial compile-expression $begin) _value _register _body) + + (&o/$record-get _value _path) + (&&lux/compile-record-get (partial compile-expression $begin) _value _path) + + (&o/$if _test _then _else) + (&&lux/compile-if (partial compile-expression $begin) _test _then _else) + + (&o/$function _register-offset ?arity ?scope ?env ?body) + (&&function/compile-function compile-expression &/$None ?arity ?scope ?env ?body) + + (&o/$ann ?value-ex ?type-ex) + (compile-expression $begin ?value-ex) + + (&o/$proc [?proc-category ?proc-name] ?args special-args) + (if (= "jvm" ?proc-category) + (&&proc-host/compile-proc (partial compile-expression $begin) ?proc-name ?args special-args) + (&&proc-common/compile-proc (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args)) + + _ + (assert false (prn-str 'compile-expression (&/adt->text syntax))) + )) + )) + +(defn init! + "(-> Null)" + [] + (reset! !source->last-line {})) + +(defn eval! [expr] + (&/with-eval + (|do [module &/get-module-name + id &/gen-id + [file-name _ _] &/location + :let [class-name (str (&host/->module-class module) "/" id) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + class-name nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/value-field "Ljava/lang/Object;" nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitCode *writer*)] + _ (compile-expression nil expr) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/value-field "Ljava/lang/Object;") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [bytecode (.toByteArray (doto =class + .visitEnd))] + _ (&&/save-class! (str id) bytecode) + loader &/loader] + (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) + (.getField &/value-field) + (.get nil) + return)))) + +(def all-compilers + (let [compile-expression* (partial compile-expression nil)] + (&/T [(partial &&lux/compile-def compile-expression) + (partial &&lux/compile-program compile-expression*) + (fn [macro args state] (.apply macro args state)) + (partial &&proc-host/compile-jvm-class compile-expression*) + &&proc-host/compile-jvm-interface]))) + +(defn ^:private activate-module! [name file-hash] + (|do [_ (&&cache/delete name) + _ (&a-module/create-module name file-hash)] + (&a-module/flag-active-module name))) + +(defn ^:private save-module! [name file-hash class-bytes] + (|do [_ (&a-module/flag-compiled-module name) + _ (&&/save-class! &/module-class-name class-bytes) + module-descriptor (&&core/generate-module-descriptor file-hash)] + (&&core/write-module-descriptor! name module-descriptor))) + +(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) + +datum-sig+ "Ljava/lang/Object;"] + (defn compile-module [source-dirs name] + (|do [[file-name file-content] (&&io/read-file source-dirs name) + :let [file-hash (hash file-content) + compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] + (&/|eitherL (&&cache/load name) + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (&/fail-with-loc (str "[Compiler Error] Cannot re-define a module: " name)) + (|do [_ (activate-module! name file-hash) + :let [module-class-name (str (&host/->module-class name) "/_") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + module-class-name nil "java/lang/Object" nil) + (.visitSource file-name nil))] + _ (if (= "lux" name) + (|do [_ &&rt/compile-Function-class + _ &&rt/compile-LuxRT-class] + (return nil)) + (return nil)) + :let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)]] + (fn [state] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [:let [_ (.visitEnd =class)] + _ (save-module! name file-hash (.toByteArray =class))] + (return file-hash)) + ?state) + + (&/$Left ?message) + (&/fail* ?message))))))) + ))) + +(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String + (class (byte-array [])) + Integer/TYPE + Integer/TYPE])) + (.setAccessible true))] + (defn memory-class-loader [store] + (proxy [java.lang.ClassLoader] + [] + (findClass [^String class-name] + (if-let [^bytes bytecode (get @store class-name)] + (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) + +(defn jvm-host [] + (let [store (atom {})] + (&/$Jvm (&/T [;; "lux;writer" + &/$None + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store + ;; lux;type-env + (&/|table) + ;; lux;dummy-mappings + (&/|table) + ])))) + +(let [!err! *err*] + (defn compile-program [mode program-module source-dirs] + (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs + &&jvm-cache/load-def-value + &&jvm-cache/install-all-defs-in-module + &&jvm-cache/uninstall-all-defs-in-module) + _ (compile-module source-dirs "lux")] + (compile-module source-dirs program-module))] + (|case (m-action (&/init-state "{old}" mode (jvm-host))) + (&/$Right ?state _) + (do (println "Compilation complete!") + (&&cache/clean ?state)) + + (&/$Left ?message) + (binding [*out* !err!] + (do (println (str "Compilation failed:\n" ?message)) + (flush) + (System/exit 1))) + )))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/base.clj b/lux-bootstrapper/src/lux/compiler/jvm/base.clj new file mode 100644 index 000000000..b5e520de5 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm/base.clj @@ -0,0 +1,88 @@ +(ns lux.compiler.jvm.base + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.java.io :as io] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail*]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module]) + [lux.host.generics :as &host-generics] + [lux.compiler.core :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor) + (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Constants] +(def ^:const ^String function-class "lux/Function") +(def ^:const ^String lux-utils-class "lux/LuxRT") +(def ^:const ^String unit-tag-field "unit_tag") + +;; Formats +(def ^:const ^String local-prefix "l") +(def ^:const ^String partial-prefix "p") +(def ^:const ^String closure-prefix "c") +(def ^:const ^String apply-method "apply") +(defn ^String apply-signature [n] + (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) +(def ^:const num-apply-variants 8) +(def ^:const arity-field "_arity_") +(def ^:const partials-field "_partials_") + +;; [Utils] +(defn ^:private write-output [module name data] + (let [^String module* (&host/->module-class module) + module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] + (.mkdirs (File. module-dir)) + (&&/write-file (str module-dir java.io.File/separator name ".class") data))) + +(defn class-exists? + "(-> Text Text (IO Bit))" + [^String module ^String class-name] + (|do [_ (return nil) + :let [full-path (str @&&/!output-dir java.io.File/separator module java.io.File/separator class-name ".class") + exists? (.exists (File. full-path))]] + (return exists?))) + +;; [Exports] +(defn ^Class load-class! [^ClassLoader loader name] + (.loadClass loader name)) + +(defn save-class! [name bytecode] + (|do [eval? &/get-eval + module &/get-module-name + loader &/loader + !classes &/classes + :let [real-name (str (&host-generics/->class-name module) "." name) + _ (swap! !classes assoc real-name bytecode) + _ (when (not eval?) + (write-output module name bytecode)) + ;; _ (load-class! loader real-name) + ]] + (return nil))) + +(do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>] + (do (defn <wrap-name> [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>))))) + (defn <unwrap-name> [^MethodVisitor writer] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST <class>) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <unwrap-method> (str "()" <prim>))))) + + wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 + wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 + wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 + wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 + wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 + wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 + wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 + wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 + ) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/cache.clj b/lux-bootstrapper/src/lux/compiler/jvm/cache.clj new file mode 100644 index 000000000..f54eacc92 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm/cache.clj @@ -0,0 +1,63 @@ +(ns lux.compiler.jvm.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |case |let]] + [type :as &type] + [host :as &host]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module]) + (lux.compiler [core :as &&core] + [io :as &&io]) + (lux.compiler.jvm [base :as &&])) + (:import (java.io File) + (java.lang.reflect Field) + )) + +;; [Utils] +(defn ^:private read-file [^File file] + "(-> File (Array Byte))" + (with-open [reader (io/input-stream file)] + (let [length (.length file) + buffer (byte-array length)] + (.read reader buffer 0 length) + buffer))) + +(defn ^:private get-field [^String field-name ^Class class] + "(-> Text Class Object)" + (-> class ^Field (.getField field-name) (.get nil))) + +;; [Resources] +(defn load-def-value [module name] + (|do [loader &/loader + :let [def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name name)))]] + (return (get-field &/value-field def-class)))) + +(defn install-all-defs-in-module [module-name] + (|do [!classes &/classes + :let [module-path (str @&&core/!output-dir java.io.File/separator module-name) + file-name+content (for [^File file (seq (.listFiles (new File module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)]] + [(second (re-find #"^(.*)\.class$" file-name)) + (read-file file)]) + _ (doseq [[file-name content] file-name+content] + (swap! !classes assoc (str (&host-generics/->class-name module-name) + "." + file-name) + content))]] + (return (map first file-name+content)))) + +(defn uninstall-all-defs-in-module [module-name] + (|do [!classes &/classes + :let [module-path (str @&&core/!output-dir java.io.File/separator module-name) + installed-files (for [^File file (seq (.listFiles (new File module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)]] + (second (re-find #"^(.*)\.class$" file-name))) + _ (swap! !classes (fn [_classes-dict] + (reduce dissoc _classes-dict installed-files)))]] + (return nil))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/case.clj b/lux-bootstrapper/src/lux/compiler/jvm/case.clj new file mode 100644 index 000000000..b7cdb7571 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm/case.clj @@ -0,0 +1,207 @@ +(ns lux.compiler.jvm.case + (:require (clojure [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.analyser.case :as &a-case] + [lux.compiler.jvm.base :as &&] + [lux.compiler.jvm.rt :as &rt]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth] + (cond (= 0 stack-depth) + writer + + (= 1 stack-depth) + (doto writer + (.visitInsn Opcodes/POP)) + + (= 2 stack-depth) + (doto writer + (.visitInsn Opcodes/POP2)) + + :else ;; > 2 + (doto writer + (.visitInsn Opcodes/POP2) + (pop-alt-stack (- stack-depth 2))))) + +(defn ^:private stack-peek [^MethodVisitor writer] + (doto writer + (.visitInsn Opcodes/DUP) + &rt/peekI)) + +(defn ^:private compile-pattern* + "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" + [^MethodVisitor writer bodies stack-depth $else pm] + (|case pm + (&o/$ExecPM _body-idx) + (|case (&/|at _body-idx bodies) + (&/$Some $body) + (doto writer + (pop-alt-stack stack-depth) + (.visitJumpInsn Opcodes/GOTO $body)) + + (&/$None) + (assert false)) + + (&o/$PopPM) + (&rt/popI writer) + + (&o/$BindPM _var-id) + (doto writer + stack-peek + (.visitVarInsn Opcodes/ASTORE _var-id) + &rt/popI) + + (&o/$BitPM _value) + (doto writer + stack-peek + &&/unwrap-boolean + (.visitJumpInsn (if _value Opcodes/IFEQ Opcodes/IFNE) $else)) + + (&o/$NatPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$IntPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$RevPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$FracPM _value) + (doto writer + stack-peek + &&/unwrap-double + (.visitLdcInsn (double _value)) + (.visitInsn Opcodes/DCMPL) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$TextPM _value) + (doto writer + stack-peek + (.visitLdcInsn _value) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else)) + + (&o/$TuplePM (&/$Left lefts)) + (let [accessI (if (= 0 lefts) + #(doto ^MethodVisitor % + (.visitInsn Opcodes/AALOAD)) + #(doto ^MethodVisitor % + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "tuple_left" "([Ljava/lang/Object;I)Ljava/lang/Object;")))] + (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int lefts)) + accessI + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) + + (&o/$TuplePM (&/$Right _idx)) + (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int (dec _idx))) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "tuple_right" "([Ljava/lang/Object;I)Ljava/lang/Object;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + + (&o/$VariantPM _idx+) + (|let [$success (new Label) + $fail (new Label) + [_idx is-last] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true])) + _ (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int _idx))) + _ (if is-last + (.visitLdcInsn writer "") + (.visitInsn writer Opcodes/ACONST_NULL))] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $fail) + (.visitJumpInsn Opcodes/GOTO $success) + (.visitLabel $fail) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $success) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) + + (&o/$SeqPM _left-pm _right-pm) + (doto writer + (compile-pattern* bodies stack-depth $else _left-pm) + (compile-pattern* bodies stack-depth $else _right-pm)) + + (&o/$AltPM _left-pm _right-pm) + (|let [$alt-else (new Label)] + (doto writer + (.visitInsn Opcodes/DUP) + (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm) + (.visitLabel $alt-else) + (.visitInsn Opcodes/POP) + (compile-pattern* bodies stack-depth $else _right-pm))) + )) + +(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end] + (|let [$else (new Label)] + (doto writer + (compile-pattern* bodies 1 $else pm) + (.visitLabel $else) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_fail" "()V") + (.visitInsn Opcodes/ACONST_NULL) + (.visitJumpInsn Opcodes/GOTO $end)))) + +(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end] + (&/map% (fn [label+body] + (|let [[_label _body] label+body] + (|do [:let [_ (.visitLabel writer _label)] + _ (compile _body) + :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] + (return nil)))) + (&/zip2 bodies-labels ?bodies))) + +;; [Resources] +(defn compile-case [compile ?value ?pm ?bodies] + (|do [^MethodVisitor *writer* &/get-writer + :let [$end (new Label) + bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL))] + _ (compile ?value) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + _ (compile-pattern *writer* bodies-labels ?pm $end)] + _ (compile-bodies *writer* compile bodies-labels ?bodies $end) + :let [_ (.visitLabel *writer* $end)]] + (return nil))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/function.clj b/lux-bootstrapper/src/lux/compiler/jvm/function.clj new file mode 100644 index 000000000..eb779a7b6 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm/function.clj @@ -0,0 +1,278 @@ +(ns lux.compiler.jvm.function + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |case |let]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + (lux.compiler.jvm [base :as &&])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private function-return-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private <init>-return "V") + +(defn ^:private ^String reset-signature [function-class] + (str "()" (&host-generics/->type-signature function-class))) + +(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) + +(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] + (doto method-writer + (.visitLdcInsn (int by)) + (.visitInsn Opcodes/IADD))) + +(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.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) + 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 ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] + (doto method-writer + (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) + (->> (dotimes [idx amount]))))) + +(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] + (let [max-args-num (min amount &&/num-apply-variants)] + (doto method-writer + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (consecutive-args start max-args-num) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) + (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) + (->> (when (> amount &&/num-apply-variants))))))) + +(defn ^:private function-impl-signature [arity] + (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" function-return-sig)) + +(defn ^:private function-<init>-signature [env arity] + (if (> arity 1) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" + <init>-return) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" + <init>-return))) + +(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] + (if (= 1 arity) + (doto method-writer + (.visitLdcInsn (int 0)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "<init>" "(I)V")) + (doto method-writer + (.visitVarInsn Opcodes/ILOAD (inc closure-length)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "<init>" "(I)V")))) + +(defn ^:private add-function-<init> [^ClassWriter class class-name arity env] + (let [closure-length (&/|length env)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" (function-<init>-signature env arity) nil nil) + (.visitCode) + ;; Do normal object initialization + (.visitVarInsn Opcodes/ALOAD 0) + (init-function arity closure-length) + ;; Add all of the closure variables + (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) + (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) + (doseq [?name+?captured (&/->seq env)]))) + ;; Add all the partial arguments + (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) + (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) + (dotimes [idx* (dec arity)]))) + ;; Finish + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STRICT)] + (defn ^:private add-function-impl [^ClassWriter class class-name compile arity impl-body] + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod class impl-flags "impl" (function-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 function-class arity closed-over] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW function-class) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [?name+?captured] + (|case ?name+?captured + [?name [_ (&o/$captured _ _ ?source)]] + (compile nil ?source))) + closed-over) + :let [_ (when (> arity 1) + (doto *writer* + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity))))] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL function-class "<init>" (function-<init>-signature closed-over arity))]] + (return nil))) + +(defn ^:private add-function-reset [^ClassWriter class-writer class-name arity env] + (if (> arity 1) + (doto (.visitMethod 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 arity)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (function-<init>-signature env arity)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (doto (.visitMethod 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-function-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] + (if (> arity 1) + (let [num-partials (dec arity) + $default (new Label) + $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) + $labels (vec (concat $labels* (list $default))) + method-writer (.visitMethod class-writer (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STRICT) &&/apply-method (&&/apply-signature +degree+) nil nil) + frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) + frame-stack (to-array [Opcodes/INTEGER]) + arity-over-extent (- arity +degree+)] + (do (doto method-writer + (.visitCode) + get-num-partials! + (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) + ;; (< stage (- arity +degree+)) + (-> (doto (.visitLabel $label) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + get-num-partials! + (inc-int! +degree+) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (fill-nulls! (- (- num-partials +degree+) stage)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" (function-<init>-signature env arity)) + (.visitInsn Opcodes/ARETURN)) + (->> (cond (= stage arity-over-extent) + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (->> (when (not= 0 stage)))) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (function-impl-signature arity)) + (.visitInsn Opcodes/ARETURN)) + + (> stage arity-over-extent) + (let [args-to-completion (- arity stage) + args-left (- +degree+ args-to-completion)] + (doto method-writer + (.visitLabel $label) + (.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]))) + (consecutive-args 1 args-to-completion) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (function-impl-signature arity)) + (consecutive-applys (+ 1 args-to-completion) args-left) + (.visitInsn Opcodes/ARETURN))) + + :else) + (doseq [[stage $label] (map vector (range arity) $labels)]))) + (.visitMaxs 0 0) + (.visitEnd)) + (return nil))) + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod ^ClassWriter class-writer (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STRICT) &&/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] +(let [function-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] + (|do [[file-name _ _] &/location + :let [??scope (&/|reverse ?scope) + name (&host/location (&/|tail ??scope)) + class-name (str (&host/->module-class (&/|head ??scope)) "/" name) + [^ClassWriter =class save?] (|case ?prev-writer + (&/$Some _writer) + (&/T [_writer false]) + + (&/$None) + (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version function-flags + class-name nil &&/function-class (into-array String []))) + true])) + _ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) + (doto (.visitEnd))) + (-> (doto (.visitField datum-flags captured-name field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) + (doto (.visitEnd)) + (->> (dotimes [idx (dec arity)]))) + (-> (.visitSource file-name nil) + (when save?)) + (add-function-<init> class-name arity ?env) + (add-function-reset class-name arity ?env) + )] + _ (if (> arity 1) + (add-function-impl =class class-name compile arity ?body) + (return nil)) + _ (&/map% #(add-function-apply-n =class % class-name arity ?env compile ?body) + (&/|range* 1 (min arity &&/num-apply-variants))) + :let [_ (.visitEnd =class)] + _ (if save? + (&&/save-class! name (.toByteArray =class)) + (return nil))] + (if save? + (instance-closure compile class-name arity ?env) + (return (instance-closure compile class-name arity ?env)))))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj new file mode 100644 index 000000000..043fc2273 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj @@ -0,0 +1,402 @@ +(ns lux.compiler.jvm.lux + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module]) + (lux.compiler.jvm [base :as &&] + [function :as &&function])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor) + java.lang.reflect.Field)) + +;; [Exports] +(defn compile-bit [?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> <prim> <caster>] + (defn <name> [value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn (<caster> value)) + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str "(" <prim> ")" (&host-generics/->type-signature <class>))))]] + (return nil))) + + compile-nat "java/lang/Long" "J" long + compile-int "java/lang/Long" "J" long + compile-rev "java/lang/Long" "J" long + compile-frac "java/lang/Double" "D" double + ) + +(defn compile-text [?value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitLdcInsn *writer* ?value)]] + (return nil))) + +(defn compile-tuple [compile ?elems] + (|do [^MethodVisitor *writer* &/get-writer + :let [num-elems (&/|length ?elems)]] + (|case num-elems + 0 + (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]] + (return nil)) + + 1 + (compile (&/|head ?elems)) + + _ + (|do [:let [_ (doto *writer* + (.visitLdcInsn (int num-elems)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx elem] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret))) + (&/|range num-elems) ?elems)] + (return nil))))) + +(defn compile-variant [compile tag tail? value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitLdcInsn *writer* (int tag)) + _ (if tail? + (.visitLdcInsn *writer* "") + (.visitInsn *writer* Opcodes/ACONST_NULL))] + _ (compile value) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]] + (return nil))) + +(defn compile-local [compile ?idx] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] + (return nil))) + +(defn compile-captured [compile ?scope ?captured-id ?source] + (|do [:let [??scope (&/|reverse ?scope)] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD + (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) + (str &&/closure-prefix ?captured-id) + "Ljava/lang/Object;"))]] + (return nil))) + +(defn compile-global [compile ?owner-class ?name] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] + (return nil))) + +(defn ^:private compile-apply* [compile ?args] + (|do [^MethodVisitor *writer* &/get-writer + _ (&/map% (fn [?args] + (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)] + _ (&/map% compile ?args) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]] + (return nil))) + (&/|partition &&/num-apply-variants ?args))] + (return nil))) + +(defn compile-apply [compile ?fn ?args] + (|case ?fn + [_ (&o/$def ?module ?name)] + (|do [[_ [_ _ _ func-obj]] (&a-module/find-def! ?module ?name) + class-loader &/loader + :let [func-class (class func-obj) + func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil) + func-partials (.get ^Field (.getDeclaredField (Class/forName "lux.Function" true class-loader) &&/partials-field) func-obj) + num-args (&/|length ?args) + func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]] + (if (and (= 0 func-partials) + (>= num-args func-arity)) + (|do [_ (compile ?fn) + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)] + _ (&/map% compile (&/|take func-arity ?args)) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))] + _ (if (= num-args func-arity) + (return nil) + (compile-apply* compile (&/|drop func-arity ?args)))] + (return nil)) + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)))) + + _ + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)) + )) + +(defn compile-loop [compile-expression register-offset inits body] + (|do [^MethodVisitor *writer* &/get-writer + :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) + inits)] + _ (&/map% (fn [idx+_init] + (|do [:let [[idx _init] idx+_init + idx+ (+ register-offset idx)] + _ (compile-expression nil _init) + :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] + (return nil))) + idxs+inits) + :let [$begin (new Label) + _ (.visitLabel *writer* $begin)]] + (compile-expression $begin body) + )) + +(defn compile-iter [compile $begin register-offset ?args] + (|do [^MethodVisitor *writer* &/get-writer + :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) + ?args)] + _ (&/map% (fn [idx+?arg] + (|do [:let [[idx ?arg] idx+?arg + idx+ (+ register-offset idx) + already-set? (|case ?arg + [_ (&o/$var (&/$Local l-idx))] + (= idx+ l-idx) + + _ + false)]] + (if already-set? + (return nil) + (compile ?arg)))) + idxs+args) + _ (&/map% (fn [idx+?arg] + (|do [:let [[idx ?arg] idx+?arg + idx+ (+ register-offset idx) + already-set? (|case ?arg + [_ (&o/$var (&/$Local l-idx))] + (= idx+ l-idx) + + _ + false)] + :let [_ (when (not already-set?) + (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] + (return nil))) + (&/|reverse idxs+args)) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] + (return nil))) + +(defn compile-let [compile _value _register _body] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _value) + :let [_ (.visitVarInsn *writer* Opcodes/ASTORE _register)] + _ (compile _body)] + (return nil))) + +(defn compile-record-get [compile _value _path] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _value) + :let [_ (&/|map (fn [step] + (|let [[idx tail?] step] + (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int (if tail? + (dec idx) + idx))) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" + (if tail? "tuple_right" "tuple_left") + "([Ljava/lang/Object;I)Ljava/lang/Object;")))) + _path)]] + (return nil))) + +(defn compile-if [compile _test _then _else] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _test) + :let [$else (new Label) + $end (new Label) + _ (doto *writer* + &&/unwrap-boolean + (.visitJumpInsn Opcodes/IFEQ $else))] + _ (compile _then) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] + :let [_ (.visitLabel *writer* $else)] + _ (compile _else) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) + _ (.visitLabel *writer* $end)]] + (return nil))) + +(defn ^:private de-ann [optim] + (|case optim + [_ (&o/$ann value-expr _)] + value-expr + + _ + optim)) + +(defn ^:private throwable->text [^Throwable t] + (let [base (->> t + .getStackTrace + (map str) + (cons (.getMessage t)) + (interpose "\n") + (apply str))] + (if-let [cause (.getCause t)] + (str base "\n\n" "Caused by: " (throwable->text cause)) + base))) + +(defn ^:private install-def! [class-loader current-class module-name ?name ?body ?meta exported?] + (|do [_ (return nil) + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) + def-type (&a/expr-type* ?body)] + def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) + (catch Throwable t + (&/assert! false + (str "Error during value initialization:\n" + (throwable->text t))))) + _ (&/without-repl-closure + (&a-module/define module-name ?name exported? def-type ?meta def-value))] + (return def-value))) + +(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] + (defn compile-def [compile ?name ?body ?meta exported?] + (|do [module-name &/get-module-name + class-loader &/loader] + (|case (de-ann ?body) + [_ (&o/$function _ _ __scope _ _)] + (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope + false + (de-ann ?body))] + (|do [[file-name _ _] &/location + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil &&/function-class (into-array String [])) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + instancer (&&function/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ instancer + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! def-name (.toByteArray =class)) + def-value (install-def! class-loader current-class module-name ?name ?body ?meta exported?) + :let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]] + (return def-value))) + + _ + (|do [[file-name _ _] &/location + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil "java/lang/Object" (into-array String [])) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile nil ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! def-name (.toByteArray =class)) + def-value (install-def! class-loader current-class module-name ?name ?body ?meta exported?) + :let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]] + (return def-value)))))) + +(defn compile-program [compile ?program] + (|do [module-name &/get-module-name + ^ClassWriter *writer* &/get-writer] + (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) + (.visitCode)) + (|do [^MethodVisitor main-writer &/get-writer + _ (compile ?program) + :let [_ (.visitTypeInsn main-writer Opcodes/CHECKCAST &&/function-class)] + :let [$loop (new Label) + $end (new Label) + _ (doto main-writer + ;; Tail: Begin + (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V + ;; Tail: End + ;; Size: Begin + (.visitVarInsn Opcodes/ALOAD 0) ;; VA + (.visitInsn Opcodes/ARRAYLENGTH) ;; VI + ;; Size: End + ;; Loop: Begin + (.visitLabel $loop) + (.visitLdcInsn (int 1)) ;; VII + (.visitInsn Opcodes/ISUB) ;; VI + (.visitInsn Opcodes/DUP) ;; VII + (.visitJumpInsn Opcodes/IFLT $end) ;; VI + ;; Head: Begin + (.visitInsn Opcodes/DUP) ;; VII + (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA + (.visitInsn Opcodes/SWAP) ;; VIAI + (.visitInsn Opcodes/AALOAD) ;; VIO + (.visitInsn Opcodes/SWAP) ;; VOI + (.visitInsn Opcodes/DUP_X2) ;; IVOI + (.visitInsn Opcodes/POP) ;; IVO + ;; Head: End + ;; Tuple: Begin + (.visitLdcInsn (int 2)) ;; IVOS + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 + (.visitInsn Opcodes/DUP_X1) ;; IV2O2 + (.visitInsn Opcodes/SWAP) ;; IV22O + (.visitLdcInsn (int 0)) ;; IV22OI + (.visitInsn Opcodes/SWAP) ;; IV22IO + (.visitInsn Opcodes/AASTORE) ;; IV2 + (.visitInsn Opcodes/DUP_X1) ;; I2V2 + (.visitInsn Opcodes/SWAP) ;; I22V + (.visitLdcInsn (int 1)) ;; I22VI + (.visitInsn Opcodes/SWAP) ;; I22IV + (.visitInsn Opcodes/AASTORE) ;; I2 + ;; Tuple: End + ;; Cons: Begin + (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I + (.visitLdcInsn "") ;; I2I? + (.visitInsn Opcodes/DUP2_X1) ;; II?2I? + (.visitInsn Opcodes/POP2) ;; II?2 + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV + ;; Cons: End + (.visitInsn Opcodes/SWAP) ;; VI + (.visitJumpInsn Opcodes/GOTO $loop) + ;; Loop: End + (.visitLabel $end) ;; VI + (.visitInsn Opcodes/POP) ;; V + )] + :let [_ (doto main-writer + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (doto main-writer + (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj b/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj new file mode 100644 index 000000000..d4c825282 --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj @@ -0,0 +1,460 @@ +(ns lux.compiler.jvm.proc.common + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [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] + [lux.analyser.base :as &a] + [lux.compiler.jvm.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Resources] +(do-template [<name> <op>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?mask) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitInsn <op>) + &&/wrap-long)]] + (return nil))) + + ^:private compile-i64-and Opcodes/LAND + ^:private compile-i64-or Opcodes/LOR + ^:private compile-i64-xor Opcodes/LXOR + ) + +(do-template [<op> <name>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?shift) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn <op>) + &&/wrap-long)]] + (return nil))) + + Opcodes/LSHL ^:private compile-i64-left-shift + Opcodes/LSHR ^:private compile-i64-arithmetic-right-shift + Opcodes/LUSHR ^:private compile-i64-logical-right-shift + ) + +(defn ^:private compile-lux-is [compile ?values special-args] + (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?left) + _ (compile ?right) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IF_ACMPEQ $then) + ;; else + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") + (.visitLabel $end))]] + (return nil))) + +(defn ^:private compile-lux-try [compile ?values special-args] + (|do [:let [(&/$Cons ?op (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?op) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "lux/Function") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "runTry" "(Llux/Function;)[Ljava/lang/Object;"))]] + (return nil))) + +(do-template [<name> <opcode> <unwrap> <wrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap>)] + _ (compile ?y) + :let [_ (doto *writer* + <unwrap>) + _ (doto *writer* + (.visitInsn <opcode>) + <wrap>)]] + (return nil))) + + ^:private compile-i64-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-i64-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + + ^:private compile-int-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long + ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long + ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long + + ^:private compile-frac-add Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-frac-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-frac-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-frac-div Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-frac-rem Opcodes/DREM &&/unwrap-double &&/wrap-double + ) + +(do-template [<name> <cmpcode> <cmp-output> <unwrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap>)] + _ (compile ?y) + :let [_ (doto *writer* + <unwrap>) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn <cmpcode>) + (.visitLdcInsn (int <cmp-output>)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-i64-eq Opcodes/LCMP 0 &&/unwrap-long + + ^:private compile-int-lt Opcodes/LCMP -1 &&/unwrap-long + + ^:private compile-frac-eq Opcodes/DCMPG 0 &&/unwrap-double + ^:private compile-frac-lt Opcodes/DCMPG -1 &&/unwrap-double + ) + +(defn ^:private compile-frac-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]] + (return nil))) + +(defn ^:private compile-frac-decode [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "decode_frac" "(Ljava/lang/String;)[Ljava/lang/Object;"))]] + (return nil))) + +(defn ^:private compile-int-char [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitInsn Opcodes/I2C) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/String" "valueOf" "(C)Ljava/lang/String;"))]] + (return nil))) + +(do-template [<name> <unwrap> <op> <wrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + <unwrap> + (.visitInsn <op>) + <wrap>)]] + (return nil))) + + ^:private compile-frac-int &&/unwrap-double Opcodes/D2L &&/wrap-long + ^:private compile-int-frac &&/unwrap-long Opcodes/L2D &&/wrap-double + ) + +(defn ^:private compile-text-eq [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + _ (compile ?y) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (&&/wrap-boolean))]] + (return nil))) + +(defn ^:private compile-text-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)I") + (.visitJumpInsn Opcodes/IFLT $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + +(defn compile-text-concat [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] + (return nil))) + +(defn compile-text-clip [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?from) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?to) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;"))]] + (return nil))) + +(defn ^:private compile-text-index [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?part) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?start) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "indexOf" "(Ljava/lang/String;I)I"))] + :let [$not-found (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $not-found) + (.visitInsn Opcodes/I2L) + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $not-found) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()[Ljava/lang/Object;") + (.visitLabel $end))]] + (return nil))) + +(do-template [<name> <class> <method>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> "()I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + + ^:private compile-text-size "java/lang/String" "length" + ) + +(defn ^:private compile-text-char [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-io-log [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))] + _ (compile ?x) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") + (.visitLdcInsn &/unit-tag))]] + (return nil))) + +(defn ^:private compile-io-error [compile ?values special-args] + (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW "java/lang/Error") + (.visitInsn Opcodes/DUP))] + _ (compile ?message) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Error" "<init>" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW))]] + (return nil))) + +(defn ^:private compile-io-exit [compile ?values special-args] + (|do [:let [(&/$Cons ?code (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?code) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "exit" "(I)V") + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-io-current-time [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "currentTimeMillis" "()J") + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-syntax-char-case! [compile ?values ?patterns] + (|do [:let [(&/$Cons ?input (&/$Cons [_ (&a/$tuple ?matches)] (&/$Cons ?else (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + :let [pattern-labels (&/|map (fn [_] (new Label)) ?patterns) + matched-patterns (->> (&/zip2 ?patterns pattern-labels) + (&/flat-map (fn [?chars+?label] + (|let [[?chars ?label] ?chars+?label] + (&/|map (fn [?char] + (&/T [?char ?label])) + ?chars)))) + &/->seq + (sort-by &/|first <) + &/->list) + end-label (new Label) + else-label (new Label)] + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitLookupSwitchInsn else-label + (int-array (&/->seq (&/|map &/|first matched-patterns))) + (into-array (&/->seq (&/|map &/|second matched-patterns)))))] + _ (&/map% (fn [?label+?match] + (|let [[?label ?match] ?label+?match] + (|do [:let [_ (doto *writer* + (.visitLabel ?label))] + _ (compile ?match) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO end-label))]] + (return nil)))) + (&/zip2 pattern-labels ?matches)) + :let [_ (doto *writer* + (.visitLabel else-label))] + _ (compile ?else) + :let [_ (doto *writer* + (.visitLabel end-label))]] + (return nil))) + +(defn compile-proc [compile category proc ?values special-args] + (case category + "lux" + (case proc + "is" (compile-lux-is compile ?values special-args) + "try" (compile-lux-try compile ?values special-args) + ;; Special extensions for performance reasons + ;; Will be replaced by custom extensions in the future. + "syntax char case!" (compile-syntax-char-case! compile ?values special-args)) + + "io" + (case proc + "log" (compile-io-log compile ?values special-args) + "error" (compile-io-error compile ?values special-args) + "exit" (compile-io-exit compile ?values special-args) + "current-time" (compile-io-current-time compile ?values special-args) + ) + + "text" + (case proc + "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) + "concat" (compile-text-concat compile ?values special-args) + "clip" (compile-text-clip compile ?values special-args) + "index" (compile-text-index compile ?values special-args) + "size" (compile-text-size compile ?values special-args) + "char" (compile-text-char compile ?values special-args) + ) + + "i64" + (case proc + "and" (compile-i64-and compile ?values special-args) + "or" (compile-i64-or compile ?values special-args) + "xor" (compile-i64-xor compile ?values special-args) + "left-shift" (compile-i64-left-shift compile ?values special-args) + "arithmetic-right-shift" (compile-i64-arithmetic-right-shift compile ?values special-args) + "logical-right-shift" (compile-i64-logical-right-shift compile ?values special-args) + "=" (compile-i64-eq compile ?values special-args) + "+" (compile-i64-add compile ?values special-args) + "-" (compile-i64-sub compile ?values special-args) + "*" (compile-int-mul compile ?values special-args) + "/" (compile-int-div compile ?values special-args) + "%" (compile-int-rem compile ?values special-args) + "<" (compile-int-lt compile ?values special-args) + "f64" (compile-int-frac compile ?values special-args) + "char" (compile-int-char compile ?values special-args) + ) + + "f64" + (case proc + "+" (compile-frac-add compile ?values special-args) + "-" (compile-frac-sub compile ?values special-args) + "*" (compile-frac-mul compile ?values special-args) + "/" (compile-frac-div compile ?values special-args) + "%" (compile-frac-rem compile ?values special-args) + "=" (compile-frac-eq compile ?values special-args) + "<" (compile-frac-lt compile ?values special-args) + "i64" (compile-frac-int compile ?values special-args) + "encode" (compile-frac-encode compile ?values special-args) + "decode" (compile-frac-decode compile ?values special-args) + ) + + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj b/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj new file mode 100644 index 000000000..ec934ae7b --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj @@ -0,0 +1,1112 @@ +(ns lux.compiler.jvm.proc.host + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [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] + [lux.analyser.base :as &a] + [lux.compiler.jvm.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Utils] +(def init-method "<init>") + +(let [class+method+sig {"boolean" &&/unwrap-boolean + "byte" &&/unwrap-byte + "short" &&/unwrap-short + "int" &&/unwrap-int + "long" &&/unwrap-long + "float" &&/unwrap-float + "double" &&/unwrap-double + "char" &&/unwrap-char}] + (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] + (if-let [unwrap (get class+method+sig class-name)] + (doto *writer* + unwrap) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) + +(let [boolean-class "java.lang.Boolean" + byte-class "java.lang.Byte" + short-class "java.lang.Short" + int-class "java.lang.Integer" + long-class "java.lang.Long" + float-class "java.lang.Float" + double-class "java.lang.Double" + char-class "java.lang.Character"] + (defn prepare-return! [^MethodVisitor *writer* *type*] + (if (&type/type= &type/Any *type*) + (.visitLdcInsn *writer* &/unit-tag) + (|case *type* + (&/$Primitive "boolean" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) + + (&/$Primitive "byte" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) + + (&/$Primitive "short" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) + + (&/$Primitive "int" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) + + (&/$Primitive "long" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) + + (&/$Primitive "float" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) + + (&/$Primitive "double" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) + + (&/$Primitive "char" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) + + (&/$Primitive _ _) + nil + + (&/$Named ?name ?type) + (prepare-return! *writer* ?type) + + (&/$Ex _) + nil + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*))))) + *writer*)) + +;; [Resources] +(defn ^:private compile-annotation [^ClassWriter writer ann] + (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) + nil) + +(defn ^:private compile-field [^ClassWriter writer field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|let [=field (.visitField writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) + ?name + (&host-generics/gclass->simple-signature ?gclass) + (&host-generics/gclass->signature ?gclass) nil)] + (do (&/|map (partial compile-annotation =field) ?anns) + (.visitEnd =field) + nil)) + + (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) + (|let [=field (.visitField writer + (+ (&host/privacy-modifier->flag =privacy-modifier) + (&host/state-modifier->flag =state-modifier)) + =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) nil)] + (do (&/|map (partial compile-annotation =field) =anns) + (.visitEnd =field) + nil)) + )) + +(defn ^:private compile-method-return [^MethodVisitor writer output] + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass _class-name _) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name)) + (.visitInsn Opcodes/ARETURN)) + + _ + (.visitInsn writer Opcodes/ARETURN))) + +(defn ^:private prepare-method-input + "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" + [idx input ^MethodVisitor method-visitor] + (|case input + [_ (&/$GenericClass name params)] + (case name + "boolean" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-boolean + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) + "byte" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-byte + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) + "short" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-short + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) + "int" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-int + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) + "long" (do (doto method-visitor + (.visitVarInsn Opcodes/LLOAD idx) + &&/wrap-long + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) + "float" (do (doto method-visitor + (.visitVarInsn Opcodes/FLOAD idx) + &&/wrap-float + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) + "double" (do (doto method-visitor + (.visitVarInsn Opcodes/DLOAD idx) + &&/wrap-double + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) + "char" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-char + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) + ;; else + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) + + [_ gclass] + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) + )) + +(defn ^:private prepare-method-inputs + "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" + [idx inputs method-visitor] + (|case inputs + (&/$Nil) + (return &/$Nil) + + (&/$Cons input inputs*) + (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] + (|do [:let [[_idx _outputs] idx+outputs] + [idx* output] (prepare-method-input _idx input method-visitor)] + (return (&/T [idx* (&/$Cons output _outputs)])))) + (&/T [idx &/$Nil]) + inputs)] + (return (&/list-join (&/|reverse outputs*)))) + )) + +(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] + (|case method-def + (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|let [?output (&/$GenericClass "void" (&/|list)) + =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0)) + init-method + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [[super-class-name super-class-params] ?super-class + init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) + init-sig (str "(" init-types ")" "V") + _ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + :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 (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if =final? Opcodes/ACC_FINAL 0) + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0) + Opcodes/ACC_STATIC) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 0 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_ABSTRACT + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + + (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + )) + +(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] + (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) + =method (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + _ (&/|map (partial compile-annotation =method) =anns) + _ (.visitEnd =method)] + nil)) + +(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] + (case type + "boolean" (doto writer + &&/unwrap-boolean) + "byte" (doto writer + &&/unwrap-byte) + "short" (doto writer + &&/unwrap-short) + "int" (doto writer + &&/unwrap-int) + "long" (doto writer + &&/unwrap-long) + "float" (doto writer + &&/unwrap-float) + "double" (doto writer + &&/unwrap-double) + "char" (doto writer + &&/unwrap-char) + ;; else + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) + +(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") + <init>-return "V"] + (defn ^:private anon-class-<init>-signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + <init>-return)) + + (defn ^:private add-anon-class-<init> [^ClassWriter class-writer compile class-name super-class env ctor-args] + (|let [[super-class-name super-class-params] super-class + init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] + (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class-<init>-signature env) nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0))] + _ (&/map% (fn [type+term] + (|let [[type term] type+term] + (|do [_ (compile term) + :let [_ (prepare-ctor-arg =method type)]] + (return nil)))) + ctor-args) + :let [_ (doto =method + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" <init>-return)) + (-> (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 [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + ) + +(defn ^:private constant-inits + "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" + [fields] + (&/fold &/|++ + &/$Nil + (&/|map (fn [field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (&/|list (&/T [?name ?gclass ?value])) + + (&/$VariableFieldSyntax _) + (&/|list) + )) + fields))) + +(declare compile-jvm-putstatic) +(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] + (|do [module &/get-module-name + [file-name line column] &/location + :let [[?name ?params] class-decl + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) + full-name (str module "/" ?name) + super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + (&host/inheritance-modifier->flag ?inheritance-modifier)) + full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =class) ?anns) + _ (&/|map (partial compile-field =class) + ?fields)] + _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) + _ (|case ??ctor-args + (&/$Some ctor-args) + (add-anon-class-<init> =class compile full-name ?super-class env ctor-args) + + _ + (return nil)) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode))] + _ (&/map% (fn [ftriple] + (|let [[fname fgclass fvalue] ftriple] + (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) + (constant-inits ?fields)) + :let [_ (doto =method + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) + +(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] + (|do [:let [[interface-name interface-vars] interface-decl] + module &/get-module-name + [file-name _ _] &/location + :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) + =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) + (str module "/" interface-name) + (if (= "" interface-signature) nil interface-signature) + "java/lang/Object" + (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =interface) ?anns) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) + (.visitEnd =interface))]] + (&&/save-class! interface-name (.toByteArray =interface)))) + +(do-template [<name> <op> <unwrap> <wrap>] + (defn <name> [compile _?value special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [_ (doto *writer* + <unwrap> + (.visitInsn <op>) + <wrap>)]] + (return nil))) + + ^:private compile-jvm-double-to-float Opcodes/D2F &&/unwrap-double &&/wrap-float + ^:private compile-jvm-double-to-int Opcodes/D2I &&/unwrap-double &&/wrap-int + ^:private compile-jvm-double-to-long Opcodes/D2L &&/unwrap-double &&/wrap-long + + ^:private compile-jvm-float-to-double Opcodes/F2D &&/unwrap-float &&/wrap-double + ^:private compile-jvm-float-to-int Opcodes/F2I &&/unwrap-float &&/wrap-int + ^:private compile-jvm-float-to-long Opcodes/F2L &&/unwrap-float &&/wrap-long + + ^:private compile-jvm-int-to-byte Opcodes/I2B &&/unwrap-int &&/wrap-byte + ^:private compile-jvm-int-to-char Opcodes/I2C &&/unwrap-int &&/wrap-char + ^:private compile-jvm-int-to-double Opcodes/I2D &&/unwrap-int &&/wrap-double + ^:private compile-jvm-int-to-float Opcodes/I2F &&/unwrap-int &&/wrap-float + ^:private compile-jvm-int-to-long Opcodes/I2L &&/unwrap-int &&/wrap-long + ^:private compile-jvm-int-to-short Opcodes/I2S &&/unwrap-int &&/wrap-short + + ^:private compile-jvm-long-to-double Opcodes/L2D &&/unwrap-long &&/wrap-double + ^:private compile-jvm-long-to-float Opcodes/L2F &&/unwrap-long &&/wrap-float + ^:private compile-jvm-long-to-int Opcodes/L2I &&/unwrap-long &&/wrap-int + + ^:private compile-jvm-char-to-byte Opcodes/I2B &&/unwrap-char &&/wrap-byte + ^:private compile-jvm-char-to-short Opcodes/I2S &&/unwrap-char &&/wrap-short + ^:private compile-jvm-char-to-int Opcodes/NOP &&/unwrap-char &&/wrap-int + ^:private compile-jvm-char-to-long Opcodes/I2L &&/unwrap-char &&/wrap-long + + ^:private compile-jvm-short-to-long Opcodes/I2L &&/unwrap-short &&/wrap-long + + ^:private compile-jvm-byte-to-long Opcodes/I2L &&/unwrap-byte &&/wrap-long + ) + +(do-template [<name> <op> <wrap>] + (defn <name> [compile _?value special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitInsn <op>) + <wrap>)]] + (return nil))) + + ^:private compile-jvm-long-to-short Opcodes/I2S &&/wrap-short + ^:private compile-jvm-long-to-byte Opcodes/I2B &&/wrap-byte + ) + +(do-template [<name> <op> <unwrap-left> <unwrap-right> <wrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap-left>)] + _ (compile ?y) + :let [_ (doto *writer* + <unwrap-right>)] + :let [_ (doto *writer* + (.visitInsn <op>) + <wrap>)]] + (return nil))) + + ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int + + ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long + ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long + ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long + ) + +(do-template [<name> <opcode> <unwrap> <wrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap>)] + _ (compile ?y) + :let [_ (doto *writer* + <unwrap>) + _ (doto *writer* + (.visitInsn <opcode>) + (<wrap>))]] + (return nil))) + + ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int + ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int + ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int + ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int + ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int + + ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long + ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long + + ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float + ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float + + ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double + ) + +(do-template [<name> <opcode> <unwrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap>)] + _ (compile ?y) + :let [_ (doto *writer* + <unwrap>) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn <opcode> $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ &&/unwrap-int + ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int + ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int + + ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char + ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char + ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char + ) + +(do-template [<name> <cmpcode> <cmp-output> <unwrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap>)] + _ (compile ?y) + :let [_ (doto *writer* + <unwrap>) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn <cmpcode>) + (.visitLdcInsn (int <cmp-output>)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long + ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long + ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long + + ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float + ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float + ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float + + ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double + ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double + ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double + ) + +(do-template [<prim-type> <array-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>] + (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* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]] + (return nil))) + + (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>)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn <load-op>) + <wrapper>)]] + (return nil))) + + (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>)] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (doto *writer* + <unwrapper> + (.visitInsn <store-op>))]] + (return nil))) + ) + + Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean + Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte + Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short + Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int + Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long + Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float + Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double + 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 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* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] + (return nil))) + +(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) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] + (return nil))) + +(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) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(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) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-jvm-object-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-object-null? [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IFNULL $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + +(defn compile-jvm-object-synchronized [compile ?values special-args] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?monitor) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/MONITORENTER))] + _ (compile ?expr) + :let [_ (doto *writer* + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/MONITOREXIT))]] + (return nil))) + +(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 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* + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(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) + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class*) + (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(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) + _ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(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) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + _ (compile ?value) + =input-sig (&host/->java-sig ?input-type) + :let [_ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-invokestatic [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + +(do-template [<name> <op>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?object ?args) ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (compile ?object) + :let [_ (when (not= "<init>" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn <op> ?class* ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + + ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL + ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE + ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ) + +(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) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW class*) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [class-name+arg] + (|do [:let [[class-name arg] class-name+arg] + ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (&/zip2 ?classes ?args)) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] + (return nil))) + +(defn ^:private compile-jvm-object-class [compile ?values special-args] + (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn _class-name) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") + (prepare-return! ?output-type))]] + (return nil))) + +(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) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/INSTANCEOF class*) + (&&/wrap-boolean))]] + (return nil))) + +(defn compile-proc [compile proc-name ?values special-args] + (case proc-name + "object synchronized" (compile-jvm-object-synchronized compile ?values special-args) + "object class" (compile-jvm-object-class compile ?values special-args) + "instanceof" (compile-jvm-instanceof 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) + "object null?" (compile-jvm-object-null? compile ?values special-args) + "object null" (compile-jvm-object-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) + "zaload" (compile-jvm-zaload compile ?values special-args) + "zastore" (compile-jvm-zastore compile ?values special-args) + "baload" (compile-jvm-baload compile ?values special-args) + "bastore" (compile-jvm-bastore compile ?values special-args) + "saload" (compile-jvm-saload compile ?values special-args) + "sastore" (compile-jvm-sastore compile ?values special-args) + "iaload" (compile-jvm-iaload compile ?values special-args) + "iastore" (compile-jvm-iastore compile ?values special-args) + "laload" (compile-jvm-laload compile ?values special-args) + "lastore" (compile-jvm-lastore compile ?values special-args) + "faload" (compile-jvm-faload compile ?values special-args) + "fastore" (compile-jvm-fastore compile ?values special-args) + "daload" (compile-jvm-daload compile ?values special-args) + "dastore" (compile-jvm-dastore compile ?values special-args) + "caload" (compile-jvm-caload compile ?values special-args) + "castore" (compile-jvm-castore 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) + "double-to-float" (compile-jvm-double-to-float compile ?values special-args) + "double-to-int" (compile-jvm-double-to-int compile ?values special-args) + "double-to-long" (compile-jvm-double-to-long compile ?values special-args) + "float-to-double" (compile-jvm-float-to-double compile ?values special-args) + "float-to-int" (compile-jvm-float-to-int compile ?values special-args) + "float-to-long" (compile-jvm-float-to-long compile ?values special-args) + "int-to-byte" (compile-jvm-int-to-byte compile ?values special-args) + "int-to-char" (compile-jvm-int-to-char compile ?values special-args) + "int-to-double" (compile-jvm-int-to-double compile ?values special-args) + "int-to-float" (compile-jvm-int-to-float compile ?values special-args) + "int-to-long" (compile-jvm-int-to-long compile ?values special-args) + "int-to-short" (compile-jvm-int-to-short compile ?values special-args) + "long-to-double" (compile-jvm-long-to-double compile ?values special-args) + "long-to-float" (compile-jvm-long-to-float compile ?values special-args) + "long-to-int" (compile-jvm-long-to-int compile ?values special-args) + "long-to-short" (compile-jvm-long-to-short compile ?values special-args) + "long-to-byte" (compile-jvm-long-to-byte compile ?values special-args) + "char-to-byte" (compile-jvm-char-to-byte compile ?values special-args) + "char-to-short" (compile-jvm-char-to-short compile ?values special-args) + "char-to-int" (compile-jvm-char-to-int compile ?values special-args) + "char-to-long" (compile-jvm-char-to-long compile ?values special-args) + "short-to-long" (compile-jvm-short-to-long compile ?values special-args) + "byte-to-long" (compile-jvm-byte-to-long compile ?values special-args) + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["jvm" proc-name])))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/rt.clj b/lux-bootstrapper/src/lux/compiler/jvm/rt.clj new file mode 100644 index 000000000..7fabd27ed --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/jvm/rt.clj @@ -0,0 +1,410 @@ +(ns lux.compiler.jvm.rt + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [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] + [lux.analyser.base :as &a] + [lux.compiler.jvm.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Utils] +(def init-method "<init>") + +;; [Resources] +;; Functions +(def compile-Function-class + (|do [_ (return nil) + :let [super-class "java/lang/Object" + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + Opcodes/ACC_ABSTRACT + ;; Opcodes/ACC_INTERFACE + ) + &&/function-class nil super-class (into-array String [])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) + (doto (.visitEnd)))) + =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (dotimes [arity* &&/num-apply-variants] + (let [arity (inc arity*)] + (if (= 1 arity) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) + (.visitEnd)) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) + (.visitCode) + (-> (.visitVarInsn Opcodes/ALOAD idx) + (->> (dotimes [idx arity]))) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitVarInsn Opcodes/ALOAD arity) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))))]] + (&&/save-class! (second (string/split &&/function-class #"/")) + (.toByteArray (doto =class .visitEnd))))) + +(defmacro <bytecode> [& instructions] + `(fn [^MethodVisitor writer#] + (doto writer# + ~@instructions))) + +;; Runtime infrastructure +(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] + (|let [lefts #(doto ^MethodVisitor % + (.visitVarInsn Opcodes/ILOAD 1)) + tuple-size #(doto ^MethodVisitor % + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARRAYLENGTH)) + last-right #(doto ^MethodVisitor % + tuple-size + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB)) + sub-lefts #(doto ^MethodVisitor % + lefts + last-right + (.visitInsn Opcodes/ISUB)) + sub-tuple #(doto ^MethodVisitor % + (.visitVarInsn Opcodes/ALOAD 0) + last-right + (.visitInsn Opcodes/AALOAD) + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")) + recurI (fn [$begin] + #(doto ^MethodVisitor % + sub-lefts (.visitVarInsn Opcodes/ISTORE 1) + sub-tuple (.visitVarInsn Opcodes/ASTORE 0) + (.visitJumpInsn Opcodes/GOTO $begin))) + _ (let [$begin (new Label) + $recursive (new Label) + left-index lefts + left-access #(doto ^MethodVisitor % + (.visitVarInsn Opcodes/ALOAD 0) + left-index + (.visitInsn Opcodes/AALOAD))] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "tuple_left" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + lefts last-right (.visitJumpInsn Opcodes/IF_ICMPGE $recursive) + left-access + (.visitInsn Opcodes/ARETURN) + (.visitLabel $recursive) + ((recurI $begin)) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $not-last (new Label) + $must-copy (new Label) + right-index #(doto ^MethodVisitor % + lefts + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/IADD)) + right-access #(doto ^MethodVisitor % + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/AALOAD)) + sub-right #(doto ^MethodVisitor % + (.visitVarInsn Opcodes/ALOAD 0) + right-index + tuple-size + (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;"))] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "tuple_right" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + last-right right-index + (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPNE $not-last) + right-access + (.visitInsn Opcodes/ARETURN) + (.visitLabel $not-last) + (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) + ;; Must recurse + ((recurI $begin)) + (.visitLabel $must-copy) + sub-right + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop (new Label) + $perfect-match! (new Label) + $tags-match! (new Label) + $maybe-nested (new Label) + $mismatch! (new Label) + + !variant (<bytecode> (.visitVarInsn Opcodes/ALOAD 0)) + !tag (<bytecode> (.visitVarInsn Opcodes/ILOAD 1)) + !last? (<bytecode> (.visitVarInsn Opcodes/ALOAD 2)) + + <>tag (<bytecode> (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + &&/unwrap-int) + <>last? (<bytecode> (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD)) + <>value (<bytecode> (.visitLdcInsn (int 2)) + (.visitInsn Opcodes/AALOAD)) + + not-found (<bytecode> (.visitInsn Opcodes/ACONST_NULL)) + + super-nested-tag (<bytecode> (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/ISUB)) + super-nested (<bytecode> super-nested-tag ;; super-tag + !variant <>last? ;; super-tag, super-last + !variant <>value ;; super-tag, super-last, super-value + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + + update-!variant (<bytecode> !variant <>value + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0)) + update-!tag (<bytecode> (.visitInsn Opcodes/ISUB)) + iterate! (fn [^Label $loop] + (<bytecode> update-!variant + update-!tag + (.visitJumpInsn Opcodes/GOTO $loop)))] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + !tag ;; tag + (.visitLabel $loop) + !variant <>tag ;; tag, variant::tag + (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPEQ $tags-match!) ;; tag, variant::tag + (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPGT $maybe-nested) ;; tag, variant::tag + !last? (.visitJumpInsn Opcodes/IFNULL $mismatch!) ;; tag, variant::tag + super-nested ;; super-variant + (.visitInsn Opcodes/ARETURN) + (.visitLabel $tags-match!) ;; tag, variant::tag + !last? ;; tag, variant::tag, last? + !variant <>last? + (.visitJumpInsn Opcodes/IF_ACMPEQ $perfect-match!) + (.visitLabel $maybe-nested) ;; tag, variant::tag + !variant <>last? ;; tag, variant::tag, variant::last? + (.visitJumpInsn Opcodes/IFNULL $mismatch!) ;; tag, variant::tag + ((iterate! $loop)) + (.visitLabel $perfect-match!) + ;; (.visitInsn Opcodes/POP2) + !variant <>value + (.visitInsn Opcodes/ARETURN) + (.visitLabel $mismatch!) ;; tag, variant::tag + ;; (.visitInsn Opcodes/POP2) + not-found + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (int 3)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ILOAD 0) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 2)) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + nil)) + +(defn ^:private swap2x1 [^MethodVisitor =method] + (doto =method + ;; X1, Y2 + (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 + (.visitInsn Opcodes/POP2) ;; Y2, X1 + )) + +(do-template [<name> <method> <class> <parse-method> <signature> <wrapper>] + (defn <name> [^ClassWriter =class] + (do (let [$from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) <method> "(Ljava/lang/String;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC <class> <parse-method> <signature>) + <wrapper> + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + nil)) + + ^:private compile-LuxRT-int-methods "decode_int" "java/lang/Long" "parseLong" "(Ljava/lang/String;)J" &&/wrap-long + ^:private compile-LuxRT-frac-methods "decode_frac" "java/lang/Double" "parseDouble" "(Ljava/lang/String;)D" &&/wrap-double + ) + +(defn peekI [^MethodVisitor writer] + (doto writer + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD))) + +(defn popI [^MethodVisitor writer] + (doto writer + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;"))) + +(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn "Invalid expression for pattern-matching.") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + nil)) + +(def compile-LuxRT-class + (|do [_ (return nil) + :let [full-name &&/lux-utils-class + super-class (&host-generics/->bytecode-class-name "java.lang.Object") + tag-sig (&host-generics/->type-signature "java.lang.String") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + full-name nil super-class (into-array String []))) + =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) + (.visitEnd)) + =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitLdcInsn "LOG: ") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I + (.visitLdcInsn "") ;; I? + (.visitVarInsn Opcodes/ALOAD 0) ;; I?O + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn "_") + (.visitLdcInsn "") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (let [$from (new Label) + $to (new Label) + $handler (new Label) + make-string-writerI (fn [^MethodVisitor _method_] + (doto _method_ + (.visitTypeInsn Opcodes/NEW "java/io/StringWriter") + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/io/StringWriter" "<init>" "()V"))) + make-print-writerI (fn [^MethodVisitor _method_] + (doto _method_ + ;; W + (.visitTypeInsn Opcodes/NEW "java/io/PrintWriter") ;; WP + (.visitInsn Opcodes/SWAP) ;; PW + (.visitInsn Opcodes/DUP2) ;; PWPW + (.visitInsn Opcodes/POP) ;; PWP + (.visitInsn Opcodes/SWAP) ;; PPW + (.visitLdcInsn true) ;; PPW? + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/io/PrintWriter" "<init>" "(Ljava/io/Writer;Z)V") + ;; P + ))] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" "(Llux/Function;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Throwable") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) ;; T + make-string-writerI ;; TW + (.visitInsn Opcodes/DUP2) ;; TWTW + make-print-writerI ;; TWTP + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Throwable" "printStackTrace" "(Ljava/io/PrintWriter;)V") ;; TW + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/StringWriter" "toString" "()Ljava/lang/String;") ;; TS + (.visitInsn Opcodes/SWAP) (.visitInsn Opcodes/POP) ;; S + (.visitLdcInsn (->> #'&/$Left meta ::&/idx int)) ;; SI + (.visitInsn Opcodes/ACONST_NULL) ;; SI? + swap2x1 ;; I?S + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (doto =class + (compile-LuxRT-pm-methods) + (compile-LuxRT-adt-methods) + (compile-LuxRT-int-methods) + (compile-LuxRT-frac-methods))]] + (&&/save-class! (second (string/split &&/lux-utils-class #"/")) + (.toByteArray (doto =class .visitEnd))))) diff --git a/lux-bootstrapper/src/lux/compiler/parallel.clj b/lux-bootstrapper/src/lux/compiler/parallel.clj new file mode 100644 index 000000000..28716b45b --- /dev/null +++ b/lux-bootstrapper/src/lux/compiler/parallel.clj @@ -0,0 +1,45 @@ +(ns lux.compiler.parallel + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case]]))) + +;; [Utils] +(def ^:private !state! (ref {})) + +(def ^:private get-compiler + (fn [compiler] + (return* compiler compiler))) + +;; [Exports] +(defn setup! + "Must always call this function before using parallel compilation to make sure that the state that is being tracked is in proper shape." + [] + (dosync (ref-set !state! {}))) + +(defn parallel-compilation [compile-module*] + (fn [module-name] + (|do [compiler get-compiler + :let [[task new?] (dosync (if-let [existing-task (get @!state! module-name)] + (&/T [existing-task false]) + (let [new-task (promise)] + (do (alter !state! assoc module-name new-task) + (&/T [new-task true]))))) + _ (when new? + (.start (new Thread + (fn [] + (let [out-str (with-out-str + (try (|case (&/run-state (compile-module* module-name) + compiler) + (&/$Right post-compiler _) + (deliver task (&/$Right post-compiler)) + + (&/$Left ?error) + (deliver task (&/$Left ?error))) + (catch Throwable ex + (.printStackTrace ex) + (deliver task (&/$Left "")))))] + (&/|log! out-str))))))]] + (return task)))) diff --git a/lux-bootstrapper/src/lux/host.clj b/lux-bootstrapper/src/lux/host.clj new file mode 100644 index 000000000..562d582f6 --- /dev/null +++ b/lux-bootstrapper/src/lux/host.clj @@ -0,0 +1,432 @@ +(ns lux.host + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics]) + (:import (java.lang.reflect Field Method Constructor Modifier Type + GenericArrayType ParameterizedType TypeVariable) + (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Constants] +(def function-class "lux.Function") +(def module-separator "/") +(def class-name-separator ".") +(def class-separator "/") +(def bytecode-version Opcodes/V1_6) + +;; [Resources] +(defn ^String ->module-class [old] + old) + +(def ->package ->module-class) + +(defn unfold-array + "(-> Type (, Int Type))" + [type] + (|case type + (&/$Primitive "#Array" (&/$Cons param (&/$Nil))) + (|let [[count inner] (unfold-array param)] + (&/T [(inc count) inner])) + + _ + (&/T [0 type]))) + +(let [ex-type-class (str "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";") + object-array (str "[" "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")] + (defn ->java-sig + "(-> Type (Lux Text))" + [^objects type] + (|case type + (&/$Primitive ?name params) + (cond (= &host-type/array-data-tag ?name) (|do [:let [[level base] (unfold-array type)] + base-sig (|case base + (&/$Primitive base-class _) + (return (&host-generics/->type-signature base-class)) + + _ + (->java-sig base))] + (return (str (->> (&/|repeat level "[") (&/fold str "")) + base-sig))) + (= &host-type/null-data-tag ?name) (return (&host-generics/->type-signature "java.lang.Object")) + :else (return (&host-generics/->type-signature ?name))) + + (&/$Function _ _) + (return (&host-generics/->type-signature function-class)) + + (&/$Sum _) + (return object-array) + + (&/$Product _) + (return object-array) + + (&/$Named ?name ?type) + (->java-sig ?type) + + (&/$Apply ?A ?F) + (|do [type* (&type/apply-type ?F ?A)] + (->java-sig type*)) + + (&/$Ex _) + (return ex-type-class) + + _ + (if (&type/type= &type/Any type) + (return "V") + (assert false (str '->java-sig " " (&type/show-type type)))) + ))) + +(do-template [<name> <static?>] + (defn <name> [class-loader target field] + (|let [target-class (Class/forName target true class-loader)] + (if-let [^Type gtype (first (for [^Field =field (seq (.getDeclaredFields target-class)) + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))] + (.getGenericType =field)))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list)] + (return (&/T [gvars gtype]))) + (&/fail-with-loc (str "[Host Error] Field does not exist: " target "." field))))) + + lookup-static-field true + lookup-field false + ) + +(do-template [<name> <static?> <method-type>] + (defn <name> [class-loader target method-name args] + (|let [target-class (Class/forName target true class-loader)] + (if-let [[^Method method ^Class declarer] (first (for [^Method =method (.getDeclaredMethods target-class) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method))) + (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types)))))] + [=method + (.getDeclaringClass =method)]))] + (if (= target-class declarer) + (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list) + gvars (->> method .getTypeParameters seq &/->list) + gargs (->> method .getGenericParameterTypes seq &/->list) + _ (when (.getAnnotation method java.lang.Deprecated) + (println (str "[Host Warning] Deprecated method: " target "." method-name " " (->> args &/->seq print-str))))] + (return (&/T [(.getGenericReturnType method) + (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) + parent-gvars + gvars + gargs]))) + (&/fail-with-loc (str "[Host Error] " <method-type> " method " (pr-str method-name) " for " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")" " belongs to parent " (.getName declarer) " instead of " target))) + (&/fail-with-loc (str "[Host Error] " <method-type> " method does not exist: " target "." method-name " " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")"))))) + + lookup-static-method true "Static" + lookup-virtual-method false "Virtual" + ) + +(defn lookup-constructor [class-loader target args] + (let [target-class (Class/forName target true class-loader)] + (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list) + gargs (->> ctor .getGenericParameterTypes seq &/->list) + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) + _ (when (.getAnnotation ctor java.lang.Deprecated) + (println (str "[Host Warning] Deprecated constructor: " target " " (->> args &/->seq print-str))))] + (return (&/T [exs gvars gargs]))) + (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target " " (->> args &/->seq print-str)))))) + +(defn abstract-methods + "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" + [class-loader super-class] + (|let [[super-name super-params] super-class] + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName super-name true class-loader)) + :when (Modifier/isAbstract (.getModifiers =method))] + (&/T [(.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))])))))) + +(defn def-name [name] + (str (&/normalize-name name) "_" (Long/toUnsignedString (hash name)))) + +(defn location [scope] + (let [scope (&/$Cons (def-name (&/|head scope)) + (&/|map &/normalize-name (&/|tail scope)))] + (->> scope + (&/|interpose "$") + (&/fold str "")))) + +(defn primitive-jvm-type? [type] + (case type + ("boolean" "byte" "short" "int" "long" "float" "double" "char") + true + ;; else + false)) + +(defn dummy-value [^MethodVisitor writer class] + (|case class + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + (.visitLdcInsn false)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + (.visitLdcInsn (byte 0))) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + (.visitLdcInsn (short 0))) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + (.visitLdcInsn (int 0))) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + (.visitLdcInsn (long 0))) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + (.visitLdcInsn (float 0.0))) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + (.visitLdcInsn (double 0.0))) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + (.visitLdcInsn (char 0))) + + _ + (doto writer + (.visitInsn Opcodes/ACONST_NULL)))) + +(defn ^:private dummy-return [^MethodVisitor writer output] + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + (dummy-value output) + (.visitInsn Opcodes/IRETURN)) + + _ + (doto writer + (dummy-value output) + (.visitInsn Opcodes/ARETURN)))) + +(defn ^:private ->dummy-type [real-name store-name gclass] + (|case gclass + (&/$GenericClass _name _params) + (if (= real-name _name) + (&/$GenericClass store-name (&/|map (partial ->dummy-type real-name store-name) _params)) + gclass) + + _ + gclass)) + +(def init-method-name "<init>") + +(defn ^:private dummy-ctor [^MethodVisitor writer real-name store-name super-class ctor-args] + (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature (comp (partial ->dummy-type real-name store-name) &/|first))) (&/fold str ""))] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (-> (doto (dummy-value arg-type) + (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type)) + (->> (when (not (primitive-jvm-type? arg-type)))))) + (->> (doseq [ctor-arg (&/->seq ctor-args) + :let [;; arg-term (&/|first ctor-arg) + arg-type (->dummy-type real-name store-name (&/|first ctor-arg))]]))) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V")) + (.visitInsn Opcodes/RETURN)))) + +(defn ^:private compile-dummy-method [^ClassWriter =class real-name store-name super-class method-def] + (|case method-def + (&/$ConstructorMethodSyntax =privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body) + (|let [=output (&/$GenericClass "void" (&/|list)) + method-decl [init-method-name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + init-method-name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-ctor real-name store-name super-class =ctor-args) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$VirtualMethodSyntax =name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC + (if =final? Opcodes/ACC_FINAL 0)) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$OverridenMethodSyntax =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$StaticMethodSyntax =name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$AbstractMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + (.visitEnd))) + + (&/$NativeMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + (.visitEnd))) + + _ + (assert false (println-str 'compile-dummy-method (&/adt->text method-def))) + )) + +(defn privacy-modifier->flag + "(-> PrivacyModifier Int)" + [privacy-modifier] + (|case privacy-modifier + (&/$PublicPM) Opcodes/ACC_PUBLIC + (&/$PrivatePM) Opcodes/ACC_PRIVATE + (&/$ProtectedPM) Opcodes/ACC_PROTECTED + (&/$DefaultPM) 0 + )) + +(defn state-modifier->flag + "(-> StateModifier Int)" + [state-modifier] + (|case state-modifier + (&/$DefaultSM) 0 + (&/$VolatileSM) Opcodes/ACC_VOLATILE + (&/$FinalSM) Opcodes/ACC_FINAL)) + +(defn inheritance-modifier->flag + "(-> InheritanceModifier Int)" + [inheritance-modifier] + (|case inheritance-modifier + (&/$DefaultIM) 0 + (&/$AbstractIM) Opcodes/ACC_ABSTRACT + (&/$FinalIM) Opcodes/ACC_FINAL)) + +(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] + (|do [module &/get-module-name + :let [[?name ?params] class-decl + dummy-name ?name;; (str ?name "__DUMMY__") + dummy-full-name (str module "/" dummy-name) + real-name (str (&host-generics/->class-name module) "." ?name) + store-name (str (&host-generics/->class-name module) "." dummy-name) + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons super-class interfaces)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + dummy-full-name + (if (= "" class-signature) nil class-signature) + (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) + (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (|case field + (&/$ConstantFieldAnalysis =name =anns =type ?value) + (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) + nil) + (.visitEnd)) + + (&/$VariableFieldAnalysis =name =privacy-modifier =state-modifier =anns =type) + (doto (.visitField =class (+ Opcodes/ACC_PUBLIC (state-modifier->flag =state-modifier)) =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) + nil) + (.visitEnd)) + )) + fields) + _ (&/|map (partial compile-dummy-method =class real-name store-name super-class) methods) + bytecode (.toByteArray (doto =class .visitEnd))] + ^ClassLoader loader &/loader + !classes &/classes + :let [_ (swap! !classes assoc store-name bytecode) + _ (.loadClass loader store-name)] + _ (&/push-dummy-name real-name store-name)] + (return nil))) diff --git a/lux-bootstrapper/src/lux/host/generics.clj b/lux-bootstrapper/src/lux/host/generics.clj new file mode 100644 index 000000000..9e0359760 --- /dev/null +++ b/lux-bootstrapper/src/lux/host/generics.clj @@ -0,0 +1,200 @@ +(ns lux.host.generics + (:require (clojure [string :as string] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]])) + (:import java.util.regex.Pattern)) + +(declare gclass->signature) + +(do-template [<name> <old-sep> <new-sep>] + (let [regex (-> <old-sep> Pattern/quote re-pattern)] + (defn <name> [old] + (string/replace old regex <new-sep>))) + + ;; ->class + ^String ->bytecode-class-name "." "/" + ;; ->class-name + ^String ->class-name "/" "." + ) + +;; ->type-signature +(defn ->type-signature [class] + (case class + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ;; else + (let [class* (->bytecode-class-name class)] + (if (.startsWith class* "[") + class* + (str "L" class* ";"))) + )) + +(defn super-class-name [super] + "(-> GenericSuperClassDecl Text)" + (|let [[super-name super-params] super] + super-name)) + +(defn formal-type-parameter->signature [param] + (|let [[pname pbounds] param] + (|case pbounds + (&/$Nil) + pname + + _ + (->> pbounds + (&/|map (fn [pbound] (str ": " (gclass->signature pbound)))) + (&/|interpose " ") + (str pname " ")) + ))) + +(defn formal-type-parameters->signature [params] + (if (&/|empty? params) + "" + (str "<" (->> params (&/|map formal-type-parameter->signature) (&/|interpose " ") (&/fold str "")) ">"))) + +(defn gclass->signature [super] + "(-> GenericClass Text)" + (|case super + (&/$GenericTypeVar name) + (str "T" name ";") + + (&/$GenericWildcard (&/$None)) + "*" + + (&/$GenericWildcard (&/$Some [(&/$UpperBound) ?bound])) + (str "+" (gclass->signature ?bound)) + + (&/$GenericWildcard (&/$Some [(&/$LowerBound) ?bound])) + (str "-" (gclass->signature ?bound)) + + (&/$GenericClass ^String name params) + (case name + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ;; else + (if (.startsWith name "[") + name + (let [params* (if (&/|empty? params) + "" + (str "<" (->> params (&/|map gclass->signature) (&/|interpose "") (&/fold str "")) ">"))] + (str "L" (->bytecode-class-name name) params* ";")))) + + (&/$GenericArray param) + (str "[" (gclass->signature param)))) + +(defn gsuper-decl->signature [super] + "(-> GenericSuperClassDecl Text)" + (|let [[super-name super-params] super + params* (if (&/|empty? super-params) + "" + (str "<" (->> super-params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">"))] + (str "L" (->bytecode-class-name super-name) params* ";"))) + +(defn gclass-decl->signature [class-decl supers] + "(-> GenericClassDecl (List GenericSuperClassDecl) Text)" + (|let [[class-name class-vars] class-decl + vars-section (formal-type-parameters->signature class-vars) + super-section (->> (&/|map gsuper-decl->signature supers) (&/|interpose " ") (&/fold str ""))] + (str vars-section super-section))) + +(let [object-simple-signature (->type-signature "java.lang.Object")] + (defn gclass->simple-signature [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-simple-signature + + (&/$GenericWildcard _) + object-simple-signature + + (&/$GenericClass name params) + (->type-signature name) + + (&/$GenericArray param) + (str "[" (gclass->simple-signature param)) + + _ + (assert false (str 'gclass->simple-signature " " (&/adt->text gclass)))))) + +(defn gclass->class-name [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + (->bytecode-class-name "java.lang.Object") + + (&/$GenericWildcard _) + (->bytecode-class-name "java.lang.Object") + + (&/$GenericClass name params) + (->bytecode-class-name name) + + (&/$GenericArray param) + (str "[" (gclass->class-name param)) + + _ + (assert false (str 'gclass->class-name " " (&/adt->text gclass))))) + +(let [object-bc-name (->bytecode-class-name "java.lang.Object")] + (defn gclass->bytecode-class-name* [gclass type-env] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-bc-name + + (&/$GenericWildcard _) + object-bc-name + + (&/$GenericClass name params) + ;; When referring to type-parameters during class or method + ;; definition, a type-environment is set for storing the names + ;; of such parameters. + ;; When a "class" shows up with the name of one of those + ;; parameters, it must be detected, and the bytecode class-name + ;; must correspond to Object's. + (if (&/|get name type-env) + object-bc-name + (->bytecode-class-name name)) + + (&/$GenericArray param) + (assert false "gclass->bytecode-class-name* does not work on arrays.")))) + +(let [object-bc-name (->bytecode-class-name "java.lang.Object")] + (defn gclass->bytecode-class-name [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar name) + object-bc-name + + (&/$GenericWildcard _) + object-bc-name + + (&/$GenericClass name params) + (->bytecode-class-name name) + + (&/$GenericArray param) + (assert false "gclass->bytecode-class-name does not work on arrays.")))) + +(defn method-signatures [method-decl] + (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl + simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output)) + generic-signature (str (formal-type-parameters->signature =gvars) + "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")" + (gclass->signature =output) + (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] + (&/T [simple-signature generic-signature]))) diff --git a/lux-bootstrapper/src/lux/lexer.clj b/lux-bootstrapper/src/lux/lexer.clj new file mode 100644 index 000000000..49e29710a --- /dev/null +++ b/lux-bootstrapper/src/lux/lexer.clj @@ -0,0 +1,137 @@ +(ns lux.lexer + (:require (clojure [template :refer [do-template]] + [string :as string]) + (lux [base :as & :refer [defvariant |do return* return |case]] + [reader :as &reader]) + [lux.analyser.module :as &module])) + +;; [Tags] +(defvariant + ("White_Space" 1) + ("Comment" 1) + ("Bit" 1) + ("Nat" 1) + ("Int" 1) + ("Rev" 1) + ("Frac" 1) + ("Text" 1) + ("Identifier" 1) + ("Tag" 1) + ("Open_Paren" 0) + ("Close_Paren" 0) + ("Open_Bracket" 0) + ("Close_Bracket" 0) + ("Open_Brace" 0) + ("Close_Brace" 0) + ) + +;; [Utils] +(def lex-text + (|do [[meta _ _] (&reader/read-text "\"") + :let [[_ _ _column] meta] + [_ _ ^String content] (&reader/read-regex #"^([^\"]*)") + _ (&reader/read-text "\"")] + (return (&/T [meta ($Text content)])))) + +(def +ident-re+ + #"^([^0-9\[\]\{\}\(\)\s\"#.][^\[\]\{\}\(\)\s\"#.]*)") + +;; [Lexers] +(def ^:private lex-white-space + (|do [[meta _ white-space] (&reader/read-regex #"^(\s+|$)")] + (return (&/T [meta ($White_Space white-space)])))) + +(def ^:private lex-comment + (|do [_ (&reader/read-text "##") + [meta _ comment] (&reader/read-regex #"^(.*)$")] + (return (&/T [meta ($Comment comment)])))) + +(do-template [<name> <tag> <regex>] + (def <name> + (|do [[meta _ token] (&reader/read-regex <regex>)] + (return (&/T [meta (<tag> token)])))) + + lex-bit $Bit #"^#(0|1)" + ) + +(do-template [<name> <tag> <regex>] + (def <name> + (|do [[meta _ token] (&reader/read-regex <regex>)] + (return (&/T [meta (<tag> (string/replace token #"," ""))])))) + + lex-nat $Nat #"^[0-9][0-9,]*" + lex-int $Int #"^(-|\+)[0-9][0-9,]*" + lex-rev $Rev #"^\.[0-9][0-9,]*" + lex-frac $Frac #"^(-|\+)[0-9][0-9,]*\.[0-9][0-9,]*((e|E)(-|\+)[0-9][0-9,]*)?" + ) + +(def +same-module-mark+ (str &/+name-separator+ &/+name-separator+)) + +(def ^:private lex-ident + (&/try-all-% "[Reader Error]" + (&/|list (|do [[meta _ token] (&reader/read-regex +ident-re+) + [_ _ got-it?] (&reader/read-text? &/+name-separator+)] + (|case got-it? + (&/$Some _) + (|do [[_ _ local-token] (&reader/read-regex +ident-re+) + ? (&module/exists? token)] + (if ? + (return (&/T [meta (&/T [token local-token])])) + (|do [unaliased (&module/dealias token)] + (return (&/T [meta (&/T [unaliased local-token])]))))) + + (&/$None) + (return (&/T [meta (&/T ["" token])])))) + (|do [[meta _ _] (&reader/read-text +same-module-mark+) + [_ _ token] (&reader/read-regex +ident-re+) + module-name &/get-module-name] + (return (&/T [meta (&/T [module-name token])]))) + (|do [[meta _ _] (&reader/read-text &/+name-separator+) + [_ _ token] (&reader/read-regex +ident-re+)] + (return (&/T [meta (&/T [&/prelude token])]))) + ))) + +(def ^:private lex-identifier + (|do [[meta ident] lex-ident] + (return (&/T [meta ($Identifier ident)])))) + +(def ^:private lex-tag + (|do [[meta _ _] (&reader/read-text "#") + [_ ident] lex-ident] + (return (&/T [meta ($Tag ident)])))) + +(do-template [<name> <text> <tag>] + (def <name> + (|do [[meta _ _] (&reader/read-text <text>)] + (return (&/T [meta <tag>])))) + + ^:private lex-open-paren "(" $Open_Paren + ^:private lex-close-paren ")" $Close_Paren + ^:private lex-open-bracket "[" $Open_Bracket + ^:private lex-close-bracket "]" $Close_Bracket + ^:private lex-open-brace "{" $Open_Brace + ^:private lex-close-brace "}" $Close_Brace + ) + +(def ^:private lex-delimiter + (&/try-all% (&/|list lex-open-paren + lex-close-paren + lex-open-bracket + lex-close-bracket + lex-open-brace + lex-close-brace))) + +;; [Exports] +(def lex + (&/try-all-% "[Reader Error]" + (&/|list lex-white-space + lex-comment + lex-bit + lex-nat + lex-frac + lex-rev + lex-int + lex-text + lex-identifier + lex-tag + lex-delimiter))) diff --git a/lux-bootstrapper/src/lux/lib/loader.clj b/lux-bootstrapper/src/lux/lib/loader.clj new file mode 100644 index 000000000..97e6ee684 --- /dev/null +++ b/lux-bootstrapper/src/lux/lib/loader.clj @@ -0,0 +1,42 @@ +(ns lux.lib.loader + (:refer-clojure :exclude [load]) + (:require (lux [base :as & :refer [|let |do return return* |case]])) + (:import (java.io InputStream + File + FileInputStream + ByteArrayInputStream + ByteArrayOutputStream) + java.util.jar.JarInputStream)) + +;; [Utils] +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private unpackage [^File lib-file] + (let [is (->> lib-file + (new FileInputStream) + (new JarInputStream))] + (loop [lib-data {} + entry (.getNextJarEntry is)] + (if entry + (if (.endsWith (.getName entry) ".lux") + (recur (assoc lib-data (.getName entry) (new String (read-stream is))) + (.getNextJarEntry is)) + (recur lib-data + (.getNextJarEntry is))) + lib-data)))) + +;; [Exports] +(defn load [dependencies] + (->> dependencies + &/->seq + (map #(->> ^String % (new File) unpackage)) + (reduce merge {}))) diff --git a/lux-bootstrapper/src/lux/optimizer.clj b/lux-bootstrapper/src/lux/optimizer.clj new file mode 100644 index 000000000..6e235e084 --- /dev/null +++ b/lux-bootstrapper/src/lux/optimizer.clj @@ -0,0 +1,1150 @@ +(ns lux.optimizer + (:require (lux [base :as & :refer [|let |do return return* |case defvariant]]) + (lux.analyser [base :as &a] + [case :as &a-case]))) + +;; [Tags] +(defvariant + ;; These tags just have a one-to-one correspondence with Analysis data-structures. + ("bit" 1) + ("nat" 1) + ("int" 1) + ("rev" 1) + ("frac" 1) + ("text" 1) + ("variant" 3) + ("tuple" 1) + ("apply" 2) + ("case" 2) + ("function" 5) + ("ann" 2) + ("def" 1) + ("var" 1) + ("captured" 3) + ("proc" 3) + + ;; These other tags represent higher-order constructs that manifest + ;; themselves as patterns in the code. + ;; Lux does not formally provide these features, but some macros + ;; expose ways to implement them in terms of the other (primitive) + ;; features. + ;; The optimizer looks for those usage patterns and transforms them + ;; into explicit constructs, which are then subject to specialized optimizations. + + ;; Loop scope, for doing loop inlining + ("loop" 3) ;; {register-offset Int, inits (List Optimized), body Optimized} + ;; This is loop iteration, as expected in imperative programming. + ("iter" 2) ;; {register-offset Int, vals (List Optimized)} + ;; This is a simple let-expression, as opposed to the more general pattern-matching. + ("let" 3) + ;; This is an access to a record's member. It can be multi-level: + ;; e.g. record.l1.l2.l3 + ;; The record-get token stores the path, for simpler compilation. + ("record-get" 2) + ;; Regular, run-of-the-mill if expressions. + ("if" 3) + ) + +;; [Utils] + +;; [[Pattern-Matching Traversal Optimization]] + +;; This represents an alternative way to view pattern-matching. +;; The PM that Lux provides has declarative semantics, with the user +;; specifying how his data is shaped, but not how to traverse it. +;; The optimizer's PM is operational in nature, and relies on +;; specifying a path of traversal, with a variety of operations that +;; can be done along the way. +;; The algorithm relies on looking at pattern-matching as traversing a +;; (possibly) branching path, where each step along the path +;; corresponds to a value, the ends of the path are the jumping-off +;; points for the bodies of branches, and branching decisions can be +;; backtracked, if they do not result in a valid jump. +(defvariant + ;; Throw away the current data-node (CDN). It's useless. + ("PopPM" 0) + ;; Store the CDN in a register. + ("BindPM" 1) + ;; Compare the CDN with a bit value. + ("BitPM" 1) + ;; Compare the CDN with a natural value. + ("NatPM" 1) + ;; Compare the CDN with an integer value. + ("IntPM" 1) + ;; Compare the CDN with a revolution value. + ("RevPM" 1) + ;; Compare the CDN with a frac value. + ("FracPM" 1) + ;; Compare the CDN with a text value. + ("TextPM" 1) + ;; Compare the CDN with a variant value. If valid, proceed to test + ;; the variant's inner value. + ("VariantPM" 1) + ;; Access a tuple value at a given index, for further examination. + ("TuplePM" 1) + ;; Creates an instance of the backtracking info, as a preparatory + ;; step to exploring one of the branching paths. + ("AltPM" 2) + ;; Allows to test the CDN, while keeping a copy of it for more + ;; tasting later on. + ;; If necessary when doing multiple tests on a single value, like + ;; when testing multiple parts of a tuple. + ("SeqPM" 2) + ;; This is the jumping-off point for the PM part, where the PM + ;; data-structure is thrown away and the program jumps to the + ;; branch's body. + ("ExecPM" 1)) + +(defn de-meta + "(-> Optimized Optimized)" + [optim] + (|let [[meta optim-] optim] + (|case optim- + ($variant idx is-last? value) + ($variant idx is-last? (de-meta value)) + + ($tuple elems) + ($tuple (&/|map de-meta elems)) + + ($case value [_pm _bodies]) + ($case (de-meta value) + (&/T [_pm (&/|map de-meta _bodies)])) + + ($function _register-offset arity scope captured body*) + ($function _register-offset + arity + scope + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + (&/T [_name ($captured _scope _idx (de-meta _source))]))) + captured) + (de-meta body*)) + + ($ann value-expr type-expr) + (de-meta value-expr) + + ($apply func args) + ($apply (de-meta func) + (&/|map de-meta args)) + + ($captured scope idx source) + ($captured scope idx (de-meta source)) + + ($proc proc-ident args special-args) + ($proc proc-ident (&/|map de-meta args) special-args) + + ($loop _register-offset _inits _body) + ($loop _register-offset + (&/|map de-meta _inits) + (de-meta _body)) + + ($iter _iter-register-offset args) + ($iter _iter-register-offset + (&/|map de-meta args)) + + ($let _value _register _body) + ($let (de-meta _value) + _register + (de-meta _body)) + + ($record-get _value _path) + ($record-get (de-meta _value) + _path) + + ($if _test _then _else) + ($if (de-meta _test) + (de-meta _then) + (de-meta _else)) + + _ + optim- + ))) + +;; This function does a simple transformation from the declarative +;; model of PM of the analyser, to the operational model of PM of the +;; optimizer. +;; You may notice that all branches end in PopPM. +;; The reason is that testing does not immediately imply throwing away +;; the data to be tested, which is why a popping step must immediately follow. +(defn ^:private transform-pm* [test] + (|case test + (&a-case/$NoTestAC) + (&/|list $PopPM) + + (&a-case/$StoreTestAC _register) + (&/|list ($BindPM _register)) + + (&a-case/$BitTestAC _value) + (&/|list ($BitPM _value) + $PopPM) + + (&a-case/$NatTestAC _value) + (&/|list ($NatPM _value) + $PopPM) + + (&a-case/$IntTestAC _value) + (&/|list ($IntPM _value) + $PopPM) + + (&a-case/$RevTestAC _value) + (&/|list ($RevPM _value) + $PopPM) + + (&a-case/$FracTestAC _value) + (&/|list ($FracPM _value) + $PopPM) + + (&a-case/$TextTestAC _value) + (&/|list ($TextPM _value) + $PopPM) + + (&a-case/$VariantTestAC _idx _num-options _sub-test) + (&/|++ (&/|list ($VariantPM (if (= _idx (dec _num-options)) + (&/$Right _idx) + (&/$Left _idx)))) + (&/|++ (transform-pm* _sub-test) + (&/|list $PopPM))) + + (&a-case/$TupleTestAC _sub-tests) + (|case _sub-tests + ;; An empty tuple corresponds to unit, which cannot be tested in + ;; any meaningful way, so it's just popped. + (&/$Nil) + (&/|list $PopPM) + + ;; A tuple of a single element is equivalent to the element + ;; itself, to the element's PM is generated. + (&/$Cons _only-test (&/$Nil)) + (transform-pm* _only-test) + + ;; Single tuple PM features the tests of each tuple member + ;; inlined, it's operational equivalent is interleaving the + ;; access to each tuple member, followed by the testing of said + ;; member. + ;; That is way each sequence of access+subtesting gets generated + ;; and later they all get concatenated. + _ + (|let [tuple-size (&/|length _sub-tests)] + (&/|++ (&/flat-map (fn [idx+test*] + (|let [[idx test*] idx+test*] + (&/$Cons ($TuplePM (if (< idx (dec tuple-size)) + (&/$Left idx) + (&/$Right idx))) + (transform-pm* test*)))) + (&/zip2 (&/|range tuple-size) + _sub-tests)) + (&/|list $PopPM)))))) + +;; It will be common for pattern-matching on a very nested +;; data-structure to require popping all the intermediate +;; data-structures that were visited once it's all done. +;; However, the PM infrastructure employs a single data-stack to keep +;; all data nodes in the trajectory, and that data-stack can just be +;; thrown again entirely, in just one step. +;; Because of that, any ending POPs prior to throwing away the +;; data-stack would be completely useless. +;; This function cleans them all up, to avoid wasteful computation later. +(defn ^:private clean-unnecessary-pops [steps] + (|case steps + (&/$Cons ($PopPM) _steps) + (clean-unnecessary-pops _steps) + + _ + steps)) + +;; This transforms a single branch of a PM tree into it's operational +;; equivalent, while also associating the PM of the branch with the +;; jump to the branch's body. +(defn ^:private transform-pm [test body-id] + (&/fold (fn [right left] ($SeqPM left right)) + ($ExecPM body-id) + (clean-unnecessary-pops (&/|reverse (transform-pm* test))))) + +;; This function fuses together the paths of the PM traversal, adding +;; branching AltPMs where necessary, and fusing similar paths together +;; as much as possible, when early parts of them coincide. +;; The goal is to minimize rework as much as possible by sharing as +;; much of each path as possible. +(defn ^:private fuse-pms [pre post] + (|case (&/T [pre post]) + [($PopPM) ($PopPM)] + $PopPM + + [($BindPM _pre-var-id) ($BindPM _post-var-id)] + (if (= _pre-var-id _post-var-id) + ($BindPM _pre-var-id) + ($AltPM pre post)) + + [($BitPM _pre-value) ($BitPM _post-value)] + (if (= _pre-value _post-value) + ($BitPM _pre-value) + ($AltPM pre post)) + + [($NatPM _pre-value) ($NatPM _post-value)] + (if (= _pre-value _post-value) + ($NatPM _pre-value) + ($AltPM pre post)) + + [($IntPM _pre-value) ($IntPM _post-value)] + (if (= _pre-value _post-value) + ($IntPM _pre-value) + ($AltPM pre post)) + + [($RevPM _pre-value) ($RevPM _post-value)] + (if (= _pre-value _post-value) + ($RevPM _pre-value) + ($AltPM pre post)) + + [($FracPM _pre-value) ($FracPM _post-value)] + (if (= _pre-value _post-value) + ($FracPM _pre-value) + ($AltPM pre post)) + + [($TextPM _pre-value) ($TextPM _post-value)] + (if (= _pre-value _post-value) + ($TextPM _pre-value) + ($AltPM pre post)) + + [($TuplePM (&/$Left _pre-idx)) ($TuplePM (&/$Left _post-idx))] + (if (= _pre-idx _post-idx) + ($TuplePM (&/$Left _pre-idx)) + ($AltPM pre post)) + + [($TuplePM (&/$Right _pre-idx)) ($TuplePM (&/$Right _post-idx))] + (if (= _pre-idx _post-idx) + ($TuplePM (&/$Right _pre-idx)) + ($AltPM pre post)) + + [($VariantPM (&/$Left _pre-idx)) ($VariantPM (&/$Left _post-idx))] + (if (= _pre-idx _post-idx) + ($VariantPM (&/$Left _pre-idx)) + ($AltPM pre post)) + + [($VariantPM (&/$Right _pre-idx)) ($VariantPM (&/$Right _post-idx))] + (if (= _pre-idx _post-idx) + ($VariantPM (&/$Right _pre-idx)) + ($AltPM pre post)) + + [($SeqPM _pre-pre _pre-post) ($SeqPM _post-pre _post-post)] + (|case (fuse-pms _pre-pre _post-pre) + ($AltPM _ _) + ($AltPM pre post) + + fused-pre + ($SeqPM fused-pre (fuse-pms _pre-post _post-post))) + + _ + ($AltPM pre post) + )) + +(defn ^:private pattern-vars [pattern] + (|case pattern + ($BindPM _id) + (&/|list (&/T [_id false])) + + ($SeqPM _left _right) + (&/|++ (pattern-vars _left) (pattern-vars _right)) + + _ + (&/|list) + + ;; $AltPM is not considered because it's not supposed to be + ;; present anywhere at this point in time. + )) + +(defn ^:private find-unused-vars [var-table body] + (|let [[meta body-] body] + (|case body- + ($var (&/$Local _idx)) + (&/|update _idx (fn [_] true) var-table) + + ($captured _scope _c-idx [_ ($var (&/$Local _idx))]) + (&/|update _idx (fn [_] true) var-table) + + ($variant _idx _is-last? _value) + (find-unused-vars var-table _value) + + ($tuple _elems) + (&/fold find-unused-vars var-table _elems) + + ($ann _value-expr _type-expr) + (find-unused-vars var-table _value-expr) + + ($apply _func _args) + (&/fold find-unused-vars + (find-unused-vars var-table _func) + _args) + + ($proc _proc-ident _args _special-args) + (&/fold find-unused-vars var-table _args) + + ($loop _register-offset _inits _body) + (&/|++ (&/fold find-unused-vars var-table _inits) + (find-unused-vars var-table _body)) + + ($iter _ _args) + (&/fold find-unused-vars var-table _args) + + ($let _value _register _body) + (-> var-table + (find-unused-vars _value) + (find-unused-vars _body)) + + ($record-get _value _path) + (find-unused-vars var-table _value) + + ($if _test _then _else) + (-> var-table + (find-unused-vars _test) + (find-unused-vars _then) + (find-unused-vars _else)) + + ($case _value [_pm _bodies]) + (&/fold find-unused-vars + (find-unused-vars var-table _value) + _bodies) + + ($function _ _ _ _captured _) + (->> _captured + (&/|map &/|second) + (&/fold find-unused-vars var-table)) + + _ + var-table + ))) + +(defn ^:private clean-unused-pattern-registers [var-table pattern] + (|case pattern + ($BindPM _idx) + (|let [_new-idx (&/|get _idx var-table)] + (cond (= _idx _new-idx) + pattern + + (>= _new-idx 0) + ($BindPM _new-idx) + + :else + $PopPM)) + + ($SeqPM _left _right) + ($SeqPM (clean-unused-pattern-registers var-table _left) + (clean-unused-pattern-registers var-table _right)) + + _ + pattern + + ;; $AltPM is not considered because it's not supposed to be + ;; present anywhere at this point in time. + )) + +;; This function assumes that the var-table has an ascending index +;; order. +;; For example: (2 3 4 5 6 7 8), instead of (8 7 6 5 4 3 2) +(defn ^:private adjust-register-indexes* [offset var-table] + (|case var-table + (&/$Nil) + (&/|list) + + (&/$Cons [_idx _used?] _tail) + (if _used? + (&/$Cons (&/T [_idx (- _idx offset)]) + (adjust-register-indexes* offset _tail)) + (&/$Cons (&/T [_idx -1]) + (adjust-register-indexes* (inc offset) _tail)) + ))) + +(defn ^:private adjust-register-indexes [var-table] + (adjust-register-indexes* 0 var-table)) + +(defn ^:private clean-unused-body-registers [var-table body] + (|let [[meta body-] body] + (|case body- + ($var (&/$Local _idx)) + (|let [new-idx (or (&/|get _idx var-table) + _idx)] + (&/T [meta ($var (&/$Local new-idx))])) + + ($captured _scope _c-idx [_sub-meta ($var (&/$Local _idx))]) + (|let [new-idx (or (&/|get _idx var-table) + _idx)] + (&/T [meta ($captured _scope _c-idx (&/T [_sub-meta ($var (&/$Local new-idx))]))])) + + ($variant _idx _is-last? _value) + (&/T [meta ($variant _idx _is-last? (clean-unused-body-registers var-table _value))]) + + ($tuple _elems) + (&/T [meta ($tuple (&/|map (partial clean-unused-body-registers var-table) + _elems))]) + + ($ann _value-expr _type-expr) + (&/T [meta ($ann (clean-unused-body-registers var-table _value-expr) _type-expr)]) + + ($apply _func _args) + (&/T [meta ($apply (clean-unused-body-registers var-table _func) + (&/|map (partial clean-unused-body-registers var-table) + _args))]) + + ($proc _proc-ident _args _special-args) + (&/T [meta ($proc _proc-ident + (&/|map (partial clean-unused-body-registers var-table) + _args) + _special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop _register-offset + (&/|map (partial clean-unused-body-registers var-table) + _inits) + (clean-unused-body-registers var-table _body))]) + + ($iter _iter-register-offset _args) + (&/T [meta ($iter _iter-register-offset + (&/|map (partial clean-unused-body-registers var-table) + _args))]) + + ($let _value _register _body) + (&/T [meta ($let (clean-unused-body-registers var-table _value) + _register + (clean-unused-body-registers var-table _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (clean-unused-body-registers var-table _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (clean-unused-body-registers var-table _test) + (clean-unused-body-registers var-table _then) + (clean-unused-body-registers var-table _else))]) + + ($case _value [_pm _bodies]) + (&/T [meta ($case (clean-unused-body-registers var-table _value) + (&/T [_pm + (&/|map (partial clean-unused-body-registers var-table) + _bodies)]))]) + + ($function _register-offset _arity _scope _captured _body) + (&/T [meta ($function _register-offset + _arity + _scope + (&/|map (fn [capture] + (|let [[_name __var] capture] + (&/T [_name (clean-unused-body-registers var-table __var)]))) + _captured) + _body)]) + + _ + body + ))) + +(defn ^:private simplify-pattern [pattern] + (|case pattern + ($SeqPM ($TuplePM _idx) ($SeqPM ($PopPM) pattern*)) + (simplify-pattern pattern*) + + ($SeqPM ($TuplePM _idx) _right) + (|case (simplify-pattern _right) + ($SeqPM ($PopPM) pattern*) + pattern* + + _right* + ($SeqPM ($TuplePM _idx) _right*)) + + ($SeqPM _left _right) + ($SeqPM _left (simplify-pattern _right)) + + _ + pattern)) + +(defn ^:private optimize-register-use [pattern body] + (|let [p-vars (pattern-vars pattern) + p-vars* (find-unused-vars p-vars body) + adjusted-vars (adjust-register-indexes p-vars*) + clean-pattern (clean-unused-pattern-registers adjusted-vars pattern) + simple-pattern (simplify-pattern clean-pattern) + clean-body (clean-unused-body-registers adjusted-vars body)] + (&/T [simple-pattern clean-body]))) + +;; This is the top-level function for optimizing PM, which transforms +;; each branch and then fuses them together. +(defn ^:private optimize-pm [branches] + (|let [;; branches (&/|reverse branches*) + pms+bodies (&/map2 (fn [branch _body-id] + (|let [[_pattern _body] branch] + (optimize-register-use (transform-pm _pattern _body-id) + _body))) + branches + (&/|range (&/|length branches))) + pms (&/|map &/|first pms+bodies) + bodies (&/|map &/|second pms+bodies)] + (|case (&/|reverse pms) + (&/$Nil) + (assert false) + + (&/$Cons _head-pm _tail-pms) + (&/T [(&/fold fuse-pms _head-pm _tail-pms) + bodies]) + ))) + +;; [[Function-Folding Optimization]] + +;; The semantics of Lux establish that all functions are of a single +;; argument and the multi-argument functions are actually nested +;; functions being generated and then applied. +;; This, of course, would generate a lot of waste. +;; To avoid it, Lux actually folds function definitions together, +;; thereby creating functions that can be used both +;; one-argument-at-a-time, and also being called with all, or just a +;; partial amount of their arguments. +;; This avoids generating too many artifacts during compilation, since +;; they get "compressed", and it can also lead to faster execution, by +;; enabling optimized function calls later. + +;; Functions and captured variables have "scopes", which tell which +;; function they are, or to which function they belong. +;; During the folding, inner functions dissapear, since their bodies +;; are merged into their outer "parent" functions. +;; Their scopes must change accordingy. +(defn ^:private de-scope + "(-> Scope Scope Scope Scope)" + [old-scope new-scope scope] + (if (identical? new-scope scope) + old-scope + scope)) + +;; Also, it must be noted that when folding functions, the indexes of +;; the registers have to be changed accodingly. +;; That is what the following "shifting" functions are for. + +;; Shifts the registers for PM operations. +(defn ^:private shift-pattern [pattern] + (|case pattern + ($BindPM _var-id) + ($BindPM (inc _var-id)) + + ($SeqPM _left-pm _right-pm) + ($SeqPM (shift-pattern _left-pm) (shift-pattern _right-pm)) + + ($AltPM _left-pm _right-pm) + ($AltPM (shift-pattern _left-pm) (shift-pattern _right-pm)) + + _ + pattern + )) + +;; Shifts the body of a function after a folding is performed. +(defn shift-function-body + "(-> Scope Scope Bit Optimized Optimized)" + [old-scope new-scope own-body? body] + (|let [[meta body-] body] + (|case body- + ($variant idx is-last? value) + (&/T [meta ($variant idx is-last? (shift-function-body old-scope new-scope own-body? value))]) + + ($tuple elems) + (&/T [meta ($tuple (&/|map (partial shift-function-body old-scope new-scope own-body?) elems))]) + + ($case value [_pm _bodies]) + (&/T [meta ($case (shift-function-body old-scope new-scope own-body? value) + (&/T [(if own-body? + (shift-pattern _pm) + _pm) + (&/|map (partial shift-function-body old-scope new-scope own-body?) _bodies)]))]) + + ($function _register-offset arity scope captured body*) + (|let [scope* (de-scope old-scope new-scope scope)] + (&/T [meta ($function _register-offset + arity + scope* + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + (&/T [_name (&/T [_meta ($captured scope* _idx (shift-function-body old-scope new-scope own-body? _source))])]))) + captured) + (shift-function-body old-scope new-scope false body*))])) + + ($ann value-expr type-expr) + (&/T [meta ($ann (shift-function-body old-scope new-scope own-body? value-expr) + type-expr)]) + + ($var var-kind) + (if own-body? + (|case var-kind + (&/$Local 0) + (&/T [meta ($apply body + (&/|list (&/T [meta ($var (&/$Local 1))])))]) + + (&/$Local idx) + (&/T [meta ($var (&/$Local (inc idx)))])) + body) + + ;; This special "apply" rule is for handling recursive calls better. + ($apply [meta-0 ($var (&/$Local 0))] args) + (if own-body? + (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) + (&/$Cons (&/T [meta-0 ($var (&/$Local 1))]) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args)))]) + (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])) + + ($apply func args) + (&/T [meta ($apply (shift-function-body old-scope new-scope own-body? func) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) + + ($captured scope idx source) + (if own-body? + source + (|case scope + (&/$Cons _ (&/$Cons _ (&/$Nil))) + source + + _ + (&/T [meta ($captured (de-scope old-scope new-scope scope) idx (shift-function-body old-scope new-scope own-body? source))]))) + + ($proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body old-scope new-scope own-body?) args) special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop (if own-body? + (inc _register-offset) + _register-offset) + (&/|map (partial shift-function-body old-scope new-scope own-body?) + _inits) + (shift-function-body old-scope new-scope own-body? _body))]) + + ($iter _iter-register-offset args) + (&/T [meta ($iter (if own-body? + (inc _iter-register-offset) + _iter-register-offset) + (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) + + ($let _value _register _body) + (&/T [meta ($let (shift-function-body old-scope new-scope own-body? _value) + (if own-body? + (inc _register) + _register) + (shift-function-body old-scope new-scope own-body? _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (shift-function-body old-scope new-scope own-body? _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (shift-function-body old-scope new-scope own-body? _test) + (shift-function-body old-scope new-scope own-body? _then) + (shift-function-body old-scope new-scope own-body? _else))]) + + _ + body + ))) + +;; [[Record-Manipulation Optimizations]] + +;; If a pattern-matching tree with a single branch is found, and that +;; branch corresponds to a tuple PM, and the body corresponds to a +;; local variable, it's likely that the local refers to some member of +;; the tuple that is being extracted. +;; That is the pattern that is to be expected of record read-access, +;; so this function tries to extract the (possibly nested) path +;; necessary, ending in the data-node of the wanted member. +(defn ^:private record-read-path + "(-> (List PM) Idx (List Idx))" + [pms member-idx] + (loop [current-idx 0 + pms pms] + (|case pms + (&/$Nil) + &/$None + + (&/$Cons _pm _pms) + (|case _pm + (&a-case/$NoTestAC) + (recur (inc current-idx) + _pms) + + (&a-case/$StoreTestAC _register) + (if (= member-idx _register) + (&/|list (&/T [current-idx (&/|empty? _pms)])) + (recur (inc current-idx) + _pms)) + + (&a-case/$TupleTestAC _sub-tests) + (let [sub-path (record-read-path _sub-tests member-idx)] + (if (not (&/|empty? sub-path)) + (&/$Cons (&/T [current-idx (&/|empty? _pms)]) sub-path) + (recur (inc current-idx) + _pms) + )) + + _ + (&/|list)) + ))) + +;; [[Loop Optimizations]] + +;; Lux does not offer any looping constructs, relying instead on +;; recursion. +;; Some common usages of recursion can be written more efficiently +;; just using regular loops/iteration. +;; This optimization looks for tail-calls in the function body, +;; rewriting them as jumps to the beginning of the function, while +;; they also updated the necessary local variables for the next iteration. +(defn ^:private optimize-iter + "(-> Int Optimized Optimized)" + [arity optim] + (|let [[meta optim-] optim] + (|case optim- + ($apply [meta-0 ($var (&/$Local 0))] _args) + (if (= arity (&/|length _args)) + (&/T [meta ($iter 1 _args)]) + optim) + + ($case _value [_pattern _bodies]) + (&/T [meta ($case _value + (&/T [_pattern + (&/|map (partial optimize-iter arity) + _bodies)]))]) + + ($let _value _register _body) + (&/T [meta ($let _value _register (optimize-iter arity _body))]) + + ($if _test _then _else) + (&/T [meta ($if _test + (optimize-iter arity _then) + (optimize-iter arity _else))]) + + ($ann _value-expr _type-expr) + (&/T [meta ($ann (optimize-iter arity _value-expr) _type-expr)]) + + _ + optim + ))) + +(defn ^:private contains-self-reference? + "(-> Optimized Bit)" + [body] + (|let [[meta body-] body + stepwise-test (fn [base arg] (or base (contains-self-reference? arg)))] + (|case body- + ($variant idx is-last? value) + (contains-self-reference? value) + + ($tuple elems) + (&/fold stepwise-test false elems) + + ($case value [_pm _bodies]) + (or (contains-self-reference? value) + (&/fold stepwise-test false _bodies)) + + ($function _ _ _ captured _) + (->> captured + (&/|map (fn [capture] + (|let [[_name [_meta ($captured _scope _idx _source)]] capture] + _source))) + (&/fold stepwise-test false)) + + ($ann value-expr type-expr) + (contains-self-reference? value-expr) + + ($var (&/$Local 0)) + true + + ($apply func args) + (or (contains-self-reference? func) + (&/fold stepwise-test false args)) + + ($proc proc-ident args special-args) + (&/fold stepwise-test false args) + + ($loop _register-offset _inits _body) + (or (&/fold stepwise-test false _inits) + (contains-self-reference? _body)) + + ($iter _ args) + (&/fold stepwise-test false args) + + ($let _value _register _body) + (or (contains-self-reference? _value) + (contains-self-reference? _body)) + + ($record-get _value _path) + (contains-self-reference? _value) + + ($if _test _then _else) + (or (contains-self-reference? _test) + (contains-self-reference? _then) + (contains-self-reference? _else)) + + _ + false + ))) + +(defn ^:private pm-loop-transform [register-offset direct? pattern] + (|case pattern + ($BindPM _var-id) + ($BindPM (+ register-offset (if direct? + (- _var-id 2) + (- _var-id 1)))) + + ($SeqPM _left-pm _right-pm) + ($SeqPM (pm-loop-transform register-offset direct? _left-pm) + (pm-loop-transform register-offset direct? _right-pm)) + + ($AltPM _left-pm _right-pm) + ($AltPM (pm-loop-transform register-offset direct? _left-pm) + (pm-loop-transform register-offset direct? _right-pm)) + + _ + pattern + )) + +;; This function must be run STRICTLY before shift-function body, as +;; the transformation assumes that SFB will be invoke after it. +(defn ^:private loop-transform [register-offset direct? body] + (|let [adjust-direct (fn [register] + ;; The register must be decreased once, since + ;; it will be re-increased in + ;; shift-function-body. + ;; The decrease is meant to keep things stable. + (if direct? + ;; And, if this adjustment is done + ;; directly during a loop-transform (and + ;; not indirectly if transforming an inner + ;; loop), then it must be decreased again + ;; because the 0/self var will no longer + ;; exist in the loop's context. + (- register 2) + (- register 1))) + [meta body-] body] + (|case body- + ($variant idx is-last? value) + (&/T [meta ($variant idx is-last? (loop-transform register-offset direct? value))]) + + ($tuple elems) + (&/T [meta ($tuple (&/|map (partial loop-transform register-offset direct?) elems))]) + + ($case value [_pm _bodies]) + (&/T [meta ($case (loop-transform register-offset direct? value) + (&/T [(pm-loop-transform register-offset direct? _pm) + (&/|map (partial loop-transform register-offset direct?) + _bodies)]))]) + + ;; Functions are ignored because they'll be handled properly at shift-function-body + + ($ann value-expr type-expr) + (&/T [meta ($ann (loop-transform register-offset direct? value-expr) + type-expr)]) + + ($var (&/$Local idx)) + ;; The index must be decreased once, because the var index is + ;; 1-based (since 0 is reserved for self-reference). + ;; Then it must be decreased again, since it will be increased + ;; in the shift-function-body call. + ;; Then, I add the offset to ensure the var points to the right register. + (&/T [meta ($var (&/$Local (-> (adjust-direct idx) + (+ register-offset))))]) + + ($apply func args) + (&/T [meta ($apply (loop-transform register-offset direct? func) + (&/|map (partial loop-transform register-offset direct?) args))]) + + ;; Captured-vars are ignored because they'll be handled properly at shift-function-body + + ($proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset direct?) args) special-args)]) + + ($loop _register-offset _inits _body) + (&/T [meta ($loop (+ register-offset (adjust-direct _register-offset)) + (&/|map (partial loop-transform register-offset direct?) _inits) + (loop-transform register-offset direct? _body))]) + + ($iter _iter-register-offset args) + (&/T [meta ($iter (+ register-offset (adjust-direct _iter-register-offset)) + (&/|map (partial loop-transform register-offset direct?) args))]) + + ($let _value _register _body) + (&/T [meta ($let (loop-transform register-offset direct? _value) + (+ register-offset (adjust-direct _register)) + (loop-transform register-offset direct? _body))]) + + ($record-get _value _path) + (&/T [meta ($record-get (loop-transform register-offset direct? _value) + _path)]) + + ($if _test _then _else) + (&/T [meta ($if (loop-transform register-offset direct? _test) + (loop-transform register-offset direct? _then) + (loop-transform register-offset direct? _else))]) + + _ + body + ))) + +(defn ^:private inline-loop [meta register-offset scope captured args body] + (->> body + (loop-transform register-offset true) + (shift-function-body scope (&/|tail scope) true) + ($loop register-offset args) + (list meta) + (&/T))) + +;; [[Initial Optimization]] + +;; Before any big optimization can be done, the incoming Analysis nodes +;; must be transformed into Optimized nodes, amenable to further transformations. +;; This function does the job, while also detecting (and optimizing) +;; some simple surface patterns it may encounter. +(let [optimize-closure (fn [optimize closure] + (&/|map (fn [capture] + (|let [[_name _analysis] capture] + (&/T [_name (optimize _analysis)]))) + closure))] + (defn ^:private pass-0 + "(-> Bit Analysis Optimized)" + [top-level-func? analysis] + (|let [[meta analysis-] analysis] + (|case analysis- + (&a/$bit value) + (&/T [meta ($bit value)]) + + (&a/$nat value) + (&/T [meta ($nat value)]) + + (&a/$int value) + (&/T [meta ($int value)]) + + (&a/$rev value) + (&/T [meta ($rev value)]) + + (&a/$frac value) + (&/T [meta ($frac value)]) + + (&a/$text value) + (&/T [meta ($text value)]) + + (&a/$variant idx is-last? value) + (&/T [meta ($variant idx is-last? (pass-0 top-level-func? value))]) + + (&a/$tuple elems) + (&/T [meta ($tuple (&/|map (partial pass-0 top-level-func?) elems))]) + + (&a/$apply func args) + (|let [=func (pass-0 top-level-func? func) + =args (&/|map (partial pass-0 top-level-func?) args)] + (&/T [meta ($apply =func =args)]) + ;; (|case =func + ;; [_ ($ann [_ ($function _register-offset _arity _scope _captured _body)] + ;; _)] + ;; (if (and (= _arity (&/|length =args)) + ;; (not (contains-self-reference? _body))) + ;; (inline-loop meta _register-offset _scope _captured =args _body) + ;; (&/T [meta ($apply =func =args)])) + + ;; _ + ;; (&/T [meta ($apply =func =args)])) + ) + + (&a/$case value branches) + (let [normal-case-optim (fn [] + (&/T [meta ($case (pass-0 top-level-func? value) + (optimize-pm (&/|map (fn [branch] + (|let [[_pattern _body] branch] + (&/T [_pattern (pass-0 top-level-func? _body)]))) + branches)))]))] + (|case branches + ;; The pattern for a let-expression is a single branch, + ;; tying the value to a register. + (&/$Cons [(&a-case/$StoreTestAC _register) _body] (&/$Nil)) + (&/T [meta ($let (pass-0 top-level-func? value) _register (pass-0 top-level-func? _body))]) + + (&/$Cons [(&a-case/$BitTestAC true) _then] + (&/$Cons [(&a-case/$BitTestAC false) _else] + (&/$Nil))) + (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) + + (&/$Cons [(&a-case/$BitTestAC true) _then] + (&/$Cons [(&a-case/$NoTestAC false) _else] + (&/$Nil))) + (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) + + (&/$Cons [(&a-case/$BitTestAC false) _else] + (&/$Cons [(&a-case/$BitTestAC true) _then] + (&/$Nil))) + (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) + + (&/$Cons [(&a-case/$BitTestAC false) _else] + (&/$Cons [(&a-case/$NoTestAC) _then] + (&/$Nil))) + (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) + + ;; The pattern for a record-get is a single branch, with a + ;; tuple pattern and a body corresponding to a + ;; local-variable extracted from the tuple. + (&/$Cons [(&a-case/$TupleTestAC _sub-tests) [_ (&a/$var (&/$Local _member-idx))]] (&/$Nil)) + (|let [_path (record-read-path _sub-tests _member-idx)] + (if (&/|empty? _path) + ;; If the path is empty, that means it was a + ;; false-positive and normal PM optimization should be + ;; done instead. + (normal-case-optim) + ;; Otherwise, we've got ourselves a record-get expression. + (&/T [meta ($record-get (pass-0 top-level-func? value) _path)]))) + + ;; If no special patterns are found, just do normal PM optimization. + _ + (normal-case-optim))) + + (&a/$function _register-offset scope captured body) + (|let [inner-func? (|case body + [_ (&a/$function _ _ _ _)] + true + + _ + false)] + (|case (pass-0 (not inner-func?) body) + ;; If the body of a function is another function, that means + ;; no work was done in-between and both layers can be folded + ;; into one. + [_ ($function _ _arity _scope _captured _body)] + (|let [new-arity (inc _arity) + collapsed-body (shift-function-body scope _scope true _body)] + (&/T [meta ($function _register-offset + new-arity + scope + (optimize-closure (partial pass-0 top-level-func?) captured) + (if top-level-func? + (optimize-iter new-arity collapsed-body) + collapsed-body))])) + + ;; Otherwise, they're nothing to be done and we've got a + ;; 1-arity function. + =body + (&/T [meta ($function _register-offset + 1 scope + (optimize-closure (partial pass-0 top-level-func?) captured) + (if top-level-func? + (optimize-iter 1 =body) + =body))]))) + + (&a/$ann value-expr type-expr) + (&/T [meta ($ann (pass-0 top-level-func? value-expr) type-expr)]) + + (&a/$def def-name) + (&/T [meta ($def def-name)]) + + (&a/$var var-kind) + (&/T [meta ($var var-kind)]) + + (&a/$captured scope idx source) + (&/T [meta ($captured scope idx (pass-0 top-level-func? source))]) + + (&a/$proc proc-ident args special-args) + (&/T [meta ($proc proc-ident (&/|map (partial pass-0 top-level-func?) args) special-args)]) + + _ + (assert false (prn-str 'pass-0 top-level-func? (&/adt->text analysis))) + )))) + +;; [Exports] +(defn optimize + "(-> Analysis Optimized)" + [analysis] + (->> analysis + (pass-0 true))) diff --git a/lux-bootstrapper/src/lux/parser.clj b/lux-bootstrapper/src/lux/parser.clj new file mode 100644 index 000000000..dd33129b8 --- /dev/null +++ b/lux-bootstrapper/src/lux/parser.clj @@ -0,0 +1,105 @@ +(ns lux.parser + (:require [clojure.template :refer [do-template]] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return |case]] + [lexer :as &lexer]))) + +;; [Utils] +(def ^:private base-uneven-record-error + "[Parser Error] Records must have an even number of elements.") + +(defn ^:private repeat% [action] + (fn [state] + (|case (action state) + (&/$Left ^String error) + (if (or (.contains error base-uneven-record-error) + (not (.contains error "[Parser Error]"))) + (&/$Left error) + (&/$Right (&/T [state &/$Nil]))) + + (&/$Right state* head) + ((|do [tail (repeat% action)] + (return (&/$Cons head tail))) + state*)))) + +(do-template [<name> <close-tag> <description> <tag>] + (defn <name> [parse] + (|do [elems (repeat% parse) + token &lexer/lex] + (|case token + [meta (<close-tag> _)] + (return (<tag> (&/fold &/|++ &/$Nil elems))) + + _ + (&/fail-with-loc (str "[Parser Error] Unbalanced " <description> ".")) + ))) + + ^:private parse-form &lexer/$Close_Paren "parantheses" &/$Form + ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$Tuple + ) + +(defn ^:private parse-record [parse] + (|do [elems* (repeat% parse) + token &lexer/lex + :let [elems (&/fold &/|++ &/$Nil elems*)]] + (|case token + [meta (&lexer/$Close_Brace _)] + (|do [_ (&/assert! (even? (&/|length elems)) + (&/fail-with-loc base-uneven-record-error))] + (return (&/$Record (&/|as-pairs elems)))) + + _ + (&/fail-with-loc "[Parser Error] Unbalanced braces.") + ))) + +;; [Interface] +(def parse + (|do [token &lexer/lex + :let [[meta token*] token]] + (|case token* + (&lexer/$White_Space _) + (return &/$Nil) + + (&lexer/$Comment _) + (return &/$Nil) + + (&lexer/$Bit ?value) + (return (&/|list (&/T [meta (&/$Bit (.equals ^String ?value "#1"))]))) + + (&lexer/$Nat ?value) + (return (&/|list (&/T [meta (&/$Nat (Long/parseUnsignedLong ?value))]))) + + (&lexer/$Int ?value) + (return (&/|list (&/T [meta (&/$Int (Long/parseLong ?value))]))) + + (&lexer/$Rev ?value) + (return (&/|list (&/T [meta (&/$Rev (&/decode-rev ?value))]))) + + (&lexer/$Frac ?value) + (return (&/|list (&/T [meta (&/$Frac (Double/parseDouble ?value))]))) + + (&lexer/$Text ?value) + (return (&/|list (&/T [meta (&/$Text ?value)]))) + + (&lexer/$Identifier ?ident) + (return (&/|list (&/T [meta (&/$Identifier ?ident)]))) + + (&lexer/$Tag ?ident) + (return (&/|list (&/T [meta (&/$Tag ?ident)]))) + + (&lexer/$Open_Paren _) + (|do [syntax (parse-form parse)] + (return (&/|list (&/T [meta syntax])))) + + (&lexer/$Open_Bracket _) + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/T [meta syntax])))) + + (&lexer/$Open_Brace _) + (|do [syntax (parse-record parse)] + (return (&/|list (&/T [meta syntax])))) + + _ + (&/fail-with-loc "[Parser Error] Unknown lexer token.") + ))) diff --git a/lux-bootstrapper/src/lux/reader.clj b/lux-bootstrapper/src/lux/reader.clj new file mode 100644 index 000000000..14914cc2e --- /dev/null +++ b/lux-bootstrapper/src/lux/reader.clj @@ -0,0 +1,153 @@ +(ns lux.reader + (:require [clojure.string :as string] + clojure.core.match + clojure.core.match.array + [lux.base :as & :refer [defvariant |do return* return |let |case]])) + +;; [Tags] +(defvariant + ("No" 1) + ("Done" 1) + ("Yes" 2)) + +;; [Utils] +(defn- with-line [body] + (fn [state] + (|case (&/get$ &/$source state) + (&/$Nil) + ((&/fail-with-loc "[Reader Error] EOF") state) + + (&/$Cons [[file-name line-num column-num] line] + more) + (|case (body file-name line-num column-num line) + ($No msg) + ((&/fail-with-loc msg) state) + + ($Done output) + (return* (&/set$ &/$source more state) + output) + + ($Yes output line*) + (return* (&/set$ &/$source (&/$Cons line* more) state) + output)) + ))) + +(defn- with-lines [body] + (fn [state] + (|case (body (&/get$ &/$source state)) + (&/$Right reader* match) + (return* (&/set$ &/$source reader* state) + match) + + (&/$Left msg) + ((&/fail-with-loc msg) state) + ))) + +(defn- re-find! [^java.util.regex.Pattern regex column ^String line] + (let [matcher (doto (.matcher regex line) + (.region column (.length line)) + (.useAnchoringBounds true))] + (when (.find matcher) + (.group matcher 0)))) + +;; [Exports] +(defn read-regex [regex] + (with-line + (fn [file-name line-num column-num ^String line] + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true match])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false match]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Pattern failed: " regex)))))) + +(defn read-regex? + "(-> Regex (Reader (Maybe Text)))" + [regex] + (with-line + (fn [file-name line-num column-num ^String line] + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true (&/$Some match)])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some match)]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($Yes (&/T [(&/T [file-name line-num column-num]) false &/$None]) + (&/T [(&/T [file-name line-num column-num]) line])))))) + +(defn read-regex+ [regex] + (with-lines + (fn [reader] + (loop [prefix "" + reader* reader] + (|case reader* + (&/$Nil) + (&/$Left "[Reader Error] EOF") + + (&/$Cons [[file-name line-num column-num] ^String line] + reader**) + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) + column-num* (+ column-num match-length) + prefix* (if (= 0 column-num) + (str prefix "\n" match) + (str prefix match))] + (if (= column-num* (.length line)) + (recur prefix* reader**) + (&/$Right (&/T [(&/$Cons (&/T [(&/T [file-name line-num column-num*]) line]) + reader**) + (&/T [(&/T [file-name line-num column-num]) prefix*])])))) + (&/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + +(defn read-text + "(-> Text (Reader Text))" + [^String text] + (with-line + (fn [file-name line-num column-num ^String line] + (if (.startsWith line text column-num) + (let [match-length (.length text) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true text])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false text]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($No (str "[Reader Error] Text failed: " text)))))) + +(defn read-text? + "(-> Text (Reader (Maybe Text)))" + [^String text] + (with-line + (fn [file-name line-num column-num ^String line] + (if (.startsWith line text column-num) + (let [match-length (.length text) + column-num* (+ column-num match-length)] + (if (= column-num* (.length line)) + ($Done (&/T [(&/T [file-name line-num column-num]) true (&/$Some text)])) + ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some text)]) + (&/T [(&/T [file-name line-num column-num*]) line])))) + ($Yes (&/T [(&/T [file-name line-num column-num]) false &/$None]) + (&/T [(&/T [file-name line-num column-num]) line])))))) + +(defn from [^String name ^String source-code] + (let [lines (string/split-lines source-code) + indexed-lines (map (fn [line line-num] + (&/T [(&/T [name (inc line-num) 0]) + line])) + lines + (range (count lines)))] + (reduce (fn [tail head] (&/$Cons head tail)) + &/$Nil + (reverse indexed-lines)))) + +(defn with-source [name content body] + (fn [state] + (|let [old-source (&/get$ &/$source state)] + (|case (body (&/set$ &/$source (from name content) state)) + (&/$Left error) + ((&/fail-with-loc error) state) + + (&/$Right state* output) + (&/$Right (&/T [(&/set$ &/$source old-source state*) output])))))) diff --git a/lux-bootstrapper/src/lux/repl.clj b/lux-bootstrapper/src/lux/repl.clj new file mode 100644 index 000000000..d980ac9ec --- /dev/null +++ b/lux-bootstrapper/src/lux/repl.clj @@ -0,0 +1,87 @@ +(ns lux.repl + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case]] + [type :as &type] + [analyser :as &analyser] + [optimizer :as &optimizer] + [compiler :as &compiler]) + [lux.compiler.cache :as &cache] + (lux.analyser [base :as &a-base] + [lux :as &a-lux] + [module :as &module])) + (:import (java.io InputStreamReader + BufferedReader))) + +;; [Utils] +(def ^:private repl-module "REPL") + +(defn ^:private repl-location [repl-line] + (&/T [repl-module repl-line 0])) + +(defn ^:private init [source-dirs] + (do (&compiler/init!) + (|case ((|do [_ (&compiler/compile-module source-dirs "lux") + _ (&cache/delete repl-module) + _ (&module/create-module repl-module 0) + _ (fn [?state] + (return* (&/set$ &/$source + (&/|list (&/T [(repl-location -1) "(;module: lux)"])) + ?state) + nil)) + analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) + eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!))] + (return nil)) + (&/init-state &/$REPL)) + (&/$Right ?state _) + (do (println) + (println "Welcome to the REPL!") + (println "Type \"exit\" to leave.") + (println) + ?state) + + (&/$Left ?message) + (do (println (str "Initialization failed:\n" ?message)) + (flush) + (System/exit 1))) + )) + +;; [Values] +(defn repl [dependencies source-dirs target-dir] + (with-open [input (->> System/in (new InputStreamReader) (new BufferedReader))] + (loop [state (init source-dirs) + repl-line 0 + multi-line? false] + (let [_ (if (not multi-line?) + (.print System/out "> ") + (.print System/out " ")) + line (.readLine input)] + (if (= "exit" line) + (println "Till next time...") + (let [line* (&/|list (&/T [(repl-location repl-line) line])) + state* (&/update$ &/$source + (fn [_source] (&/|++ _source line*)) + state)] + (|case ((|do [analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) + eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!)) + :let [outputs (map (fn [analysis value] + (|let [[[_type _location] _term] analysis] + [_type value])) + (&/->seq analysed-tokens) + (&/->seq eval-values))]] + (return outputs)) + state*) + (&/$Right state** outputs) + (do (doseq [[_type _value] outputs] + (.println System/out (str ": " (&type/show-type _type) "\n" + "=> " (pr-str _value) "\n"))) + (recur state** (inc repl-line) false)) + + (&/$Left ^String ?message) + (if (or (= "[Reader Error] EOF" ?message) + (.contains ?message "[Parser Error] Unbalanced ")) + (recur state* (inc repl-line) true) + (do (println ?message) + (recur state (inc repl-line) false))) + )))) + ))) diff --git a/lux-bootstrapper/src/lux/type.clj b/lux-bootstrapper/src/lux/type.clj new file mode 100644 index 000000000..8853224b5 --- /dev/null +++ b/lux-bootstrapper/src/lux/type.clj @@ -0,0 +1,973 @@ +(ns lux.type + (:refer-clojure :exclude [deref apply merge bound?]) + (:require [clojure.template :refer [do-template]] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return assert! |let |case]]) + [lux.type.host :as &&host])) + +(declare show-type + type=) + +;; [Utils] +(defn |list? [xs] + (|case xs + (&/$Nil) + true + + (&/$Cons x xs*) + (|list? xs*) + + _ + false)) + +(def max-stack-size 256) + +(def empty-env &/$Nil) + +(def I64 (&/$Named (&/T ["lux" "I64"]) + (&/$UnivQ empty-env + (&/$Primitive "#I64" (&/|list (&/$Parameter 1)))))) +(def Nat* (&/$Primitive &&host/nat-data-tag &/$Nil)) +(def Rev* (&/$Primitive &&host/rev-data-tag &/$Nil)) +(def Int* (&/$Primitive &&host/int-data-tag &/$Nil)) + +(def Bit (&/$Named (&/T ["lux" "Bit"]) (&/$Primitive "#Bit" &/$Nil))) +(def Nat (&/$Named (&/T ["lux" "Nat"]) (&/$Apply Nat* I64))) +(def Rev (&/$Named (&/T ["lux" "Rev"]) (&/$Apply Rev* I64))) +(def Int (&/$Named (&/T ["lux" "Int"]) (&/$Apply Int* I64))) +(def Frac (&/$Named (&/T ["lux" "Frac"]) (&/$Primitive "#Frac" &/$Nil))) +(def Text (&/$Named (&/T ["lux" "Text"]) (&/$Primitive "#Text" &/$Nil))) +(def Ident (&/$Named (&/T ["lux" "Ident"]) (&/$Product Text Text))) + +(defn Array [elemT] + (&/$Primitive "#Array" (&/|list elemT))) + +(def Nothing + (&/$Named (&/T ["lux" "Nothing"]) + (&/$UnivQ empty-env + (&/$Parameter 1)))) + +(def Any + (&/$Named (&/T ["lux" "Any"]) + (&/$ExQ empty-env + (&/$Parameter 1)))) + +(def IO + (&/$Named (&/T ["lux/control/io" "IO"]) + (&/$UnivQ empty-env + (&/$Primitive "lux/type/abstract.Abstraction lux/control/io.IO" (&/|list (&/$Parameter 1)))))) + +(def List + (&/$Named (&/T ["lux" "List"]) + (&/$UnivQ empty-env + (&/$Sum + ;; lux;Nil + Any + ;; lux;Cons + (&/$Product (&/$Parameter 1) + (&/$Apply (&/$Parameter 1) + (&/$Parameter 0))))))) + +(def Maybe + (&/$Named (&/T ["lux" "Maybe"]) + (&/$UnivQ empty-env + (&/$Sum + ;; lux;None + Any + ;; lux;Some + (&/$Parameter 1)) + ))) + +(def Type + (&/$Named (&/T ["lux" "Type"]) + (let [Type (&/$Apply (&/$Parameter 1) (&/$Parameter 0)) + TypeList (&/$Apply Type List) + TypePair (&/$Product Type Type)] + (&/$Apply Nothing + (&/$UnivQ empty-env + (&/$Sum + ;; Primitive + (&/$Product Text TypeList) + (&/$Sum + ;; Sum + TypePair + (&/$Sum + ;; Product + TypePair + (&/$Sum + ;; Function + TypePair + (&/$Sum + ;; Parameter + Nat + (&/$Sum + ;; Var + Nat + (&/$Sum + ;; Ex + Nat + (&/$Sum + ;; UnivQ + (&/$Product TypeList Type) + (&/$Sum + ;; ExQ + (&/$Product TypeList Type) + (&/$Sum + ;; App + TypePair + ;; Named + (&/$Product Ident Type))))))))))) + ))))) + +(def Location + (&/$Named (&/T ["lux" "Location"]) + (&/$Product Text (&/$Product Nat Nat)))) + +(def Meta + (&/$Named (&/T ["lux" "Meta"]) + (&/$UnivQ empty-env + (&/$UnivQ empty-env + (&/$Product (&/$Parameter 3) + (&/$Parameter 1)))))) + +(def Code* + (&/$Named (&/T ["lux" "Code'"]) + (let [Code (&/$Apply (&/$Apply (&/$Parameter 1) + (&/$Parameter 0)) + (&/$Parameter 1)) + Code-List (&/$Apply Code List)] + (&/$UnivQ empty-env + (&/$Sum ;; "lux;Bit" + Bit + (&/$Sum ;; "lux;Nat" + Nat + (&/$Sum ;; "lux;Int" + Int + (&/$Sum ;; "lux;Rev" + Rev + (&/$Sum ;; "lux;Frac" + Frac + (&/$Sum ;; "lux;Text" + Text + (&/$Sum ;; "lux;Identifier" + Ident + (&/$Sum ;; "lux;Tag" + Ident + (&/$Sum ;; "lux;Form" + Code-List + (&/$Sum ;; "lux;Tuple" + Code-List + ;; "lux;Record" + (&/$Apply (&/$Product Code Code) List) + )))))))))) + )))) + +(def Code + (&/$Named (&/T ["lux" "Code"]) + (let [w (&/$Apply Location Meta)] + (&/$Apply (&/$Apply w Code*) w)))) + +(def Macro + (&/$Named (&/T ["lux" "Macro"]) + (&/$Primitive "#Macro" &/$Nil))) + +(defn bound? [id] + (fn [state] + (if-let [type (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] + (|case type + (&/$Some type*) + (return* state true) + + (&/$None) + (return* state false)) + ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id)) + state)))) + +(defn deref [id] + (fn [state] + (if-let [type* (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] + (|case type* + (&/$Some type) + (return* state type) + + (&/$None) + ((&/fail-with-loc (str "[Type Error] Un-bound type-var: " id)) + state)) + ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id)) + state)))) + +(defn deref+ [type] + (|case type + (&/$Var id) + (deref id) + + _ + (&/fail-with-loc (str "[Type Error] Type is not a variable: " (show-type type))) + )) + +(defn set-var [id type] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] + (|case tvar + (&/$Some bound) + (if (type= type bound) + (return* state nil) + ((&/fail-with-loc (str "[Type Error] Cannot re-bind type var: " id " | Current type: " (show-type bound))) + state)) + + (&/$None) + (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id (&/$Some type) %) + ts)) + state) + nil)) + ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) + state)))) + +(defn reset-var [id type] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] + (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id (&/$Some type) %) + ts)) + state) + nil) + ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) + state)))) + +(defn unset-var [id] + (fn [state] + (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] + (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id &/$None %) + ts)) + state) + nil) + ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) + state)))) + +;; [Exports] +;; Type vars +(def reset-mappings + (fn [state] + (return* (&/update$ &/$type-context #(->> % + (&/set$ &/$var-counter 0) + (&/set$ &/$var-bindings (&/|table))) + state) + nil))) + +(def create-var + (fn [state] + (let [id (->> state (&/get$ &/$type-context) (&/get$ &/$var-counter))] + (return* (&/update$ &/$type-context #(->> % + (&/update$ &/$var-counter inc) + (&/update$ &/$var-bindings (fn [ms] (&/|put id &/$None ms)))) + state) + id)))) + +(def existential + ;; (Lux Type) + (fn [compiler] + (return* (&/update$ &/$type-context + (fn [context] + (&/update$ &/$ex-counter inc context)) + compiler) + (->> compiler + (&/get$ &/$type-context) + (&/get$ &/$ex-counter) + &/$Ex)))) + +(defn with-var [k] + (|do [id create-var] + (k (&/$Var id)))) + +(defn clean* [?tid type] + (|case type + (&/$Var ?id) + (if (= ?tid ?id) + (|do [? (bound? ?id)] + (if ? + (deref ?id) + (return type))) + (|do [? (bound? ?id)] + (if ? + (|do [=type (deref ?id) + ==type (clean* ?tid =type)] + (|case ==type + (&/$Var =id) + (if (= ?tid =id) + (|do [_ (unset-var ?id)] + (return type)) + (|do [_ (reset-var ?id ==type)] + (return type))) + + _ + (|do [_ (reset-var ?id ==type)] + (return ==type)))) + (return type))) + ) + + (&/$Primitive ?name ?params) + (|do [=params (&/map% (partial clean* ?tid) ?params)] + (return (&/$Primitive ?name =params))) + + (&/$Function ?arg ?return) + (|do [=arg (clean* ?tid ?arg) + =return (clean* ?tid ?return)] + (return (&/$Function =arg =return))) + + (&/$Apply ?param ?lambda) + (|do [=lambda (clean* ?tid ?lambda) + =param (clean* ?tid ?param)] + (return (&/$Apply =param =lambda))) + + (&/$Product ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (&/$Product =left =right))) + + (&/$Sum ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (&/$Sum =left =right))) + + (&/$UnivQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) + body* (clean* ?tid ?body)] ;; TODO: DO NOT CLEAN THE BODY + (return (&/$UnivQ =env body*))) + + (&/$ExQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) + body* (clean* ?tid ?body)] ;; TODO: DO NOT CLEAN THE BODY + (return (&/$ExQ =env body*))) + + _ + (return type) + )) + +(defn clean [tvar type] + (|case tvar + (&/$Var ?id) + (clean* ?id type) + + _ + (&/fail-with-loc (str "[Type Error] Not type-var: " (show-type tvar))))) + +(defn ^:private unravel-fun [type] + (|case type + (&/$Function ?in ?out) + (|let [[??out ?args] (unravel-fun ?out)] + (&/T [??out (&/$Cons ?in ?args)])) + + _ + (&/T [type &/$Nil]))) + +(defn ^:private unravel-app + ([fun-type tail] + (|case fun-type + (&/$Apply ?arg ?func) + (unravel-app ?func (&/$Cons ?arg tail)) + + _ + (&/T [fun-type tail]))) + ([fun-type] + (unravel-app fun-type &/$Nil))) + +(do-template [<tag> <flatten> <at> <desc>] + (do (defn <flatten> + "(-> Type (List Type))" + [type] + (|case type + (<tag> left right) + (&/$Cons left (<flatten> right)) + + _ + (&/|list type))) + + (defn <at> + "(-> Int Type (Lux Type))" + [tag type] + (|case type + (&/$Named ?name ?type) + (<at> tag ?type) + + (<tag> ?left ?right) + (|case (&/T [tag ?right]) + [0 _] (return ?left) + [1 (<tag> ?left* _)] (return ?left*) + [1 _] (return ?right) + [_ (<tag> _ _)] (<at> (dec tag) ?right) + _ (&/fail-with-loc (str "[Type Error] " <desc> " lacks member: " tag " | " (show-type type)))) + + _ + (&/fail-with-loc (str "[Type Error] Type is not a " <desc> ": " (show-type type)))))) + + &/$Sum flatten-sum sum-at "Sum" + &/$Product flatten-prod prod-at "Product" + ) + +(do-template [<name> <ctor> <unit>] + (defn <name> + "(-> (List Type) Type)" + [types] + (|case (&/|reverse types) + (&/$Cons last prevs) + (&/fold (fn [right left] (<ctor> left right)) last prevs) + + (&/$Nil) + <unit>)) + + Variant$ &/$Sum Nothing + Tuple$ &/$Product Any + ) + +(defn show-type [^objects type] + (|case type + (&/$Primitive name params) + (|case params + (&/$Nil) + (str "(primitive " (pr-str name) ")") + + _ + (str "(primitive " (pr-str name) " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$Product _) + (str "[" (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) "]") + + (&/$Sum _) + (str "(| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + + (&/$Function input output) + (|let [[?out ?ins] (unravel-fun type)] + (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) + + (&/$Var id) + (str "⌈v:" id "⌋") + + (&/$Ex ?id) + (str "⟨e:" ?id "⟩") + + (&/$Parameter idx) + (str idx) + + (&/$Apply _ _) + (|let [[?call-fun ?call-args] (unravel-app type)] + (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$UnivQ ?env ?body) + (str "(All " "{" (->> ?env (&/|map show-type) (&/|interpose " ") (&/fold str "")) "} " + (show-type ?body) ")") + + (&/$ExQ ?env ?body) + (str "(Ex " "{" (->> ?env (&/|map show-type) (&/|interpose " ") (&/fold str "")) "} " + (show-type ?body) ")") + + (&/$Named ?name ?type) + (&/ident->text ?name) + + _ + (assert false (prn-str 'show-type (&/adt->text type))))) + +(defn type= [x y] + (or (clojure.lang.Util/identical x y) + (let [output (|case [x y] + [(&/$Named [?xmodule ?xname] ?xtype) (&/$Named [?ymodule ?yname] ?ytype)] + (and (= ?xmodule ?ymodule) + (= ?xname ?yname)) + + [(&/$Primitive xname xparams) (&/$Primitive yname yparams)] + (and (.equals ^Object xname yname) + (= (&/|length xparams) (&/|length yparams)) + (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) + + [(&/$Product xL xR) (&/$Product yL yR)] + (and (type= xL yL) + (type= xR yR)) + + [(&/$Sum xL xR) (&/$Sum yL yR)] + (and (type= xL yL) + (type= xR yR)) + + [(&/$Function xinput xoutput) (&/$Function yinput youtput)] + (and (type= xinput yinput) + (type= xoutput youtput)) + + [(&/$Var xid) (&/$Var yid)] + (= xid yid) + + [(&/$Parameter xidx) (&/$Parameter yidx)] + (= xidx yidx) + + [(&/$Ex xid) (&/$Ex yid)] + (= xid yid) + + [(&/$Apply xparam xlambda) (&/$Apply yparam ylambda)] + (and (type= xparam yparam) (type= xlambda ylambda)) + + [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] + (type= xbody ybody) + + [(&/$Named ?xname ?xtype) _] + (type= ?xtype y) + + [_ (&/$Named ?yname ?ytype)] + (type= x ?ytype) + + [_ _] + false + )] + output))) + +(defn ^:private fp-get [k fixpoints] + (|let [[e a] k] + (|case fixpoints + (&/$Nil) + &/$None + + (&/$Cons [[e* a*] v*] fixpoints*) + (if (and (type= e e*) + (type= a a*)) + (&/$Some v*) + (fp-get k fixpoints*)) + ))) + +(defn ^:private fp-put [k v fixpoints] + (&/$Cons (&/T [k v]) fixpoints)) + +(defn show-type+ [type] + (|case type + (&/$Var ?id) + (fn [state] + (|case ((deref ?id) state) + (&/$Right state* bound) + (return* state (str (show-type type) " = " (show-type bound))) + + (&/$Left _) + (return* state (show-type type)))) + + _ + (return (show-type type)))) + +(defn ^:private check-error [err expected actual] + (|do [=expected (show-type+ expected) + =actual (show-type+ actual)] + (&/fail-with-loc (str (if (= "" err) err (str err "\n")) + "[Type Checker Error]\n" + "Expected: " =expected "\n\n" + " Actual: " =actual + "\n")))) + +(defn beta-reduce [env type] + (|case type + (&/$Primitive ?name ?params) + (&/$Primitive ?name (&/|map (partial beta-reduce env) ?params)) + + (&/$Sum ?left ?right) + (&/$Sum (beta-reduce env ?left) (beta-reduce env ?right)) + + (&/$Product ?left ?right) + (&/$Product (beta-reduce env ?left) (beta-reduce env ?right)) + + (&/$Apply ?type-arg ?type-fn) + (&/$Apply (beta-reduce env ?type-arg) (beta-reduce env ?type-fn)) + + (&/$UnivQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (&/$UnivQ env ?local-def) + + _ + type) + + (&/$ExQ ?local-env ?local-def) + (|case ?local-env + (&/$Nil) + (&/$ExQ env ?local-def) + + _ + type) + + (&/$Function ?input ?output) + (&/$Function (beta-reduce env ?input) (beta-reduce env ?output)) + + (&/$Parameter ?idx) + (|case (&/|at ?idx env) + (&/$Some parameter) + (beta-reduce env parameter) + + _ + (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env))))) + + _ + type + )) + +(defn apply-type [type-fn param] + (|case type-fn + (&/$UnivQ local-env local-def) + (return (beta-reduce (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$ExQ local-env local-def) + (return (beta-reduce (->> local-env + (&/$Cons param) + (&/$Cons type-fn)) + local-def)) + + (&/$Apply A F) + (|do [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (&/$Named ?name ?type) + (apply-type ?type param) + + ;; TODO: This one must go... + (&/$Ex id) + (return (&/$Apply param type-fn)) + + (&/$Var id) + (|do [=type-fun (deref id)] + (apply-type =type-fun param)) + + _ + (&/fail-with-loc (str "[Type System] Not a type function:\n" (show-type type-fn) "\n" + "for arg: " (show-type param))))) + +(def ^:private init-fixpoints &/$Nil) + +(defn ^:private check* [fixpoints invariant?? expected actual] + (if (clojure.lang.Util/identical expected actual) + (return fixpoints) + (&/with-attempt + (|case [expected actual] + [(&/$Var ?eid) (&/$Var ?aid)] + (if (= ?eid ?aid) + (return fixpoints) + (|do [ebound (fn [state] + (|case ((deref ?eid) state) + (&/$Right state* ebound) + (return* state* (&/$Some ebound)) + + (&/$Left _) + (return* state &/$None))) + abound (fn [state] + (|case ((deref ?aid) state) + (&/$Right state* abound) + (return* state* (&/$Some abound)) + + (&/$Left _) + (return* state &/$None)))] + (|case [ebound abound] + [(&/$None _) (&/$None _)] + (|do [_ (set-var ?eid actual)] + (return fixpoints)) + + [(&/$Some etype) (&/$None _)] + (check* fixpoints invariant?? etype actual) + + [(&/$None _) (&/$Some atype)] + (check* fixpoints invariant?? expected atype) + + [(&/$Some etype) (&/$Some atype)] + (check* fixpoints invariant?? etype atype)))) + + [(&/$Var ?id) _] + (fn [state] + (|case ((set-var ?id actual) state) + (&/$Right state* _) + (return* state* fixpoints) + + (&/$Left _) + ((|do [bound (deref ?id)] + (check* fixpoints invariant?? bound actual)) + state))) + + [_ (&/$Var ?id)] + (fn [state] + (|case ((set-var ?id expected) state) + (&/$Right state* _) + (return* state* fixpoints) + + (&/$Left _) + ((|do [bound (deref ?id)] + (check* fixpoints invariant?? expected bound)) + state))) + + [(&/$Apply eA (&/$Ex eid)) (&/$Apply aA (&/$Ex aid))] + (if (= eid aid) + (check* fixpoints invariant?? eA aA) + (check-error "" expected actual)) + + [(&/$Apply A1 (&/$Var ?id)) (&/$Apply A2 F2)] + (fn [state] + (|case ((|do [F1 (deref ?id)] + (check* fixpoints invariant?? (&/$Apply A1 F1) actual)) + state) + (&/$Right state* output) + (return* state* output) + + (&/$Left _) + (|case F2 + (&/$UnivQ (&/$Cons _) _) + ((|do [actual* (apply-type F2 A2)] + (check* fixpoints invariant?? expected actual*)) + state) + + (&/$Ex _) + ((|do [fixpoints* (check* fixpoints invariant?? (&/$Var ?id) F2)] + (check* fixpoints* invariant?? A1 A2)) + state) + + _ + ((|do [fixpoints* (check* fixpoints invariant?? (&/$Var ?id) F2) + e* (apply-type F2 A1) + a* (apply-type F2 A2)] + (check* fixpoints* invariant?? e* a*)) + state)))) + + [(&/$Apply A1 F1) (&/$Apply A2 (&/$Var ?id))] + (fn [state] + (|case ((|do [F2 (deref ?id)] + (check* fixpoints invariant?? expected (&/$Apply A2 F2))) + state) + (&/$Right state* output) + (return* state* output) + + (&/$Left _) + ((|do [fixpoints* (check* fixpoints invariant?? F1 (&/$Var ?id)) + e* (apply-type F1 A1) + a* (apply-type F1 A2)] + (check* fixpoints* invariant?? e* a*)) + state))) + + [(&/$Apply A F) _] + (let [fp-pair (&/T [expected actual]) + _ (when (> (&/|length fixpoints) max-stack-size) + (&/|log! (print-str 'FIXPOINTS (->> (&/|keys fixpoints) + (&/|map (fn [pair] + (|let [[e a] pair] + (str (show-type e) ":+:" + (show-type a))))) + (&/|interpose "\n\n") + (&/fold str "")))) + (assert false (prn-str 'check* '[(&/$Apply A F) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] + (|case (fp-get fp-pair fixpoints) + (&/$Some ?) + (if ? + (return fixpoints) + (check-error "" expected actual)) + + (&/$None) + (|do [expected* (apply-type F A)] + (check* (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) + + [_ (&/$Apply A (&/$Ex aid))] + (check-error "" expected actual) + + [_ (&/$Apply A F)] + (|do [actual* (apply-type F A)] + (check* fixpoints invariant?? expected actual*)) + + [(&/$UnivQ _) _] + (|do [$arg existential + expected* (apply-type expected $arg)] + (check* fixpoints invariant?? expected* actual)) + + [_ (&/$UnivQ _)] + (with-var + (fn [$arg] + (|do [actual* (apply-type actual $arg) + =output (check* fixpoints invariant?? expected actual*) + _ (clean $arg expected)] + (return =output)))) + + [(&/$ExQ e!env e!def) _] + (with-var + (fn [$arg] + (|do [expected* (apply-type expected $arg) + =output (check* fixpoints invariant?? expected* actual) + _ (clean $arg actual)] + (return =output)))) + + [_ (&/$ExQ a!env a!def)] + (|do [$arg existential + actual* (apply-type actual $arg)] + (check* fixpoints invariant?? expected actual*)) + + [(&/$Primitive e!data) (&/$Primitive a!data)] + (|do [? &/jvm?] + (if ? + (|do [class-loader &/loader] + (&&host/check-host-types (partial check* fixpoints true) + check-error + fixpoints + existential + class-loader + invariant?? + e!data + a!data)) + (|let [[e!name e!params] e!data + [a!name a!params] a!data] + (if (and (= e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% (partial check* fixpoints true) e!params a!params)] + (return fixpoints)) + (check-error "" expected actual))))) + + [(&/$Function eI eO) (&/$Function aI aO)] + (|do [fixpoints* (check* fixpoints invariant?? aI eI)] + (check* fixpoints* invariant?? eO aO)) + + [(&/$Product eL eR) (&/$Product aL aR)] + (|do [fixpoints* (check* fixpoints invariant?? eL aL)] + (check* fixpoints* invariant?? eR aR)) + + [(&/$Sum eL eR) (&/$Sum aL aR)] + (|do [fixpoints* (check* fixpoints invariant?? eL aL)] + (check* fixpoints* invariant?? eR aR)) + + [(&/$Ex e!id) (&/$Ex a!id)] + (if (= e!id a!id) + (return fixpoints) + (check-error "" expected actual)) + + [(&/$Named _ ?etype) _] + (check* fixpoints invariant?? ?etype actual) + + [_ (&/$Named _ ?atype)] + (check* fixpoints invariant?? expected ?atype) + + [_ _] + (&/fail "")) + (fn [err] + (check-error err expected actual))))) + +(defn check [expected actual] + (|do [_ (check* init-fixpoints false expected actual)] + (return nil))) + +(defn actual-type + "(-> Type (Lux Type))" + [type] + (|case type + (&/$Apply ?param ?all) + (|do [type* (apply-type ?all ?param)] + (actual-type type*)) + + (&/$Var id) + (|do [=type (deref id)] + (actual-type =type)) + + (&/$Named ?name ?type) + (actual-type ?type) + + _ + (return type) + )) + +(defn type-name + "(-> Type (Lux Ident))" + [type] + (|case type + (&/$Named name _) + (return name) + + _ + (&/fail-with-loc (str "[Type Error] Type is not named: " (show-type type))) + )) + +(defn unknown? + "(-> Type (Lux Bit))" + [type] + (|case type + (&/$Var id) + (|do [? (bound? id)] + (return (not ?))) + + _ + (return false))) + +(defn resolve-type + "(-> Type (Lux Type))" + [type] + (|case type + (&/$Var id) + (|do [? (bound? id)] + (if ? + (deref id) + (return type))) + + _ + (return type))) + +(defn tuple-types-for + "(-> Int Type [Int (List Type)])" + [size-members type] + (|let [?member-types (flatten-prod type) + size-types (&/|length ?member-types)] + (if (>= size-types size-members) + (&/T [size-members (&/|++ (&/|take (dec size-members) ?member-types) + (&/|list (|case (->> ?member-types (&/|drop (dec size-members)) (&/|reverse)) + (&/$Cons last prevs) + (&/fold (fn [right left] (&/$Product left right)) + last prevs))))]) + (&/T [size-types ?member-types]) + ))) + +(do-template [<name> <zero> <plus>] + (defn <name> [types] + (|case (&/|reverse types) + (&/$Nil) + <zero> + + (&/$Cons type (&/$Nil)) + type + + (&/$Cons last prevs) + (&/fold (fn [r l] (<plus> l r)) last prevs))) + + fold-prod Any &/$Product + fold-sum Nothing &/$Sum + ) + +(def create-var+ + (|do [id create-var] + (return (&/$Var id)))) + +(defn ^:private push-app [inf-type inf-var] + (|case inf-type + (&/$Apply inf-var* inf-type*) + (&/$Apply inf-var* (push-app inf-type* inf-var)) + + _ + (&/$Apply inf-var inf-type))) + +(defn ^:private push-name [name inf-type] + (|case inf-type + (&/$Apply inf-var* inf-type*) + (&/$Apply inf-var* (push-name name inf-type*)) + + _ + (&/$Named name inf-type))) + +(defn ^:private push-univq [env inf-type] + (|case inf-type + (&/$Apply inf-var* inf-type*) + (&/$Apply inf-var* (push-univq env inf-type*)) + + _ + (&/$UnivQ env inf-type))) + +(defn instantiate-inference [type] + (|case type + (&/$Named ?name ?type) + (|do [output (instantiate-inference ?type)] + (return (push-name ?name output))) + + (&/$UnivQ _aenv _abody) + (|do [inf-var create-var + output (instantiate-inference _abody)] + (return (push-univq _aenv (push-app output (&/$Var inf-var))))) + + _ + (return type))) diff --git a/lux-bootstrapper/src/lux/type/host.clj b/lux-bootstrapper/src/lux/type/host.clj new file mode 100644 index 000000000..36e969046 --- /dev/null +++ b/lux-bootstrapper/src/lux/type/host.clj @@ -0,0 +1,411 @@ +(ns lux.type.host + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return assert! |let |case]]) + [lux.host.generics :as &host-generics]) + (:import (java.lang.reflect GenericArrayType + ParameterizedType + TypeVariable + WildcardType))) + +(defn ^:private type= [x y] + (or (clojure.lang.Util/identical x y) + (let [output (|case [x y] + [(&/$Named [?xmodule ?xname] ?xtype) (&/$Named [?ymodule ?yname] ?ytype)] + (and (= ?xmodule ?ymodule) + (= ?xname ?yname)) + + [(&/$Primitive xname xparams) (&/$Primitive yname yparams)] + (and (.equals ^Object xname yname) + (= (&/|length xparams) (&/|length yparams)) + (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) + + [(&/$Product xL xR) (&/$Product yL yR)] + (and (type= xL yL) + (type= xR yR)) + + [(&/$Sum xL xR) (&/$Sum yL yR)] + (and (type= xL yL) + (type= xR yR)) + + [(&/$Function xinput xoutput) (&/$Function yinput youtput)] + (and (type= xinput yinput) + (type= xoutput youtput)) + + [(&/$Var xid) (&/$Var yid)] + (= xid yid) + + [(&/$Parameter xidx) (&/$Parameter yidx)] + (= xidx yidx) + + [(&/$Ex xid) (&/$Ex yid)] + (= xid yid) + + [(&/$Apply xparam xlambda) (&/$Apply yparam ylambda)] + (and (type= xparam yparam) (type= xlambda ylambda)) + + [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] + (type= xbody ybody) + + [(&/$Named ?xname ?xtype) _] + (type= ?xtype y) + + [_ (&/$Named ?yname ?ytype)] + (type= x ?ytype) + + [_ _] + false + )] + output))) + +(def ^:private Any + (&/$Named (&/T ["lux" "Any"]) + (&/$ExQ (&/|list) + (&/$Parameter 1)))) + +;; [Exports] +(def array-data-tag "#Array") +(def null-data-tag "#Null") +(def i64-data-tag "#I64") +(def nat-data-tag "#Nat") +(def int-data-tag "#Int") +(def rev-data-tag "#Rev") + +;; [Utils] +(defn ^:private trace-lineage* + "(-> Class Class (List Class))" + [^Class super-class ^Class sub-class] + ;; Either they're both interfaces, or they're both classes + (let [valid-sub? #(if (or (= super-class %) + (.isAssignableFrom super-class %)) + % + nil)] + (if (or (.isInterface sub-class) + (.isInterface super-class)) + (loop [sub-class sub-class + stack (&/|list)] + (if-let [super-interface (some valid-sub? (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/$Cons super-interface stack) + (recur super-interface (&/$Cons super-interface stack))) + (if-let [super* (.getSuperclass sub-class)] + (recur super* (&/$Cons super* stack)) + stack))) + (loop [sub-class sub-class + stack (&/|list)] + (let [super* (.getSuperclass sub-class)] + (if (= super* super-class) + (&/$Cons super* stack) + (recur super* (&/$Cons super* stack)))))))) + +(defn ^:private trace-lineage + "(-> Class Class (List Class))" + [^Class sub-class ^Class super-class] + (if (= sub-class super-class) + (&/|list) + (&/|reverse (trace-lineage* super-class sub-class)))) + +(let [matcher (fn [m ^TypeVariable jt lt] (&/$Cons (&/T [(.getName jt) lt]) m))] + (defn ^:private match-params [sub-type-params params] + (assert (and (= (&/|length sub-type-params) (&/|length params)) + (&/|every? (partial instance? TypeVariable) sub-type-params))) + (&/fold2 matcher (&/|table) sub-type-params params))) + +;; [Exports] +(let [class-name-re #"((\[+)L([^\s]+);|([^\s]+)|(\[+)([ZBSIJFDC]))" + jprim->lprim (fn [prim] + (case prim + "Z" "boolean" + "B" "byte" + "S" "short" + "I" "int" + "J" "long" + "F" "float" + "D" "double" + "C" "char"))] + (defn class->type + "(-> Class Type)" + [^Class class] + (let [gclass-name (.getName class)] + (case gclass-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") + (&/$Primitive gclass-name (&/|list)) + ;; else + (if-let [[_ _ arr-obrackets arr-obase simple-base arr-pbrackets arr-pbase] (re-find class-name-re gclass-name)] + (let [base (or arr-obase simple-base (jprim->lprim arr-pbase))] + (if (.equals "void" base) + Any + (reduce (fn [inner _] (&/$Primitive array-data-tag (&/|list inner))) + (&/$Primitive base (try (-> (Class/forName base) .getTypeParameters + seq count (repeat (&/$Primitive "java.lang.Object" &/$Nil)) + &/->list) + (catch Exception e + (&/|list)))) + (range (count (or arr-obrackets arr-pbrackets ""))))) + )))))) + +(defn instance-param + "(-> (Lux Type) (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" + [existential matchings refl-type] + (cond (instance? Class refl-type) + (return (class->type refl-type)) + + (instance? GenericArrayType refl-type) + (|do [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] + (return (&/$Primitive array-data-tag (&/|list inner-type)))) + + (instance? ParameterizedType refl-type) + (|do [:let [refl-type* ^ParameterizedType refl-type] + params* (->> refl-type* + .getActualTypeArguments + seq &/->list + (&/map% (partial instance-param existential matchings)))] + (return (&/$Primitive (->> refl-type* ^Class (.getRawType) .getName) + params*))) + + (instance? TypeVariable refl-type) + (let [gvar (.getName ^TypeVariable refl-type)] + (if-let [m-type (&/|get gvar matchings)] + (return m-type) + (&/fail-with-loc (str "[Host Error] Unknown generic type-variable: " gvar "\n" + "Available type-variables: " (->> matchings + (&/|map &/|first) + &/->seq))))) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (instance-param existential matchings bound) + existential))) + +(defn principal-class [refl-type] + (cond (instance? Class refl-type) + (let [class-type (class->type refl-type)] + (if (type= Any class-type) + "V" + (|case class-type + (&/$Primitive "#Array" (&/$Cons (&/$Primitive class-name _) (&/$Nil))) + (str "[" (&host-generics/->type-signature class-name)) + + (&/$Primitive class-name _) + (&host-generics/->type-signature class-name)))) + + (instance? GenericArrayType refl-type) + (str "[" (principal-class (.getGenericComponentType ^GenericArrayType refl-type))) + + (instance? ParameterizedType refl-type) + (&host-generics/->type-signature (->> ^ParameterizedType refl-type ^Class (.getRawType) .getName)) + + (instance? TypeVariable refl-type) + (if-let [bound (->> ^TypeVariable refl-type .getBounds seq first)] + (principal-class bound) + (&host-generics/->type-signature "java.lang.Object")) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (principal-class bound) + (&host-generics/->type-signature "java.lang.Object")))) + +(defn instance-gtype + "(-> (Lux Type) (List (, Text Type)) GenericType (Lux Type))" + [existential matchings gtype] + (|case gtype + (&/$GenericArray component-type) + (|do [inner-type (instance-gtype existential matchings component-type)] + (return (&/$Primitive array-data-tag (&/|list inner-type)))) + + (&/$GenericClass type-name type-params) + ;; When referring to type-parameters during class or method + ;; definition, a type-environment is set for storing the names + ;; of such parameters. + ;; When a "class" shows up with the name of one of those + ;; parameters, it must be detected, and the bytecode class-name + ;; must correspond to Object's. + + (if-let [m-type (&/|get type-name matchings)] + (return m-type) + (|do [params* (&/map% (partial instance-gtype existential matchings) + type-params)] + (return (&/$Primitive type-name params*)))) + + (&/$GenericTypeVar var-name) + (if-let [m-type (&/|get var-name matchings)] + (return m-type) + (&/fail-with-loc (str "[Host Error] Unknown generic type-variable: " var-name "\n" + "Available type-variables: " (->> matchings + (&/|map &/|first) + &/->seq)))) + + (&/$GenericWildcard) + existential)) + +;; [Utils] +(defn ^:private translate-params + "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" + [existential super-type-params sub-type-params params] + (|let [matchings (match-params sub-type-params params)] + (&/map% (partial instance-param existential matchings) super-type-params))) + +(defn ^:private raise* + "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" + [existential sub+params ^Class super] + (|let [[^Class sub params] sub+params] + (if (.isInterface super) + (|do [:let [super-params (->> sub + .getGenericInterfaces + (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) + (if (instance? Class %) + (&/|list) + (->> ^ParameterizedType % .getActualTypeArguments seq &/->list)) + nil)))] + params* (translate-params existential + (or super-params (&/|list)) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T [super params*]))) + (let [super* (.getGenericSuperclass sub)] + (cond (instance? Class super*) + (return (&/T [super* (&/|list)])) + + (instance? ParameterizedType super*) + (|do [params* (translate-params existential + (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T [super params*]))) + + :else + (assert false (prn-str super* (class super*) [sub super]))))))) + +(defn- raise + "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" + [existential lineage class params] + (&/fold% (partial raise* existential) (&/T [class params]) lineage)) + +;; [Exports] +(defn find-class! [class class-loader] + (try (return (Class/forName class true class-loader)) + (catch java.lang.ClassNotFoundException ex + (&/fail-with-loc (str "[Host Error] Cannot find class: " (pr-str class)))))) + +(defn ->super-type + "(-> Text Text (List Type) (Lux Type))" + [existential class-loader super-class sub-class sub-params] + (|do [^Class super-class+ (find-class! super-class class-loader) + ^Class sub-class+ (find-class! sub-class class-loader)] + (if (.isAssignableFrom super-class+ sub-class+) + (let [lineage (trace-lineage sub-class+ super-class+)] + (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (&/$Primitive (.getName sub-class*) sub-params*)))) + (&/fail-with-loc (str "[Host Error] Classes do not have a subtyping relationship: " sub-class " </= " super-class))))) + +(defn as-obj [class] + (case class + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + class)) + +(let [primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}] + (defn primitive-type? [type-name] + (contains? primitive-types type-name))) + +(def ^:private lux-jvm-type-combos + #{#{"java.lang.Boolean" "#Bit"} + #{"java.lang.Long" i64-data-tag} + #{"java.lang.Double" "#Frac"} + #{"java.lang.String" "#Text"}}) + +(defn ^:private lux-type? [^String class-name] + (.startsWith class-name "#")) + +(defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual] + (|let [[^String e!name e!params] expected + [^String a!name a!params] actual] + (try (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (cond (= e!name a!name) + (if (= (&/|length e!params) (&/|length a!params)) + (|do [_ (&/map2% check e!params a!params)] + (return fixpoints)) + (check-error "" (&/$Primitive e!name e!params) (&/$Primitive a!name a!params))) + + (or (lux-type? e!name) + (lux-type? a!name)) + (if (or (= "java.lang.Object" e!name) + (contains? lux-jvm-type-combos #{e!name a!name}) + (and (not (primitive-type? e!name)) + (= null-data-tag a!name))) + (return fixpoints) + (check-error "" (&/$Primitive e!name e!params) (&/$Primitive a!name a!params))) + + (not invariant??) + (|do [actual* (->super-type existential class-loader e!name a!name a!params)] + (check (&/$Primitive e!name e!params) actual*)) + + :else + (check-error "" (&/$Primitive e!name e!params) (&/$Primitive a!name a!params)))) + (catch Exception e + (throw e))))) + +(defn gtype->gclass + "(-> GenericType GenericClass)" + [gtype] + (cond (instance? Class gtype) + (&/$GenericClass (.getName ^Class gtype) &/$Nil) + + (instance? GenericArrayType gtype) + (&/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype))) + + (instance? ParameterizedType gtype) + (let [type-name (->> ^ParameterizedType gtype ^Class (.getRawType) .getName) + type-params (->> ^ParameterizedType gtype + .getActualTypeArguments + seq &/->list + (&/|map gtype->gclass))] + (&/$GenericClass type-name type-params)) + + (instance? TypeVariable gtype) + (&/$GenericTypeVar (.getName ^TypeVariable gtype)) + + (instance? WildcardType gtype) + (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] + (&/$GenericWildcard (&/$Some (&/T &/$UpperBound (gtype->gclass bound)))) + (if-let [bound (->> ^WildcardType gtype .getLowerBounds seq first)] + (&/$GenericWildcard (&/$Some (&/T &/$LowerBound (gtype->gclass bound)))) + (&/$GenericWildcard &/$None))))) + +(let [generic-type-sig "Ljava/lang/Object;"] + (defn gclass->sig + "(-> GenericClass Text)" + [gclass] + (|case gclass + (&/$GenericClass gclass-name (&/$Nil)) + (case gclass-name + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "J" + "float" "F" + "double" "D" + "char" "C" + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") gclass-name + ;; else + (str "L" (clojure.string/replace gclass-name #"\." "/") ";")) + + (&/$GenericArray inner-gtype) + (str "[" (gclass->sig inner-gtype)) + + (&/$GenericTypeVar ?vname) + generic-type-sig + + (&/$GenericWildcard _) + generic-type-sig + ))) |