diff options
| -rw-r--r-- | source/lux.lux | 17 | ||||
| -rw-r--r-- | src/lux.clj | 94 | ||||
| -rw-r--r-- | src/lux/analyser.clj | 595 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 683 | ||||
| -rw-r--r-- | src/lux/compiler/case.clj | 568 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 194 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 176 | ||||
| -rw-r--r-- | src/lux/host.clj | 3 | ||||
| -rw-r--r-- | src/lux/macro.clj (renamed from src/lux/macros.clj) | 26 | ||||
| -rw-r--r-- | src/lux/type.clj | 49 |
10 files changed, 1195 insertions, 1210 deletions
diff --git a/source/lux.lux b/source/lux.lux index 3e29a50c9..f11e8031b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -67,6 +67,16 @@ [java.lang.Object _7] [java.lang.Object _8]]) ## Base functions & macros +(def' let' + (lambda' _ tokens + (lambda' _ state + (case' tokens + (#Cons lhs (#Cons rhs (#Cons body #Nil))) + [(#Cons (#Form (#Cons (#Ident "case'") (#Cons rhs (#Cons lhs (#Cons body #Nil))))) + #Nil) + state]) + ))) + (def' lambda (lambda' _ tokens (lambda' _ state @@ -84,7 +94,8 @@ (#Cons (#Form (#Cons (#Ident "_") args')) (#Cons body #Nil))))) #Nil)))))) - [(#Cons output #Nil) state])))) + [(#Cons output #Nil) state]) + ))) (declare-macro lambda) (def' def @@ -106,6 +117,10 @@ [(#Cons output #Nil) state]))) (declare-macro def) +(def (comment tokens state) + [#Nil state]) +(declare-macro comment) + (def (+ x y) (jvm;iadd x y)) diff --git a/src/lux.clj b/src/lux.clj index 3e0b3e9c0..3c29968de 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -10,9 +10,6 @@ ;; TODO: Make macros monadic. ;; TODO: Finish type system. ;; TODO: Re-implement compiler in language. - ;; TODO: Add signatures & structures OR type-classes. - ;; TODO: Add type-level computations. - ;; TODO: Add thunks. ;; TODO: Do tail-call optimization. ;; TODO: Adding metadata to global vars. ;; TODO: Add records. @@ -20,8 +17,7 @@ ;; TODO: Add extra arities (apply2, apply3, ..., apply16) ;; TODO: Allow setting fields. ;; TODO: monitor enter & monitor exit. - ;; TODO: Reinplement "if" as a macro on top of case. - ;; TODO: Remember to optimized calling global functions. + ;; TODO: Remember to optimize calling global functions. ;; TODO: Reader macros. ;; TODO: ;; TODO: @@ -31,94 +27,6 @@ (time (&compiler/compile-all ["lux" ;; "test2" ])) - - - (deftype (Session c p s) - (-> (-> p s c) c)) - - ;; (: bind (All [m a b] - ;; (-> (-> a (m b)) (m a) (m b)))) - - (do (defn >> [v] - (fn [session] - (session v))) - - (defn >> [v] - (client v (fn [_ client*] - (k _ client*)))) - - (def << - (server nil (fn [v server*] - (k v server*)))) - - (defn pipe []) - - (<< (fn [x server*] - (server* nil (fn [y server**] - (server** (+ x y) k))))) - - (def (select' k) - (lambda [msg session] - (session nil (k msg)))) - - (def (choose choice) - (lambda [msg session] - (session choice ...))) - - (def << - (lambda [next peer] - (peer [] (lambda [x peer'] - (next x peer'))))) - - (def (>> x) - (lambda [next peer] - (peer x (lambda [_ peer'] - (next [] peer'))))) - - (def server - (loop [_ []] - (select #Add - (do [x << - y << - _ (>> (+ x y))] - (recur [])) - - #Neg - (do [x << - _ (>> (neg x))] - (recur [])) - - #Quit - end))) - - (def client - (do [_ (choose #Add) - _ (>> 5) - _ (>> 10) - x+y <<] - (choose #Quit))) - - (def <END> - (fn [session] - nil)) - - (bind << (fn [x] - (bind << (fn [y] - (>> (+ x y)))))) - - (do [x << - y <<] - (>> (+ x y))) - - (defn <$> [consumer producer init] - (let [[x producer*] (producer init) - [y consumer*] (consumer x)] - [consumer* producer* y])) - - ((<$> (<< <END>) ((>> 5) <END>))) - ) - - ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2 ;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd .. ) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3183c7166..de75b9f26 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -6,7 +6,7 @@ normalize-ident]] [parser :as &parser] [type :as &type] - [macros :as ¯os] + [macro :as ¯o] [host :as &host]))) ;; [Util] @@ -71,7 +71,7 @@ _ =return)))) -(defn ^:private with-let [name mode type body] +(defn ^:private with-local [name mode type body] (fn [state] (let [old-mappings (-> state ::&util/local-envs first (get-in [:locals :mappings])) =return (body (update-in state [::&util/local-envs] @@ -95,9 +95,9 @@ _ =return)))) -(defn ^:private with-lets [locals monad] +(defn ^:private with-locals [locals monad] (reduce (fn [inner [label elem]] - (with-let label :local elem inner)) + (with-local label :local elem inner)) monad (reverse locals))) @@ -106,22 +106,29 @@ [::&util/ok [state (-> state ::&util/local-envs first :closure :mappings)]])) (defn ^:private analyse-1 [elem] - (exec [output (analyse-ast elem) - _ (&util/assert! (= 1 (count output)) "[Analyser Error] Can't expand to other than 1 element.")] - (return (first output)))) + (exec [output (analyse-ast elem)] + (match output + ([x] :seq) + (return x) + + :else + (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn ^:private analyse-2 [el1 el2] - (exec [output (mapcat-m analyse-ast (list el1 el2)) - _ (&util/assert! (= 2 (count output)) - "[Analyser Error] Can't expand to other than 2 elements.")] - (return [(first output) (second output)]))) + (exec [output (mapcat-m analyse-ast (list el1 el2))] + (match output + ([x y] :seq) + (return [x y]) + + :else + (fail "[Analyser Error] Can't expand to other than 2 elements.")))) (defn ^:private with-lambda [self self-type arg arg-type body] (fn [state] (let [body* (with-env (-> state ::&util/local-envs first :inner-closures str) (exec [$scope &util/get-scope] - (with-let self :self self-type - (with-let arg :local arg-type + (with-local self :self self-type + (with-local arg :local arg-type (exec [=return body =captured captured-vars] (return [$scope =next =captured =return]))))))] @@ -133,9 +140,9 @@ (match register [::Expression _ register-type] (let [register* [::Expression [::captured scope (get-in frame [:closure :counter]) register] register-type]] - [register* (-> frame - (update-in [:closure :counter] inc) - (assoc-in [:closure :mappings ident] register*))]))) + [register* (update-in frame [:closure] #(-> % + (update-in [:counter] inc) + (assoc-in [:mappings ident] register*)))]))) (defn ^:private extract-ident [ident] (match ident @@ -162,8 +169,8 @@ (-> % :closure :mappings (contains? ident) not)) [inner outer] (split-with no-binding? stack*)] (if (empty? outer) - (if-let [global|import (get-in state [::&util/global-env ident])] - [::&util/ok [state (list global|import)]] + (if-let [global (get-in state [::&util/global-env ident])] + [::&util/ok [state (list global)]] [::&util/failure (str "[Analyser Error] Unresolved identifier: " ident)]) (let [[=local inner*] (reduce (fn [[register new-inner] frame] (let [[register* frame*] (close-over (:name frame) ident register frame)] @@ -186,18 +193,8 @@ [::global ?module ?name] (exec [macro? (macro? ?module ?name)] (if macro? - (let [macro-class (str ?module "$" (normalize-ident ?name)) - output (-> (.loadClass loader macro-class) - .getDeclaredConstructors - first - (.newInstance (to-array [(int 0) nil])) - (.apply (¯os/->lux+ loader ?args)) - (.apply nil)) - ;; _ (prn 'output (str ?module ":" ?name) output (.-_1 output) (.-tag (.-_1 output))) - macro-expansion (¯os/->clojure+ (.-_1 output)) - state* (.-_2 output) - ;; _ (prn 'macro-expansion (str ?module ":" ?name) state* macro-expansion) - ] + (let [macro-class (&host/location (list ?name ?module)) + [macro-expansion state*] (¯o/expand loader macro-class)] (mapcat-m analyse-ast macro-expansion)) (exec [=args (mapcat-m analyse-ast ?args) :let [[needs-num =return-type] (match =fn-type @@ -223,450 +220,174 @@ =exprs-types (map-m expr-type =exprs)] (return (list [::Expression [::do =exprs] (last =exprs-types)])))) -(do-template [<name> <tag>] - (defn <name> [tests ?token body-id] - (match (:struct tests) - [<tag> ?patterns ?defaults] - {:struct [<tag> (update-in ?patterns [?token] (fn [bodies] - (if bodies - (conj bodies body-id) - #{body-id}))) - ?defaults] - :branches (conj (:branches tests) body-id)} - - [::???Tests] - {:struct [<tag> {?token #{body-id}} (list)] - :branches (conj (:branches tests) body-id)} +(defn ^:private locals [member] + (match member + [::&parser/Ident ?name] + (list ?name) - :else - (assert false "Can't do match."))) + [::&parser/Tuple ?submembers] + (mapcat locals ?submembers) - ^:private bool-tests ::BoolTests - ^:private int-tests ::IntTests - ^:private real-tests ::RealTests - ^:private char-tests ::CharTests - ^:private text-tests ::TextTests - ) + [::&parser/Form ([[::&parser/Tag _] & ?submembers] :seq)] + (mapcat locals ?submembers) -(defn with-default [struct ?local $body] - (match (:struct tests) - [::BoolTests ?patterns ?defaults] - {:struct [::BoolTests ?patterns (conj ?defaults [::default ?local $body])] - :branches (conj (:branches tests) body-id)} + _ + (list))) - [::IntTests ?patterns ?defaults] - {:struct [::IntTests ?patterns (conj ?defaults [::default ?local $body])] - :branches (conj (:branches tests) body-id)} +(defn ^:private analyse-branch [max-registers [bindings body]] + (reduce (fn [body* name] + (with-local name :local +dont-care-type+ body*)) + (reduce (fn [body* _] + (with-local "#" :local +dont-care-type+ body*)) + (analyse-1 body) + (range (- max-registers (count bindings)))) + bindings)) - [::RealTests ?patterns ?defaults] - {:struct [::RealTests ?patterns (conj ?defaults [::default ?local $body])] - :branches (conj (:branches tests) body-id)} +(defn ^:private analyse-case [analyse-ast ?variant ?branches] + (exec [=variant (analyse-1 ?variant) + _ (assert! (and (> (count ?branches) 0) (even? (count ?branches))) + "Unbalanced branches in \"case'\" expression.") + :let [branches (partition 2 ?branches) + locals-per-branch (map locals (map first branches)) + max-locals (reduce max 0 (map count locals-per-branch))] + base-register next-local-idx + =bodies (map-m (partial analyse-branch max-locals) + (map vector locals-per-branch (map second branches))) + =body-types (map-m expr-type =bodies) + =case-type (reduce-m &type/merge [::&type/Nothing] =body-types) + :let [=branches (map vector (map first branches) =bodies)]] + (return (list [::Expression [::case =variant base-register max-locals =branches] =case-type])))) - [::CharTests ?patterns ?defaults] - {:struct [::CharTests ?patterns (conj ?defaults [::default ?local $body])] - :branches (conj (:branches tests) body-id)} +(defn ^:private raise-expr [arg syntax] + (match syntax + [::Expression ?form ?type] + (match ?form + [::bool ?value] + syntax - [::TextTests ?patterns ?defaults] - {:struct [::TextTests ?patterns (conj ?defaults [::default ?local $body])] - :branches (conj (:branches tests) body-id)} - )) + [::int ?value] + syntax -(def ^:private product-match [<type> ?tag ?members body-id] - (condp = (:type struct) - <type> (update-in struct [:patterns] - (fn [branches] - (if-let [{:keys [arity cases]} (get branches ?tag)] - (if (= arity (count ?members)) - (-> branches - (update-in [?tag :cases] conj {:case ?members - :body body-id}) - (update-in [?tag :branches] conj body-id)) - (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity))) - (assoc branches ?tag {:arity (count ?members) - :cases [{:case ?members - :body body-id}] - :branches #{body-id}})))) - nil (-> struct - (assoc :type <type>) - (assoc-in [:patterns ?tag] {:arity (count ?members) - :cases [{:case ?members - :body body-id}] - :branches #{body-id}})) - ;; else - (assert false "Can't do match.") - )) + [::real ?value] + syntax -(def ^:private gen-product-branches [generate-branches <type> branches] - (do (assert (<= (count (:defaults branches)) 1)) - {:type <type> - :patterns (into {} (for [[?tag ?struct] (:patterns branches)] - [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)] - (map #(vector % body) case)))] - (map generate-branches grouped-parts)) - :branches (:branches ?struct)}])) - :default (-> branches :defaults first) - :branches (:branches branches)})) - -(let [fold-branch (fn [struct [pattern $body]] - (match pattern - [::BoolPM ?value] - (bool-tests struct $body) - - [::IntPM ?value] - (int-tests struct $body) - - [::RealPM ?value] - (real-tests struct $body) - - [::CharPM ?token] - (char-tests struct $body) - - [::TextPM ?text] - (text-tests struct $body) - - [::TuplePM ?members] - (product-match struct ::tuple-tests nil ?members $body) - - [::VariantPM ?tag ?members] - (product-match struct ::variant-tests ?tag ?members $body) - - [::LocalPM ?local] - (with-default struct ?local $body) - )) - base-struct [::???Tests] - generate-branches (fn generate-branches [data] - (let [branches* (reduce fold-branch base-struct data)] - (match branches* - [::BoolTests _] branches* - [::IntTests _] branches* - [::RealTests _] branches* - [::CharTests _] branches* - [::TextTests _] branches* - ::TupleTests (gen-product-branches generate-branches ::tuple-tests branches*) - ::VariantTests (gen-product-branches generate-branches ::variant-tests branches*) - nil {:type ::defaults, - :stores (reduce (fn [total [_ ?store ?body]] - (update-in total [?store] (fn [mapping] - (if mapping - (conj mapping ?body) - #{?body})))) - {} - (:defaults branches*)) - :branches (:branches branches*)}))) - get-vars (fn get-vars [pattern] - (match pattern - [::&parser/Bool ?value] - (list) - - [::&parser/Int ?value] - (list) - - [::&parser/Real ?value] - (list) - - [::&parser/Char ?token] - (list) - - [::&parser/Text ?text] - (list) - - [::&parser/Tag _] - (list) - - [::&parser/Ident ?name] - (list ?name) - - [::&parser/Tuple ?members] - (mapcat get-vars ?members) - - [::&parser/Form ([[::&parser/Tag _] & ?members] :seq)] - (mapcat get-vars ?members) - )) - ->instructions (fn ->instructions [locals pattern] - (clojure.core.match/match pattern - [::&parser/Bool ?value] - [::BoolPM ?value] - - [::&parser/Int ?value] - [::IntPM ?value] - - [::&parser/Real ?value] - [::RealPM ?value] - - [::&parser/Char ?value] - [::CharPM ?value] - - [::&parser/Text ?value] - [::TextPM ?value] - - [::&parser/Tag ?tag] - [::VariantPM ?tag (list)] - - [::&parser/Ident ?name] - [::LocalPM (get locals ?name)] - - [::&parser/Tuple ?members] - [::TuplePM (map (partial ->instructions locals) ?members)] - - [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)] - [::VariantPM ?tag (map (partial ->instructions locals) ?members)] - ))] - (defn ^:private ->decision-tree [$base branches] - (let [vars (for [branch branches] - (clojure.core.match/match branch - [::case-branch ?pattern ?body] - (get-vars ?pattern))) - [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch] - (clojure.core.match/match branch - [::case-branch ?pattern ?body] - [(inc $link) (assoc links $link ?body) (conj branches* [::case-branch ?pattern $link])])) - [0 {} []] - branches) - branches** (for [[branch branch-vars] (map vector branches* vars) - :let [[_ locals] (reduce (fn [[$local =locals] $var] - [(inc $local) (assoc =locals $var [::local $local])]) - [$base {}] branch-vars)]] - (clojure.core.match/match branch - [::case-branch ?pattern ?body] - [(->instructions locals ?pattern) ?body])) - max-registers (reduce max 0 (map count vars))] - [max-registers branch-mappings (generate-branches branches**)]))) - -(defn ^:private locals-getter [?member] - (match ?member - [::&parser/Ident ?name] - (list [?name +dont-care-type+]) + [::char ?value] + syntax - [::&parser/Tuple ?submembers] - (mapcat locals-getter ?submembers) + [::text ?value] + syntax + + [::tuple ?members] + [::Expression [::tuple (map (partial raise-expr arg) ?members)] ?type] - [::&parser/Form ([[::&parser/Tag ?subtag] & ?submembers] :seq)] - (mapcat locals-getter ?submembers) + [::variant ?tag ?members] + [::Expression [::variant ?tag (map (partial raise-expr arg) ?members)] ?type] + + [::local ?idx] + [::Expression [::local (inc ?idx)] ?type] + + [::captured _ _ ?source] + ?source - _ - (list) - )) + [::self ?curried] + [::Expression [::self (cons arg (map (partial raise-expr arg) ?curried))] ?type] -(defn ^:private analyse-case-branches [branches] - (map-m (fn [[?pattern ?body]] - (match ?pattern - [::&parser/Bool ?token] - (exec [=body (analyse-1 ?body)] - (return [::case-branch ?pattern =body])) - - [::&parser/Int ?token] - (exec [=body (analyse-1 ?body)] - (return [::case-branch ?pattern =body])) - - [::&parser/Real ?token] - (exec [=body (analyse-1 ?body)] - (return [::case-branch ?pattern =body])) - - [::&parser/Char ?token] - (exec [=body (analyse-1 ?body)] - (return [::case-branch ?pattern =body])) - - [::&parser/Text ?token] - (exec [=body (analyse-1 ?body)] - (return [::case-branch ?pattern =body])) - - [::&parser/Ident ?name] - (exec [=body (with-let ?name :local +dont-care-type+ - (analyse-1 ?body))] - (return [::case-branch ?pattern =body])) - - [::&parser/Tag ?tag] - (exec [=body (analyse-1 ?body)] - (return [::case-branch ?pattern =body])) - - [::&parser/Tuple ?members] - (exec [=body (with-lets (mapcat locals-getter ?members) - (analyse-1 ?body))] - (return [::case-branch ?pattern =body])) - - [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)] - (exec [=body (with-lets (mapcat locals-getter ?members) - (analyse-1 ?body))] - (return [::case-branch ?pattern =body])) - )) - branches)) + [::global _ _] + syntax -(defn ^:private analyse-case [analyse-ast ?variant ?branches] - (exec [=variant (analyse-1 ?variant) - _ (assert! (and (> (count ?branches) 0) (even? (count ?branches))) - "Imbalanced branches in \"case'\" expression.") - $base next-local-idx - [num-registers mappings tree] (exec [=branches (analyse-case-branches (partition 2 ?branches))] - (return (->decision-tree $base =branches)))] - (return (list [::Expression [::case $base =variant num-registers mappings tree] +dont-care-type+])))) - -(defn ^:private raise-tree-bindings [raise-expr arg ?tree] - (let [tree-partial-f (partial raise-tree-bindings raise-expr arg)] - (case (:type ?tree) - (::tuple ::variant) - (-> ?tree - (update-in [:patterns] - #(into {} (for [[?tag ?unapply] %] - [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))]))) - (update-in [:default] - (fn [[tag local $branch :as total]] - (if total - (match (raise-expr arg [::Expression local [::&type/Nothing]]) - [::Expression local* [::&type/Nothing]] - [tag local* $branch]))))) - - ::defaults - (update-in ?tree [:stores] - #(into {} (for [[?store ?branches] %] - (match (raise-expr arg [::Expression ?store [::&type/Nothing]]) - [::Expression =store [::&type/Nothing]] - [=store ?branches])))) - ;; else - (assert false (pr-str ?tree)) - ))) + [::case ?variant ?base ?num-bindings ?pm-struct] + ... -(defn ^:private raise-expr [arg syntax] - ;; (prn 'raise-bindings body) - (let [partial-f (partial raise-expr arg) - tree-partial-f (partial raise-tree-bindings raise-expr arg)] - (match syntax - [::Expression ?form ?type] - (match ?form - [::bool ?value] - syntax - - [::int ?value] - syntax - - [::real ?value] - syntax - - [::char ?value] - syntax - - [::text ?value] - syntax - - [::tuple ?members] - [::Expression [::tuple (map partial-f ?members)] ?type] + [::lambda ?scope ?captured ?args ?value] + [::Expression [::lambda (pop ?scope) + (into {} (for [[?name ?sub-syntax] ?captured] + [?name (raise-expr arg ?sub-syntax)])) + ?args + ?value] + ?type] - [::variant ?tag ?members] - [::Expression [::variant ?tag (map partial-f ?members)] ?type] - - [::local ?idx] - [::Expression [::local (inc ?idx)] ?type] - - [::captured _ _ ?source] - ?source - - [::self ?curried] - [::Expression [::self (cons arg (map partial-f ?curried))] ?type] - - [::global _ _] - syntax - - [::let ?idx ?value ?body] - [::Expression [::let (inc ?idx) (partial-f ?value) - (partial-f ?body)] - ?type] - - [::case ?base ?variant ?registers ?mappings ?tree] - (let [=variant (partial-f ?variant) - =mappings (into {} (for [[idx syntax] ?mappings] - [idx (partial-f syntax)])) - =tree (tree-partial-f ?tree)] - [::Expression [::case (inc ?base) =variant ?registers =mappings =tree] ?type]) - - [::lambda ?scope ?captured ?args ?value] - [::Expression [::lambda (pop ?scope) - (into {} (for [[?name ?sub-syntax] ?captured] - [?name (partial-f ?sub-syntax)])) - ?args - ?value] - ?type] - - [::call ?func ?args] - [::Expression [::call (partial-f ?func) (map partial-f ?args)] ?type] - - [::do ?asts] - [::Expression [::do (map partial-f ?asts)] ?type] - - [::jvm-getstatic _ _] - syntax - - [::jvm-invokevirtual ?class ?method ?arg-classes ?obj ?args] - [::Expression [::jvm-invokevirtual ?class ?method ?arg-classes - (partial-f ?obj) - (map partial-f ?args)] - ?type] + [::call ?func ?args] + [::Expression [::call (raise-expr arg ?func) (map (partial raise-expr arg) ?args)] ?type] - ;; Integer arithmetic - [::jvm-iadd ?x ?y] - [::Expression [::jvm-iadd (partial-f ?x) (partial-f ?y)] ?type] + [::do ?asts] + [::Expression [::do (map (partial raise-expr arg) ?asts)] ?type] - [::jvm-isub ?x ?y] - [::Expression [::jvm-isub (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-getstatic _ _] + syntax + + [::jvm-invokevirtual ?class ?method ?arg-classes ?obj ?args] + [::Expression [::jvm-invokevirtual ?class ?method ?arg-classes + (raise-expr arg ?obj) + (map (partial raise-expr arg) ?args)] + ?type] - [::jvm-imul ?x ?y] - [::Expression [::jvm-imul (partial-f ?x) (partial-f ?y)] ?type] + ;; Integer arithmetic + [::jvm-iadd ?x ?y] + [::Expression [::jvm-iadd (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-idiv ?x ?y] - [::Expression [::jvm-idiv (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-isub ?x ?y] + [::Expression [::jvm-isub (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-irem ?x ?y] - [::Expression [::jvm-irem (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-imul ?x ?y] + [::Expression [::jvm-imul (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - ;; Long arithmetic - [::jvm-ladd ?x ?y] - [::Expression [::jvm-ladd (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-idiv ?x ?y] + [::Expression [::jvm-idiv (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-lsub ?x ?y] - [::Expression [::jvm-lsub (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-irem ?x ?y] + [::Expression [::jvm-irem (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-lmul ?x ?y] - [::Expression [::jvm-lmul (partial-f ?x) (partial-f ?y)] ?type] + ;; Long arithmetic + [::jvm-ladd ?x ?y] + [::Expression [::jvm-ladd (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-ldiv ?x ?y] - [::Expression [::jvm-ldiv (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-lsub ?x ?y] + [::Expression [::jvm-lsub (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-lrem ?x ?y] - [::Expression [::jvm-lrem (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-lmul ?x ?y] + [::Expression [::jvm-lmul (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - ;; Float arithmetic - [::jvm-fadd ?x ?y] - [::Expression [::jvm-fadd (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-ldiv ?x ?y] + [::Expression [::jvm-ldiv (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-fsub ?x ?y] - [::Expression [::jvm-fsub (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-lrem ?x ?y] + [::Expression [::jvm-lrem (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-fmul ?x ?y] - [::Expression [::jvm-fmul (partial-f ?x) (partial-f ?y)] ?type] + ;; Float arithmetic + [::jvm-fadd ?x ?y] + [::Expression [::jvm-fadd (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-fdiv ?x ?y] - [::Expression [::jvm-fdiv (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-fsub ?x ?y] + [::Expression [::jvm-fsub (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-frem ?x ?y] - [::Expression [::jvm-frem (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-fmul ?x ?y] + [::Expression [::jvm-fmul (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - ;; Double arithmetic - [::jvm-dadd ?x ?y] - [::Expression [::jvm-dadd (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-fdiv ?x ?y] + [::Expression [::jvm-fdiv (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-dsub ?x ?y] - [::Expression [::jvm-dsub (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-frem ?x ?y] + [::Expression [::jvm-frem (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-dmul ?x ?y] - [::Expression [::jvm-dmul (partial-f ?x) (partial-f ?y)] ?type] + ;; Double arithmetic + [::jvm-dadd ?x ?y] + [::Expression [::jvm-dadd (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-ddiv ?x ?y] - [::Expression [::jvm-ddiv (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-dsub ?x ?y] + [::Expression [::jvm-dsub (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - [::jvm-drem ?x ?y] - [::Expression [::jvm-drem (partial-f ?x) (partial-f ?y)] ?type] + [::jvm-dmul ?x ?y] + [::Expression [::jvm-dmul (raise-expr arg ?x) (raise-expr arg ?y)] ?type] - _ - (assert false syntax) - )))) + [::jvm-ddiv ?x ?y] + [::Expression [::jvm-ddiv (raise-expr arg ?x) (raise-expr arg ?y)] ?type] + + [::jvm-drem ?x ?y] + [::Expression [::jvm-drem (raise-expr arg ?x) (raise-expr arg ?y)] ?type] + + _ + (assert false syntax) + ))) (defn ^:private analyse-lambda [analyse-ast ?self ?arg ?body] (exec [[_ =arg =return :as =function] &type/fresh-function diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 1ff3a503e..742455b86 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -11,7 +11,8 @@ [type :as &type] [lexer :as &lexer] [parser :as &parser] - [analyser :as &analyser]) + [analyser :as &analyser] + [host :as &host]) :reload) (:import (org.objectweb.asm Opcodes Label @@ -19,9 +20,6 @@ MethodVisitor))) ;; [Utils/General] -(defn ^:private storage-id [scope] - (->> scope reverse (map normalize-ident) (interpose "$") (reduce str ""))) - (defn ^:private write-file [file data] (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))] (.write stream data))) @@ -45,6 +43,7 @@ (def ^:private +local-prefix+ "l") (def ^:private +partial-prefix+ "p") (def ^:private +closure-prefix+ "c") +(def ^:private +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;") (def ^:private ->package ->class) @@ -163,11 +162,9 @@ (defn ^:private compile-global [compile *type* ?owner-class ?name] (exec [*writer* &util/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (storage-id (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (&host/location (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]] (return nil))) -(def +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;") - (defn ^:private compile-call [compile *type* ?fn ?args] (exec [*writer* &util/get-writer _ (compile ?fn) @@ -184,7 +181,7 @@ :let [_ (match (:form ?fn) [::&analyser/global ?owner-class ?fn-name] (let [arg-sig (->type-signature "java.lang.Object") - call-class (storage-id (list ?fn-name ?owner-class)) + call-class (&host/location (list ?fn-name ?owner-class)) provides-num (count ?args)] (if (>= provides-num ?needs-num) (let [impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)] @@ -209,122 +206,6 @@ )]] (return nil))) -(defn ^:private compile-jvm-getstatic [compile *type* ?class ?field] - (exec [*writer* &util/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?class) ?field (->java-sig *type*))]] - (return nil))) - -(defn ^:private compile-jvm-getfield [compile *type* ?class ?field ?object] - (exec [*writer* &util/get-writer - _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))] - :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (->class ?class) ?field (->java-sig *type*))]] - (return nil))) - -(let [class+metthod+sig {"boolean" [(->class "java.lang.Boolean") "booleanValue" "()Z"] - "byte" [(->class "java.lang.Byte") "byteValue" "()B"] - "short" [(->class "java.lang.Short") "shortValue" "()S"] - "int" [(->class "java.lang.Integer") "intValue" "()I"] - "long" [(->class "java.lang.Long") "longValue" "()J"] - "float" [(->class "java.lang.Float") "floatValue" "()F"] - "double" [(->class "java.lang.Double") "doubleValue" "()D"] - "char" [(->class "java.lang.Character") "charValue" "()C"]}] - (defn ^:private prepare-arg! [*writer* class-name] - (if-let [[class method sig] (get class+metthod+sig class-name)] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST class) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) - (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name))))) - -;; (let [boolean-class "java.lang.Boolean" -;; integer-class "java.lang.Integer" -;; char-class "java.lang.Character"] -;; (defn prepare-return! [*writer* *type*] -;; (match *type* -;; ::&type/nothing -;; (.visitInsn *writer* Opcodes/ACONST_NULL) - -;; [::&type/primitive "char"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class))) - -;; [::&type/primitive "int"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class))) - -;; [::&type/primitive "boolean"] -;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class))) - -;; [::&type/Data ?oclass] -;; nil))) - -(defn ^:private compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] - (exec [*writer* &util/get-writer - :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))] - _ (map-m (fn [[class-name arg]] - (exec [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) - :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class ?class) ?method method-sig) - ;; (prepare-return! *writer* *type*) - )]] - (return nil))) - -(defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args] - (exec [*writer* &util/get-writer - :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))] - _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))] - _ (map-m (fn [[class-name arg]] - (exec [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) - :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig) - ;; (prepare-return! *writer* *type*) - )]] - (return nil))) - -(defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args] - (exec [*writer* &util/get-writer - :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V") - class* (->class ?class) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW class*) - (.visitInsn Opcodes/DUP))] - _ (map-m (fn [[class-name arg]] - (exec [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (map vector ?classes ?args)) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] - (return nil))) - -(defn ^:private compile-jvm-new-array [compile *type* ?class ?length] - (exec [*writer* &util/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitTypeInsn Opcodes/ANEWARRAY (->class ?class)))]] - (return nil))) - -(defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem] - (exec [*writer* &util/get-writer - _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] - _ (compile ?elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - -(defn ^:private compile-jvm-aaload [compile *type* ?array ?idx] - (exec [*writer* &util/get-writer - _ (compile ?array) - :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) - (.visitInsn Opcodes/AALOAD))]] - (return nil))) - (defn ^:private compile-do [compile *type* ?exprs] (exec [*writer* &util/get-writer _ (map-m (fn [expr] @@ -335,450 +216,12 @@ _ (compile (last ?exprs))] (return nil))) -(do-template [<name> <wrapper-class> <value-method> <method-sig>] - (defn <name> [writer mappings default-label ?pairs] - (doseq [[?token $body] ?pairs - :let [$else (new Label)]] - (doto writer - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>) - (.visitLdcInsn ?token) - (.visitJumpInsn Opcodes/IF_ICMPNE $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel $else))) - (doto writer - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO default-label))) - - ^:private compile-compare-bools "java.lang.Boolean" "booleanValue" "()Z" - ^:private compile-compare-chars "java.lang.Character" "charValue" "()C" - ) - -(do-template [<name> <wrapper-class> <value-method> <method-sig> <cmp-op>] - (defn <name> [writer mappings default-label ?pairs] - (doseq [[?token $body] ?pairs - :let [$else (new Label)]] - (doto writer - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>) - (.visitLdcInsn ?token) - (.visitInsn <cmp-op>) - (.visitJumpInsn Opcodes/IFNE $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel $else))) - (doto writer - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO default-label))) - - ^:private compile-compare-ints "java.lang.Long" "longValue" "()J" Opcodes/LCMP - ^:private compile-compare-reals "java.lang.Double" "doubleValue" "()D" Opcodes/DCMPL - ) - -(defn ^:private compile-compare-texts [writer mappings default-label ?pairs] - (doseq [[?token $body] ?pairs - :let [$else (new Label)]] - (doto writer - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?token) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Object") "equals" (str "(" (->type-signature "java.lang.Object") ")Z")) - (.visitJumpInsn Opcodes/IFEQ $else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel $else))) - (doto writer - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO default-label))) - -(let [+tag-sig+ (->type-signature "java.lang.String") - variant-class* (->class +variant-class+) - tuple-class* (->class +tuple-class+) - +variant-field-sig+ (->type-signature "java.lang.Object") - oclass (->class "java.lang.Object") - equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] - (defn ^:private compile-decision-tree [writer mappings default-label decision-tree] - (match decision-tree - [::test-bool ?pairs] - (compile-compare-bools writer mappings default-label ?pairs) - - [::test-int ?pairs] - (compile-compare-ints writer mappings default-label ?pairs) - - [::test-real ?pairs] - (compile-compare-reals writer mappings default-label ?pairs) - - [::test-char ?pairs] - (compile-compare-chars writer mappings default-label ?pairs) - - [::test-text ?pairs] - (compile-compare-texts writer mappings default-label ?pairs) - - [::store [::&analyser/local ?idx] $body] - (doto writer - (.visitVarInsn Opcodes/ASTORE ?idx) - (.visitJumpInsn Opcodes/GOTO (get mappings $body))) - - [::test-tuple ?branches ?cases] - (let [[_ ?subcases] (first ?cases) - arity (-> ?subcases first (nth 2) count) - tuple-class** (str tuple-class* arity)] - (doto writer - ;; object - (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple - (do (doseq [subcase ?subcases - :let [next-subcase (new Label)]] - (match subcase - [::subcase $body ?subseq] - (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq))) - :let [sub-next-elem (new Label)]] - (doto writer - (.visitInsn Opcodes/DUP) ;; tuple, tuple - (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; tuple, object - (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple - (.visitLabel sub-next-elem))) - (doto writer - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel next-subcase))) - ))) - (.visitInsn Opcodes/POP) ;; -> - (.visitJumpInsn Opcodes/GOTO default-label))) - - [::test-variant ?branches ?cases] - (doto writer - ;; object - (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant - (.visitInsn Opcodes/DUP) ;; variant, variant - (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag - (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag - (.visitLdcInsn ?tag) ;; variant, tag, tag, text - (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B - (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag - (.visitInsn Opcodes/POP) ;; variant - (do (let [arity (-> ?subcases first (nth 2) count) - variant-class** (str variant-class* arity)] - (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN - (doseq [subcase ?subcases - :let [next-subcase (new Label)]] - (match subcase - [::subcase $body ?subseq] - (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq))) - :let [sub-next-elem (new Label)]] - (doto writer - (.visitInsn Opcodes/DUP) ;; variant, variant - (.visitFieldInsn Opcodes/GETFIELD variant-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; variant, object - (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; variant - (.visitLabel sub-next-elem))) - (doto writer - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel next-subcase))) - )) - )) - (.visitInsn Opcodes/POP) ;; -> - (.visitJumpInsn Opcodes/GOTO default-label) - ;; variant, tag -> - (.visitLabel tag-else-label)) - (->> (doseq [[?tag ?subcases] ?cases - :let [tag-else-label (new Label)]]))) - ;; variant, tag -> - (.visitInsn Opcodes/POP) ;; variant -> - (.visitInsn Opcodes/POP) ;; -> - (.visitJumpInsn Opcodes/GOTO default-label))) - )) - -(defn ^:private sequence-val [<test-tag> struct branches] - (concat (list [[<test-tag> (for [[?token ?supports] (:patterns struct) - ?body (set/intersection branches ?supports)] - [?token ?body])] - branches]) - (for [[_ ?local ?body] (:defaults struct) - :when (contains? branches ?body)] - [[::store ?local ?body] #{?body}]))) - -(defn ^:private sequence-product [<test-tag> struct branches] - (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns struct) - :let [?parts (:parts ?struct) - num-parts (count ?parts) - ?supports (:branches ?struct) - subcases (for [?body (set/intersection branches ?supports) - subseq (sequence-parts #{?body} ?parts) - :when (= num-parts (count subseq))] - [::subcase ?body subseq])] - :when (not (empty? subcases))] - [?tag subcases]))] - (if (empty? patterns) - '() - (list [[<test-tag> branches patterns] - branches]))) - (if-let [[_ ?local ?body] (:default struct)] - (for [?body (set/intersection branches #{?body})] - [[::store ?local ?body] #{?body}]) - '()))) - -(defn ^:private sequence-parts [branches parts] - (if (empty? parts) - (list (list)) - (let [[head & tail] parts - expanded (case (:type head) - ::&analyser/defaults - (for [[?local ?supports] (:stores head) - ?body (set/intersection branches ?supports)] - [[::store ?local ?body] #{?body}]) - - ::&analyser/bool-tests - (sequence-val ::test-bool head branches) - - ::&analyser/int-tests - (sequence-val ::test-int head branches) - - ::&analyser/real-tests - (sequence-val ::test-real head branches) - - ::&analyser/char-tests - (sequence-val ::test-char head branches) - - ::&analyser/text-tests - (sequence-val ::test-text head branches) - - ::&analyser/tuple - (sequence-product ::test-tuple head branches) - - ::&analyser/variant - (sequence-product ::test-variant head branches) - )] - (for [[step branches*] expanded - tail* (sequence-parts branches* tail)] - (cons step tail*))))) - -(let [oclass (->class "java.lang.Object") - equals-sig (str "(" (->type-signature "java.lang.Object") ")Z") - ex-class (->class "java.lang.IllegalStateException")] - (defn ^:private compile-case [compile *type* ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree] - (exec [*writer* &util/get-writer - :let [start-label (new Label) - end-label (new Label) - entries (for [[?branch ?body] ?branch-mappings - :let [label (new Label)]] - [[?branch label] - [label ?body]]) - mappings* (into {} (map first entries)) - _ (dotimes [offset ?max-registers] - (let [idx (+ ?base-idx offset)] - (.visitLocalVariable *writer* (str +local-prefix+ idx) (->java-sig [::&type/Any]) nil start-label end-label idx)))] - _ (compile ?variant) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLabel start-label)) - default-label (new Label) - ;; _ (prn '?decision-tree ?decision-tree) - _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))] - (if (or (:default ?decision-tree) - (not (empty? (:defaults ?decision-tree)))) - (butlast pieces) - pieces))] - (compile-decision-tree *writer* mappings* default-label decision-tree)) - (.visitLabel *writer* default-label) - (if-let [[_ [_ ?idx] ?body] (or (:default ?decision-tree) - (first (:defaults ?decision-tree)))] - (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitVarInsn Opcodes/ASTORE ?idx) - (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) - (doto *writer* - (.visitInsn Opcodes/POP) - (.visitTypeInsn Opcodes/NEW ex-class) - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V") - (.visitInsn Opcodes/ATHROW))))] - _ (map-m (fn [[?label ?body]] - (exec [:let [_ (do (.visitLabel *writer* ?label) - (.visitInsn *writer* Opcodes/POP))] - ret (compile ?body) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO end-label)]] - (return ret))) - (map second entries)) - :let [_ (.visitLabel *writer* end-label)]] - (return nil)))) - -(let [clo-field-sig (->type-signature "java.lang.Object") - lambda-return-sig (->type-signature "java.lang.Object") - <init>-return "V" - counter-sig "I" - +datum-sig+ (->type-signature "java.lang.Object")] - (defn ^:private lambda-impl-signature [args] - (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig)) - - (defn ^:private lambda-<init>-signature [closed-over args] - (let [num-args (count args)] - (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig)) - (if (> num-args 1) - (reduce str counter-sig (repeat (dec num-args) clo-field-sig))) - ")" - <init>-return))) - - (defn ^:private add-lambda-<init> [class class-name closed-over args init-signature] - (let [num-args (count args) - num-mappings (count closed-over)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V") - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD ?captured-id) - (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str +closure-prefix+ ?captured-id)]) - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] closed-over]))) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ICONST_0) - (.visitFieldInsn Opcodes/PUTFIELD class-name "_counter" counter-sig) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset)) - (.visitFieldInsn Opcodes/PUTFIELD class-name field-name clo-field-sig)) - (->> (let [field-name (str +partial-prefix+ clo_idx)] - (doto (.visitField class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil) - (.visitEnd))) - (dotimes [clo_idx (dec num-args)]) - (let [offset (+ 2 num-mappings)])))) - (->> (when (> num-args 1)))) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - - (do-template [<name> <prefix>] - (defn <name> [writer class-name vars] - (dotimes [idx (count vars)] - (doto writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name (str <prefix> idx) clo-field-sig)))) - - ^:private add-closure-vars +closure-prefix+ - ^:private add-partial-vars +partial-prefix+ - ) - - (defn ^:private add-nulls [writer amount] - (dotimes [_ amount] - (.visitInsn writer Opcodes/ACONST_NULL))) - - (defn ^:private add-lambda-apply [class class-name closed-over args impl-signature init-signature] - (let [num-args (count args) - num-captured (dec num-args) - default-label (new Label) - branch-labels (for [_ (range num-captured)] - (new Label))] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil) - (.visitCode) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig) - (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels)) - (-> (doto (.visitLabel branch-label) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (add-closure-vars class-name closed-over) - (.visitLdcInsn (int current-captured)) - (add-partial-vars class-name (take current-captured args)) - (.visitVarInsn Opcodes/ALOAD 1) - (add-nulls (- (dec num-captured) current-captured)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" init-signature) - (.visitInsn Opcodes/ARETURN)) - (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))]))) - (.visitLabel default-label)) - (->> (when (> num-args 1)))) - (.visitVarInsn Opcodes/ALOAD 0) - (add-partial-vars class-name (butlast args)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - - (defn ^:private add-lambda-impl [class compile impl-signature impl-body] - (&util/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) - (.visitCode)) - (exec [;; :let [_ (prn 'add-lambda-impl/_0)] - *writer* &util/get-writer - ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)] - ret (compile impl-body) - ;; :let [_ (prn 'add-lambda-impl/_2 ret)] - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))] - ;; :let [_ (prn 'add-lambda-impl/_3)] - ] - (return ret)))) - - (defn ^:private instance-closure [compile lambda-class closed-over args init-signature] - (exec [*writer* &util/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW lambda-class) - (.visitInsn Opcodes/DUP))] - _ (->> closed-over - (sort #(< (-> %1 second :form (nth 2)) - (-> %2 second :form (nth 2)))) - (map-m (fn [[?name ?captured]] - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source] - (compile ?source))))) - :let [num-args (count args) - _ (do (when (> num-args 1) - (.visitInsn *writer* Opcodes/ICONST_0) - (add-nulls *writer* (dec num-args))) - (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature))]] - (return nil))) - - (defn ^:private add-lambda-<clinit> [class class-name args <init>-sig] - (let [num-args (count args)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (doto (.visitInsn *writer* Opcodes/ICONST_0) - (add-nulls (dec num-args))) - (->> (when (> num-args 1)))) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" <init>-sig) - (.visitFieldInsn Opcodes/PUTSTATIC class-name "_datum" +datum-sig+) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - - (defn ^:private compile-lambda [compile *type* ?scope ?closure ?args ?body with-datum? instance?] - (exec [:let [lambda-class (storage-id ?scope) - impl-signature (lambda-impl-signature ?args) - <init>-sig (lambda-<init>-signature ?closure ?args) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - lambda-class nil "java/lang/Object" (into-array [(->class +function-class+)])) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str +closure-prefix+ ?captured-id)]) - (match (:form ?captured) - [::&analyser/captured ?closure-id ?captured-id ?source]) - (doseq [[?name ?captured] ?closure]))) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) - (.visitEnd)) - (->> (when (> (count ?args) 1)))) - (-> (doto (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil) - (add-lambda-<clinit> lambda-class ?args <init>-sig)) - (when with-datum?)) - (add-lambda-apply lambda-class ?closure ?args impl-signature <init>-sig) - (add-lambda-<init> lambda-class ?closure ?args <init>-sig) - )] - _ (add-lambda-impl =class compile impl-signature ?body) - :let [_ (.visitEnd =class)] - _ (save-class! lambda-class (.toByteArray =class))] - (if instance? - (instance-closure compile lambda-class ?closure ?args <init>-sig) - (return nil)))) - ) - (defn ^:private compile-field [compile *type* ?name body] (exec [*writer* &util/get-writer - class-name &analyser/module-name - :let [outer-class (->class class-name) + module-name &analyser/module-name + :let [outer-class (->class module-name) datum-sig (->type-signature "java.lang.Object") - current-class (storage-id (list ?name outer-class)) + current-class (&host/location (list ?name outer-class)) _ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC)) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) @@ -800,101 +243,17 @@ (return nil))) (defn ^:private compile-def [compile *type* name value] - (exec [_ (match value - [::&analyser/Expression ?form _] - (match ?form - [::&analyser/lambda ?scope ?captured ?args ?body] - (compile-lambda compile *type* ?scope ?closure ?args ?body true false) - - _ - (compile-field compile *type* name value)) - - _ - (fail "Can only define expressions."))] - (return nil))) - -(defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods] - (exec [*writer* &util/get-writer - loader &util/loader - :let [parent-dir (->package ?package) - full-name (str parent-dir "/" ?name) - super-class* (->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - full-name nil super-class* nil)) - _ (do (doseq [[field props] ?fields] - (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil) - (.visitEnd))) - (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class* "<init>" "()V") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (.visitEnd =class) - (.mkdirs (java.io.File. (str "output/" parent-dir))))] - _ (save-class! full-name (.toByteArray =class))] - (return nil))) - -(defn ^:private compile-jvm-interface [compile *type* ?package ?name ?fields ?methods] - (exec [*writer* &util/get-writer - loader &util/loader - :let [parent-dir (->package ?package) - full-name (str parent-dir "/" ?name) - =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) - full-name nil "java/lang/Object" nil)) - _ (do (doseq [[?method ?props] ?methods - :let [[?args ?return] (:type ?props) - signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]] - (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) - (.visitEnd =interface) - (.mkdirs (java.io.File. (str "output/" parent-dir))))] - _ (save-class! full-name (.toByteArray =interface))] - (return nil))) - -(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>] - (defn <name> [compile *type* ?x ?y] - (exec [:let [+wrapper-class+ (->class <wrapper-class>)] - *writer* &util/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) - _ (doto *writer* - (.visitInsn <opcode>) - (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (->type-signature <wrapper-class>))))]] - (return nil))) - - ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - - ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - - ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - - ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - ) + (match value + [::&analyser/Expression ?form _] + (match ?form + [::&analyser/lambda ?scope ?captured ?args ?body] + (compile-lambda compile *type* ?scope ?closure ?args ?body true false) + + _ + (compile-field compile *type* name value)) + + _ + (fail "Can only define expressions."))) (defn ^:private compile-self-call [compile ?assumed-args] (exec [*writer* &util/get-writer @@ -944,8 +303,8 @@ [::&analyser/variant ?tag ?members] (compile-variant compile-expression (:type syntax) ?tag ?members) - [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree] - (compile-case compile-expression (:type syntax) ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree) + [::&analyser/case ?variant ?base-register ?num-registers ?branches] + (compile-case compile-expression (:type syntax) ?variant ?base-register ?num-registers ?branches) [::&analyser/lambda ?scope ?frame ?args ?body] (compile-lambda compile-expression (:type syntax) ?scope ?frame ?args ?body false true) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj new file mode 100644 index 000000000..8f35ec2c0 --- /dev/null +++ b/src/lux/compiler/case.clj @@ -0,0 +1,568 @@ + +(let [+tag-sig+ (->type-signature "java.lang.String") + variant-class* (->class +variant-class+) + tuple-class* (->class +tuple-class+) + +variant-field-sig+ (->type-signature "java.lang.Object") + oclass (->class "java.lang.Object") + equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] + (defn ^:private compile-decision-tree [writer mappings default-label decision-tree] + (match decision-tree + [::test-bool ?pairs] + (compile-compare-bools writer mappings default-label ?pairs) + + [::test-int ?pairs] + (compile-compare-ints writer mappings default-label ?pairs) + + [::test-real ?pairs] + (compile-compare-reals writer mappings default-label ?pairs) + + [::test-char ?pairs] + (compile-compare-chars writer mappings default-label ?pairs) + + [::test-text ?pairs] + (compile-compare-texts writer mappings default-label ?pairs) + + [::store ?idx $body] + (doto writer + (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitJumpInsn Opcodes/GOTO (get mappings $body))) + + [::test-tuple ?branches ?cases] + (let [[_ ?subcases] (first ?cases) + arity (-> ?subcases first (nth 2) count) + tuple-class** (str tuple-class* arity)] + (doto writer + ;; object + (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple + (do (doseq [subcase ?subcases + :let [next-subcase (new Label)]] + (match subcase + [::subcase $body ?subseq] + (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq))) + :let [sub-next-elem (new Label)]] + (doto writer + (.visitInsn Opcodes/DUP) ;; tuple, tuple + (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; tuple, object + (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple + (.visitLabel sub-next-elem))) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel next-subcase))) + ))) + (.visitInsn Opcodes/POP) ;; -> + (.visitJumpInsn Opcodes/GOTO default-label))) + + [::test-variant ?branches ?cases] + (doto writer + ;; object + (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant + (.visitInsn Opcodes/DUP) ;; variant, variant + (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag + (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag + (.visitLdcInsn ?tag) ;; variant, tag, tag, text + (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B + (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag + (.visitInsn Opcodes/POP) ;; variant + (do (let [arity (-> ?subcases first (nth 2) count) + variant-class** (str variant-class* arity)] + (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN + (doseq [subcase ?subcases + :let [next-subcase (new Label)]] + (match subcase + [::subcase $body ?subseq] + (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq))) + :let [sub-next-elem (new Label)]] + (doto writer + (.visitInsn Opcodes/DUP) ;; variant, variant + (.visitFieldInsn Opcodes/GETFIELD variant-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; variant, object + (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; variant + (.visitLabel sub-next-elem))) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel next-subcase))) + )) + )) + (.visitInsn Opcodes/POP) ;; -> + (.visitJumpInsn Opcodes/GOTO default-label) + ;; variant, tag -> + (.visitLabel tag-else-label)) + (->> (doseq [[?tag ?subcases] ?cases + :let [tag-else-label (new Label)]]))) + ;; variant, tag -> + (.visitInsn Opcodes/POP) ;; variant -> + (.visitInsn Opcodes/POP) ;; -> + (.visitJumpInsn Opcodes/GOTO default-label))) + )) + +(defn ^:private map-branches [idx mappings patterns] + (reduce (fn [[idx mappings patterns*] [test body]] + [(inc idx) + (assoc mappings idx body) + (cons [test idx] patterns*)]) + [idx mappings (list)] + patterns)) + +(defn ^:private map-bodies [pm-struct] + (match pm-struct + [::BoolPM ?patterns ?defaults] + (let [[idx mappings patterns*] (map-branches 0 {} ?patterns) + [_ mappings* defaults*] (map-branches idx mappings ?defaults)] + [mappings* [::BoolPM patterns* defaults*]]) + + [::IntPM ?patterns ?defaults] + (let [[idx mappings patterns*] (map-branches 0 {} ?patterns) + [_ mappings* defaults*] (map-branches idx mappings ?defaults)] + [mappings* [::IntPM patterns* defaults*]]) + + [::RealPM ?patterns ?defaults] + (let [[idx mappings patterns*] (map-branches 0 {} ?patterns) + [_ mappings* defaults*] (map-branches idx mappings ?defaults)] + [mappings* [::RealPM patterns* defaults*]]) + + [::CharPM ?patterns ?defaults] + (let [[idx mappings patterns*] (map-branches 0 {} ?patterns) + [_ mappings* defaults*] (map-branches idx mappings ?defaults)] + [mappings* [::CharPM patterns* defaults*]]) + + [::TextPM ?patterns ?defaults] + (let [[idx mappings patterns*] (map-branches 0 {} ?patterns) + [_ mappings* defaults*] (map-branches idx mappings ?defaults)] + [mappings* [::TextPM patterns* defaults*]]) + + [::TuplePM ?num-elems ?patterns ?defaults] + (let [[idx mappings patterns*] (map-branches 0 {} ?patterns) + [_ mappings* defaults*] (map-branches idx mappings ?defaults)] + [mappings* [::TuplePM ?num-elems patterns* defaults*]]) + + [::VariantPM ?tags ?patterns ?defaults] + (let [[idx mappings patterns*] (map-branches 0 {} ?patterns) + [_ mappings* defaults*] (map-branches idx mappings ?defaults)] + [mappings* [::VariantPM ?tags patterns* defaults*]]) + + [::?PM ?defaults] + (let [[_ mappings defaults*] (map-branches 0 {} ?defaults)] + [mappings [::?PM defaults*]]))) + +(defn ^:private get-default [pm-struct] + (match pm-struct + [::BoolPM ?patterns ?defaults] + (first ?defaults) + + [::IntPM ?patterns ?defaults] + (first ?defaults) + + [::RealPM ?patterns ?defaults] + (first ?defaults) + + [::CharPM ?patterns ?defaults] + (first ?defaults) + + [::TextPM ?patterns ?defaults] + (first ?defaults) + + [::TuplePM ?num-elems ?patterns ?defaults] + (first ?defaults) + + [::VariantPM ?tags ?patterns ?defaults] + (first ?defaults) + + [::?PM ?defaults] + (first ?defaults) + )) + +(do-template [<name> <wrapper-class> <value-method> <method-sig>] + (defn <name> [writer mappings $default ?patterns] + (doseq [[?token $body] ?patterns + :let [$else (new Label)]] + (doto writer + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>) + (.visitLdcInsn ?token) + (.visitJumpInsn Opcodes/IF_ICMPNE $else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel $else))) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $default))) + + ^:private compile-bool-pm "java.lang.Boolean" "booleanValue" "()Z" + ^:private compile-char-pm "java.lang.Character" "charValue" "()C" + ) + +(do-template [<name> <wrapper-class> <value-method> <method-sig> <cmp-op>] + (defn <name> [writer mappings $default ?patterns] + (doseq [[?token $body] ?patterns + :let [$else (new Label)]] + (doto writer + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>) + (.visitLdcInsn ?token) + (.visitInsn <cmp-op>) + (.visitJumpInsn Opcodes/IFNE $else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel $else))) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $default))) + + ^:private compile-int-pm "java.lang.Long" "longValue" "()J" Opcodes/LCMP + ^:private compile-real-pm "java.lang.Double" "doubleValue" "()D" Opcodes/DCMPL + ) + +(defn ^:private compile-text-pm [writer mappings $default ?patterns] + (doseq [[?token $body] ?patterns + :let [$else (new Label)]] + (doto writer + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?token) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Object") "equals" (str "(" (->type-signature "java.lang.Object") ")Z")) + (.visitJumpInsn Opcodes/IFEQ $else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO (get mappings $body)) + (.visitLabel $else))) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $default))) + +(defn ^:private compile-tuple-pm [writer mapping $default ?num-elems ?patterns] + (let [sub-patterns (map (fn [idx] + (map (fn [tup body] + [(nth tup idx) body]) + ?patterns)) + (range ?num-elems)) + subpm-structs (map group-patterns sub-patterns) + [pat-h & pat-t] subpm-structs + (for [(get-branches pat-h) + (cull pat-t)] + ) + (reduce (fn [branches pattern] + ( (group-patterns pattern))) + (get-branches pat-h) + pat-t) + (sequence-tests sub-patterns)] + )) + +(defn ^:private compile-pm [writer mapping pm-struct] + (match pm-struct + [::BoolPM ?patterns ?defaults] + (compile-bool-pm writer mapping $default ?patterns) + + [::IntPM ?patterns ?defaults] + (compile-int-pm writer mapping $default ?patterns) + + [::RealPM ?patterns ?defaults] + (compile-real-pm writer mapping $default ?patterns) + + [::CharPM ?patterns ?defaults] + (compile-char-pm writer mapping $default ?patterns) + + [::TextPM ?patterns ?defaults] + (compile-text-pm writer mapping $default ?patterns) + + [::TuplePM ?num-elems ?patterns ?defaults] + (compile-tuple-pm writer mapping $default ?num-elems ?patterns) + + [::VariantPM ?tags ?patterns ?defaults] + (first ?defaults) + + [::?PM ?defaults] + (first ?defaults) + )) + +(do-template [<name> <pm-tag>] + (defn <name> [pm value body] + (match pm + [<pm-tag> ?branches ?defaults] + (return [<pm-tag> (cons [value body] ?branches) ?defaults]) + + [::?PM ?defaults] + (return [<pm-tag> (list [value body]) ?defaults]) + + _ + (fail "Can't match pattern!"))) + + ^:private group-bool-pm ::BoolPM + ^:private group-int-pm ::IntPM + ^:private group-real-pm ::RealPM + ^:private group-char-pm ::CharPM + ^:private group-text-pm ::textPM + ) + +(defn ^:private group-branch [pm [pattern body]] + (match pattern + [::&parser/Bool ?value] + (group-bool-pm pm ?value body) + + [::&parser/Int ?value] + (group-int-pm pm ?value body) + + [::&parser/Real ?value] + (group-real-pm pm ?value body) + + [::&parser/Char ?value] + (group-char-pm pm ?value body) + + [::&parser/Text ?value] + (group-text-pm pm ?value body) + + [::&parser/Tuple ?members] + (match pm + [::TuplePM ?num-elems ?branches ?defaults] + (exec [_ (assert! (= ?num-elems (count ?members)) + (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " (count ?members)))] + (return [::TuplePM ?num-elems (cons [?members body] ?branches) ?defaults])) + + [::?PM ?defaults] + (return [::TuplePM (count ?members) (list [?members body]) ?defaults]) + + _ + (fail "Can't match pattern!")) + + [::&parser/Tag ?tag] + (let [members (list) + num-members (count members)] + (match pm + [::VariantPM ?variants ?branches ?defaults] + (exec [variants* (if-let [?num-elems (get ?variants ?tag)] + (exec [_ (assert! (= ?num-elems num-members) + (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))] + (return ?variants)) + (return (assoc ?variants ?tag num-members)))] + (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults])) + + [::?PM ?defaults] + (return [::VariantPM {?tag num-members} (list [[?tag members] body]) ?defaults]) + + _ + (fail "Can't match pattern!"))) + + [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)] + (let [members ?members + num-members (count members)] + (match pm + [::VariantPM ?variants ?branches ?defaults] + (exec [variants* (if-let [?num-elems (get ?variants ?tag)] + (exec [_ (assert! (= ?num-elems num-members) + (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))] + (return ?variants)) + (return (assoc ?variants ?tag num-members)))] + (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults])) + + [::?PM ?defaults] + (return [::VariantPM {?tag num-members} (list [[?tag members] body]) ?defaults]) + + _ + (fail "Can't match pattern!"))) + + [::&parser/Ident ?name] + (match pm + [::BoolPM ?patterns ?defaults] + (return [::BoolPM ?patterns (conj ?defaults [?name body])]) + + [::IntPM ?patterns ?defaults] + (return [::IntPM ?patterns (conj ?defaults [?name body])]) + + [::RealPM ?patterns ?defaults] + (return [::RealPM ?patterns (conj ?defaults [?name body])]) + + [::CharPM ?patterns ?defaults] + (return [::CharPM ?patterns (conj ?defaults [?name body])]) + + [::TextPM ?patterns ?defaults] + (return [::TextPM ?patterns (conj ?defaults [?name body])]) + + [::TuplePM ?num-elems ?patterns ?defaults] + (return [::TuplePM ?num-elems ?patterns (conj ?defaults [?name body])]) + + [::VariantPM ?tags ?patterns ?defaults] + (return [::VariantPM ?tags ?patterns (conj ?defaults [?name body])]) + + [::?PM ?defaults] + (return [::?PM (conj ?defaults [?name body])])) + )) + +(defn ^:private valid-paths [group] + (set (match group + [::BoolPM ?patterns ?defaults] + (concat (map second ?patterns) (map second ?defaults)) + + [::IntPM ?patterns ?defaults] + (concat (map second ?patterns) (map second ?defaults)) + + [::RealPM ?patterns ?defaults] + (concat (map second ?patterns) (map second ?defaults)) + + [::CharPM ?patterns ?defaults] + (concat (map second ?patterns) (map second ?defaults)) + + [::TextPM ?patterns ?defaults] + (concat (map second ?patterns) (map second ?defaults)) + + [::TuplePM ?num-elems ?patterns ?defaults] + (concat (map second ?patterns) (map second ?defaults)) + + [::VariantPM ?tags ?patterns ?defaults] + (concat (map second ?patterns) (map second ?defaults)) + + [::?PM ?defaults] + (map second ?defaults)))) + +(defn ^:private sequence-multi-pm [sequence-pm prev-paths groups] + (match groups + ([head & tail] :seq) + (for [:let [curr-paths (set/intersection prev-paths (valid-paths head))] + [head-paths head-test] (sequence-pm curr-paths head)] + [:multi-test head-test head-paths (sequence-multi-pm sequence-pm head-paths tail)]) + + _ + (list (list)))) + +(do-template [<name> <pm> <test>] + (defn <name> [prev-paths group] + (match group + [<pm> ?patterns ?defaults] + (return (concat (for [[value $body] ?patterns + :when (contains? prev-paths $body)] + [<test> value #{$body}]) + (match ?defaults + ([[default-register $body] & _] :seq) + (list [<test> default-register #{$body}]) + + :else + (list)))) + + :else + (fail ""))) + + ^:private sequence-bool ::BoolPM ::test-bool + ^:private sequence-int ::IntPM ::test-int + ^:private sequence-real ::RealPM ::test-real + ^:private sequence-char ::CharPM ::test-char + ^:private sequence-text ::TextPM ::test-text + ) + +(defn ^:private sequence-? [group] + [::?PM ([[default-register $body] & _] :seq)] + (return (list [<test> default-register #{$body}])) + + :else + (fail "")) + +(defn ^:private sequence-pm [group] + (match group + [::BoolPM _ _] + (sequence-bool group) + + [::IntPM _ _] + (sequence-int group) + + [::RealPM _ _] + (sequence-real group) + + [::CharPM _ _] + (sequence-char group) + + [::TextPM _ _] + (sequence-text group) + + [::?PM _] + (sequence-? group) + + [::TuplePM ?num-elems ?patterns ?defaults] + (exec [:let [sub-patterns (map (fn [idx] + (map (fn [[tup body]] + [(nth tup idx) body]) + ?patterns)) + (range ?num-elems))] + groups (map-m #(reduce-m group-branch [::?PM (list)] %) sub-patterns) + tuple-paths (valid-paths group) + sub-seqs (sequence-multi-pm sequence-pm tuple-paths groups)] + (return (cons [::test-tuple ?num-elems sub-seqs] + (match ?defaults + ([[default-register $body] & _] :seq) + (list [<test> default-register #{$body}]) + + :else + (list))))) + + [::VariantPM ?tags ?patterns ?defaults] + (map-m (fn [tag] + (exec [:let [members+bodies (mapcat (fn [[ptag pmembers pbody]] + (if (= ptag tag) + (list [pmembers pbody]) + (list))) + ?patterns) + sub-patterns (map (fn [idx] + (map (fn [[tup body]] + [(nth tup idx) body]) + members+bodies)) + (range ?num-elems))] + groups (map-m #(reduce-m group-branch [::?PM (list)] %) sub-patterns) + tag-paths (set (map second members+bodies)) + sub-seqs (sequence-multi-pm sequence-pm tag-paths groups)] + (cons [::test-variant tag ?num-elems sub-seqs] + (match ?defaults + ([[default-register $body] & _] :seq) + (list [<test> default-register #{$body}]) + + :else + (list))))) + (keys ?tags)) + )) + +(defn ^:private decision-tree [branches] + (exec [group (reduce-m group-branch [::?PM (list)] branches) + :let [[mappings group*] (map-bodies group) + paths (valid-paths group*)]] + (sequence-pm paths group*))) + +(let [ex-class (->class "java.lang.IllegalStateException")] + (defn ^:private compile-case [compile *type* ?variant ?base-register ?num-registers ?branches] + (exec [*writer* &util/get-writer + :let [$start (new Label) + $end (new Label) + _ (dotimes [offset ?num-registers] + (let [idx (+ ?base-register offset)] + (.visitLocalVariable *writer* (str +local-prefix+ idx) (->java-sig [::&type/Any]) nil $start $end idx)))] + _ (compile ?variant) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLabel $start))] + :let [[mapping tree] (decision-tree ?branches)] + + :let [[mappings pm-struct*] (map-bodies pm-struct) + entries (for [[?branch ?body] mappings + :let [label (new Label)]] + [[?branch label] + [label ?body]]) + mappings* (into {} (map first entries)) + ] + :let [$default (new Label) + _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts ?pm-struct))] + (if (get-default pm-struct) + (butlast pieces) + pieces))] + (compile-decision-tree *writer* mappings* $default decision-tree)) + (.visitLabel *writer* $default) + (if-let [[?idx ?body] (get-default pm-struct)] + (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ASTORE ?idx) + (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) + (doto *writer* + (.visitInsn Opcodes/POP) + (.visitTypeInsn Opcodes/NEW ex-class) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V") + (.visitInsn Opcodes/ATHROW))))] + _ (map-m (fn [[?label ?body]] + (exec [:let [_ (do (.visitLabel *writer* ?label) + (.visitInsn *writer* Opcodes/POP))] + ret (compile ?body) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return ret))) + (map second entries)) + :let [_ (.visitLabel *writer* $end)]] + (return nil)))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj new file mode 100644 index 000000000..dfe67eece --- /dev/null +++ b/src/lux/compiler/host.clj @@ -0,0 +1,194 @@ + +(let [class+metthod+sig {"boolean" [(->class "java.lang.Boolean") "booleanValue" "()Z"] + "byte" [(->class "java.lang.Byte") "byteValue" "()B"] + "short" [(->class "java.lang.Short") "shortValue" "()S"] + "int" [(->class "java.lang.Integer") "intValue" "()I"] + "long" [(->class "java.lang.Long") "longValue" "()J"] + "float" [(->class "java.lang.Float") "floatValue" "()F"] + "double" [(->class "java.lang.Double") "doubleValue" "()D"] + "char" [(->class "java.lang.Character") "charValue" "()C"]}] + (defn ^:private prepare-arg! [*writer* class-name] + (if-let [[class method sig] (get class+metthod+sig class-name)] + (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig)) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name))))) + +;; (let [boolean-class "java.lang.Boolean" +;; integer-class "java.lang.Integer" +;; char-class "java.lang.Character"] +;; (defn prepare-return! [*writer* *type*] +;; (match *type* +;; ::&type/nothing +;; (.visitInsn *writer* Opcodes/ACONST_NULL) + +;; [::&type/primitive "char"] +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class))) + +;; [::&type/primitive "int"] +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class))) + +;; [::&type/primitive "boolean"] +;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class))) + +;; [::&type/Data ?oclass] +;; nil))) + + +(defn ^:private compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] + (exec [*writer* &util/get-writer + :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))] + _ (map-m (fn [[class-name arg]] + (exec [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (map vector ?classes ?args)) + :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class ?class) ?method method-sig) + ;; (prepare-return! *writer* *type*) + )]] + (return nil))) + +(defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args] + (exec [*writer* &util/get-writer + :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))] + _ (compile ?object) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))] + _ (map-m (fn [[class-name arg]] + (exec [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (map vector ?classes ?args)) + :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig) + ;; (prepare-return! *writer* *type*) + )]] + (return nil))) + +(defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args] + (exec [*writer* &util/get-writer + :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V") + class* (->class ?class) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW class*) + (.visitInsn Opcodes/DUP))] + _ (map-m (fn [[class-name arg]] + (exec [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (map vector ?classes ?args)) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]] + (return nil))) + +(defn ^:private compile-jvm-new-array [compile *type* ?class ?length] + (exec [*writer* &util/get-writer + :let [_ (doto *writer* + (.visitLdcInsn (int ?length)) + (.visitTypeInsn Opcodes/ANEWARRAY (->class ?class)))]] + (return nil))) + +(defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem] + (exec [*writer* &util/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int ?idx)))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(defn ^:private compile-jvm-aaload [compile *type* ?array ?idx] + (exec [*writer* &util/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitLdcInsn (int ?idx)) + (.visitInsn Opcodes/AALOAD))]] + (return nil))) + +(defn ^:private compile-jvm-getstatic [compile *type* ?class ?field] + (exec [*writer* &util/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?class) ?field (->java-sig *type*))]] + (return nil))) + +(defn ^:private compile-jvm-getfield [compile *type* ?class ?field ?object] + (exec [*writer* &util/get-writer + _ (compile ?object) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))] + :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (->class ?class) ?field (->java-sig *type*))]] + (return nil))) + +(defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods] + (let [parent-dir (->package ?package) + full-name (str parent-dir "/" ?name) + super-class* (->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil super-class* nil)) + _ (do (doseq [[field props] ?fields] + (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil) + (.visitEnd))) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class* "<init>" "()V") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (.visitEnd =class) + (.mkdirs (java.io.File. (str "output/" parent-dir))))] + (save-class! full-name (.toByteArray =class)))) + +(defn ^:private compile-jvm-interface [compile *type* ?package ?name ?fields ?methods] + (let [parent-dir (->package ?package) + full-name (str parent-dir "/" ?name) + =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) + full-name nil "java/lang/Object" nil)) + _ (do (doseq [[?method ?props] ?methods + :let [[?args ?return] (:type ?props) + signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]] + (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil)) + (.visitEnd =interface) + (.mkdirs (java.io.File. (str "output/" parent-dir))))] + (save-class! full-name (.toByteArray =interface)))) + +(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>] + (defn <name> [compile *type* ?x ?y] + (exec [:let [+wrapper-class+ (->class <wrapper-class>)] + *writer* &util/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + _ (doto *writer* + (.visitInsn <opcode>) + (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (->type-signature <wrapper-class>))))]] + (return nil))) + + ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + + ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)" + + ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + + ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + ) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj new file mode 100644 index 000000000..b3bfc4860 --- /dev/null +++ b/src/lux/compiler/lambda.clj @@ -0,0 +1,176 @@ +(ns lux.compiler.lambda) + +;; [Utils] +(def ^:private clo-field-sig (->type-signature "java.lang.Object")) +(def ^:private lambda-return-sig (->type-signature "java.lang.Object")) +(def ^:private <init>-return "V") +(def ^:private counter-sig "I") +(def ^:private +datum-sig+ (->type-signature "java.lang.Object")) + +(defn ^:private lambda-impl-signature [args] + (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig)) + +(defn ^:private lambda-<init>-signature [closed-over args] + (let [num-args (count args)] + (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig)) + (if (> num-args 1) + (reduce str counter-sig (repeat (dec num-args) clo-field-sig))) + ")" + <init>-return))) + +(defn ^:private add-lambda-<init> [class class-name closed-over args init-signature] + (let [num-args (count args) + num-mappings (count closed-over)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD ?captured-id) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str +closure-prefix+ ?captured-id)]) + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] closed-over]))) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ICONST_0) + (.visitFieldInsn Opcodes/PUTFIELD class-name "_counter" counter-sig) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset)) + (.visitFieldInsn Opcodes/PUTFIELD class-name field-name clo-field-sig)) + (->> (let [field-name (str +partial-prefix+ clo_idx)] + (doto (.visitField class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil) + (.visitEnd))) + (dotimes [clo_idx (dec num-args)]) + (let [offset (+ 2 num-mappings)])))) + (->> (when (> num-args 1)))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(do-template [<name> <prefix>] + (defn <name> [writer class-name vars] + (dotimes [idx (count vars)] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name (str <prefix> idx) clo-field-sig)))) + + ^:private add-closure-vars +closure-prefix+ + ^:private add-partial-vars +partial-prefix+ + ) + +(defn ^:private add-nulls [writer amount] + (dotimes [_ amount] + (.visitInsn writer Opcodes/ACONST_NULL))) + +(defn ^:private add-lambda-apply [class class-name closed-over args impl-signature init-signature] + (let [num-args (count args) + num-captured (dec num-args) + default-label (new Label) + branch-labels (for [_ (range num-captured)] + (new Label))] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil) + (.visitCode) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig) + (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels)) + (-> (doto (.visitLabel branch-label) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (add-closure-vars class-name closed-over) + (.visitLdcInsn (int current-captured)) + (add-partial-vars class-name (take current-captured args)) + (.visitVarInsn Opcodes/ALOAD 1) + (add-nulls (- (dec num-captured) current-captured)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" init-signature) + (.visitInsn Opcodes/ARETURN)) + (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))]))) + (.visitLabel default-label)) + (->> (when (> num-args 1)))) + (.visitVarInsn Opcodes/ALOAD 0) + (add-partial-vars class-name (butlast args)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(defn ^:private add-lambda-impl [class compile impl-signature impl-body] + (&util/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) + (.visitCode)) + (exec [;; :let [_ (prn 'add-lambda-impl/_0)] + *writer* &util/get-writer + ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)] + ret (compile impl-body) + ;; :let [_ (prn 'add-lambda-impl/_2 ret)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + ;; :let [_ (prn 'add-lambda-impl/_3)] + ] + (return ret)))) + +(defn ^:private instance-closure [compile lambda-class closed-over args init-signature] + (exec [*writer* &util/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW lambda-class) + (.visitInsn Opcodes/DUP))] + _ (->> closed-over + (sort #(< (-> %1 second :form (nth 2)) + (-> %2 second :form (nth 2)))) + (map-m (fn [[?name ?captured]] + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source] + (compile ?source))))) + :let [num-args (count args) + _ (do (when (> num-args 1) + (.visitInsn *writer* Opcodes/ICONST_0) + (add-nulls *writer* (dec num-args))) + (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature))]] + (return nil))) + +(defn ^:private add-lambda-<clinit> [class class-name args <init>-sig] + (let [num-args (count args)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (doto (.visitInsn *writer* Opcodes/ICONST_0) + (add-nulls (dec num-args))) + (->> (when (> num-args 1)))) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" <init>-sig) + (.visitFieldInsn Opcodes/PUTSTATIC class-name "_datum" +datum-sig+) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +;; [Resources] +(defn compile-lambda [compile *type* ?scope ?closure ?args ?body with-datum? instance?] + (exec [:let [lambda-class (&host/location ?scope) + impl-signature (lambda-impl-signature ?args) + <init>-sig (lambda-<init>-signature ?closure ?args) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + lambda-class nil "java/lang/Object" (into-array [(->class +function-class+)])) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str +closure-prefix+ ?captured-id)]) + (match (:form ?captured) + [::&analyser/captured ?closure-id ?captured-id ?source]) + (doseq [[?name ?captured] ?closure]))) + (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil) + (.visitEnd)) + (->> (when (> (count ?args) 1)))) + (-> (doto (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil) + (add-lambda-<clinit> lambda-class ?args <init>-sig)) + (when with-datum?)) + (add-lambda-apply lambda-class ?closure ?args impl-signature <init>-sig) + (add-lambda-<init> lambda-class ?closure ?args <init>-sig) + )] + _ (add-lambda-impl =class compile impl-signature ?body) + :let [_ (.visitEnd =class)] + _ (save-class! lambda-class (.toByteArray =class))] + (if instance? + (instance-closure compile lambda-class ?closure ?args <init>-sig) + (return nil)))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 1dbe0e989..8f9337157 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -96,3 +96,6 @@ lookup-static-method true lookup-virtual-method false ) + +(defn location [scope] + (->> scope reverse (map normalize-ident) (interpose "$") (reduce str ""))) diff --git a/src/lux/macros.clj b/src/lux/macro.clj index 4d255a13c..52001b24f 100644 --- a/src/lux/macros.clj +++ b/src/lux/macro.clj @@ -1,8 +1,8 @@ -(ns lux.macros +(ns lux.macro (:require [lux.parser :as &parser])) ;; [Utils] -(defn ^:private ->lux+* [->lux loader xs] +(defn ^:private ->lux+ [->lux loader xs] (reduce (fn [tail x] (doto (.newInstance (.loadClass loader "lux.Variant2")) (-> .-tag (set! "Cons")) @@ -20,7 +20,7 @@ (defn ^:private ->lux-one [->lux loader tag values] (doto (.newInstance (.loadClass loader "lux.Variant1")) (-> .-tag (set! tag)) - (-> .-_1 (set! (->lux+* ->lux loader values))))) + (-> .-_1 (set! (->lux+ ->lux loader values))))) (defn ^:private ->lux [loader x] (match x @@ -44,11 +44,11 @@ (->lux-many ->lux loader "Form" ?elems) )) -(defn ^:private ->clojure+* [->clojure xs] +(defn ^:private ->clojure+ [->clojure xs] (case (.-tag xs) "Nil" (list) "Cons" (cons (->clojure (.-_1 xs)) - (->clojure+* ->clojure (.-_2 xs))) + (->clojure+ ->clojure (.-_2 xs))) )) (defn ^:private ->clojure [x] @@ -60,10 +60,16 @@ "Text" [::&parser/Text (.-_1 x)] "Tag" [::&parser/Tag (.-_1 x)] "Ident" [::&parser/Ident (.-_1 x)] - "Tuple" [::&parser/Tuple (->clojure+* ->clojure (.-_1 x))] - "Form" [::&parser/Form (->clojure+* ->clojure (.-_1 x))])) + "Tuple" [::&parser/Tuple (->clojure+ ->clojure (.-_1 x))] + "Form" [::&parser/Form (->clojure+ ->clojure (.-_1 x))])) ;; [Resources] -(def ->lux+ (partial ->lux+* ->lux)) - -(def ->clojure+ (partial ->clojure+* ->clojure)) +(defn expand [loader macro-class] + (let [expansion (-> (.loadClass loader macro-class) + .getDeclaredConstructors + first + (.newInstance (to-array [(int 0) nil])) + (.apply (->lux+* ->lux loader ?args)) + (.apply nil))] + [(->> expansion .-_1 (->clojure+* ->clojure)) + (.-_2 output)])) diff --git a/src/lux/type.clj b/src/lux/type.clj index 9d9cf77aa..0c1b34070 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -1,5 +1,5 @@ (ns lux.type - (:refer-clojure :exclude [resolve apply]) + (:refer-clojure :exclude [deref apply merge]) (:require [clojure.core.match :refer [match]] [lux.util :as &util :refer [exec return* return fail fail* repeat-m try-m try-all-m map-m @@ -9,7 +9,7 @@ ;; [Util] (def ^:private success (return nil)) -(defn ^:private resolve [id] +(defn ^:private deref [id] (fn [state] (if-let [top+bottom (get-in state [::&util/types ::mappings id])] [::&util/ok [state top+bottom]] @@ -45,7 +45,7 @@ ;; success ;; [_ [::var ?id]] -;; (exec [[=top =bottom] (resolve ?id)] +;; (exec [[=top =bottom] (deref ?id)] ;; (try-all-m [(exec [_ (solve expected =top)] ;; success) ;; (exec [_ (solve =top expected) @@ -54,7 +54,7 @@ ;; success)])) ;; [[::var ?id] _] -;; (exec [[=top =bottom] (resolve ?id)] +;; (exec [[=top =bottom] (deref ?id)] ;; (try-all-m [(exec [_ (solve =bottom actual)] ;; success) ;; (exec [_ (solve actual =bottom) @@ -99,7 +99,7 @@ (defn clean [type] (match type [::var ?id] - (exec [[=top =bottom] (resolve ?id)] + (exec [[=top =bottom] (deref ?id)] (clean =top)) [::function ?args ?return] @@ -110,8 +110,9 @@ ;; ::any ;; (return [::object "java.lang.Object" []]) - _ - (return type))) + ;; _ + ;; (return type) + )) ;; Java Reflection (def success (return nil)) @@ -160,6 +161,40 @@ (solve n!output g!output)) )) +(let [&& #(and %1 %2)] + (defn merge [x y] + (match [x y] + [_ [::Nothing]] + (return x) + + [[::Nothing] _] + (return y) + + [[::Variant x!cases] [::Variant y!cases]] + (and (reduce && true + (for [[xslot xtype] (keys x!cases)] + (if-let [ytype (get y!cases xslot)] + (= xtype ytype) + true))) + (reduce && true + (for [[yslot ytype] (keys y!cases)] + (if-let [xtype (get x!cases yslot)] + (= xtype ytype) + true)))) + (return [::Variant (clojure.core/merge x!cases y!cases)]) + (fail (str "Incompatible variants: " (pr-str x) " and " (pr-str y))) + + [[::Record x!fields] [::Record y!fields]] + (if (and (= (keys x!fields) (keys y!fields)) + (->> (keys x!fields) + (map #(= (get x!fields %) (get y!fields %))) + (reduce && true))) + (return x) + (fail (str "Incompatible records: " (pr-str x) " and " (pr-str y)))) + + :else + (fail (str "Can't merge types: " (pr-str x) " and " (pr-str y)))))) + (comment ;; Types [::Any] |