diff options
Diffstat (limited to 'lux-bootstrapper/src')
39 files changed, 13380 insertions, 0 deletions
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 + ))) |