From 5ee1163e99d97bca272aad32c34d662b2c27ec37 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 10 Feb 2015 14:58:58 -0400 Subject: Super refactoring that breaks the system: Part 2 --- src/lux/analyser.clj | 403 +++++++++++++++++++++++++-------------- src/lux/compiler.clj | 529 ++++++++++++++++++++++++++++++--------------------- src/lux/type.clj | 6 +- src/lux/util.clj | 36 ++-- 4 files changed, 599 insertions(+), 375 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index cde2dd9bf..f2e589646 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -3,7 +3,6 @@ [clojure.core.match :refer [match]] (lux [util :as &util :refer [exec return* return fail fail* repeat-m try-all-m map-m mapcat-m reduce-m - within normalize-ident]] [parser :as &parser] [type :as &type] @@ -13,53 +12,49 @@ ;; [Util] (def ^:private +dont-care-type+ [::&type/Any]) -(defn ^:private fresh-env [name] - {:name name - :inner-closures 0 - :locals &util/+init-env+ - :closure &util/+init-env+}) - -(defn ^:private annotate [name access macro? type] +(defn ^:private annotate [module name access type] (fn [state] - (let [full-name (str (::&util/current-module state) &util/+name-separator+ name) - bound [::Expression [::global (::&util/current-module state) name] type]] + (let [full-name (str module &util/+name-separator+ name) + bound [::Expression [::global module name] type]] [::&util/ok [(-> state - (assoc-in [::&util/modules (::&util/current-module state) name] {:args-n [:None] - :access access - :macro? macro? - :type type - :defined? false}) + (assoc-in [::&util/modules module name] {:args-n [:None] + :access access + :type type + :defined? false}) (update-in [::&util/global-env] merge {full-name bound, name bound})) nil]]))) +(defn ^:private declare-macro [module name] + (fn [state] + [::&util/ok [(assoc-in state [::&util/modules module :macros name] true) + nil]])) + (defn ^:private expr-type [syntax+] (match syntax+ [::Expression _ type] (return type) _ - (fail "Can't retrieve the type of a statement."))) + (fail "Can't retrieve the type of a non-expression."))) -(defn ^:private define [name] - (fn [state] - (if-let [{:keys [type]} (get-in state [::&util/modules (::&util/current-module state) name])] - [::&util/ok [(-> state - (assoc-in [::&util/modules (::&util/current-module state) name :defined?] true) - (update-in [::&util/global-env] merge {full-name bound, name bound})) - nil]] - (fail* (str "[Analyser Error] Can't define an unannotated element: " name))))) +(defn ^:private define [module name] + (exec [? annotated? + _ (assert! ? (str "[Analyser Error] Can't define an unannotated element: " name))] + (fn [state] + [::&util/ok [(assoc-in state [::&util/modules module name :defined?] true) + nil]]))) -(defn ^:private defined? [name] +(defn ^:private defined? [module name] (fn [state] - [::&util/ok [state (get-in state [::&util/modules (::&util/current-module state) name :defined?])]])) + [::&util/ok [state (get-in state [::&util/modules module name :defined?])]])) -(defn ^:private annotated? [name] +(defn ^:private annotated? [module name] (fn [state] - [::&util/ok [state (boolean (get-in state [::&util/modules (::&util/current-module state) name]))]])) + [::&util/ok [state (boolean (get-in state [::&util/modules module name]))]])) -(defn ^:private is-macro? [module name] +(defn ^:private macro? [module name] (fn [state] - [::&util/ok [state (boolean (get-in state [::&util/modules module name :macro?]))]])) + [::&util/ok [state (boolean (get-in state [::&util/modules module :macros name]))]])) (def ^:private next-local-idx (fn [state] @@ -114,12 +109,16 @@ (fn [state] [::&util/ok [state (-> state ::&util/local-envs first :closure :mappings)]])) -(defn ^:private analyse-n [elems] - (let [num-inputs (count elems)] - (exec [output (mapcat-m analyse-ast elems) - _ (&util/assert! (= num-inputs (count output)) - (str "[Analyser Error] Can't expand to other than " num-inputs " elements."))] - (return output)))) +(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)))) + +(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)]))) (defn ^:private with-lambda [self self-type arg arg-type body] (fn [state] @@ -128,7 +127,6 @@ (with-let self :self self-type (with-let arg :local arg-type (exec [=return body - =next next-local-idx =captured captured-vars] (return [$scope =next =captured =return]))))))] (body* (update-in state [::&util/local-envs] #(cons (update-in (first %) [:inner-closures] inc) @@ -184,13 +182,13 @@ )) (defn ^:private analyse-call [analyse-ast ?fn ?args] - (exec [[=fn] (analyse-n (list ?fn)) + (exec [=fn (analyse-1 ?fn) loader &util/loader] (match =fn [::Expression =fn-form =fn-type] (match =fn-form [::global ?module ?name] - (exec [macro? (is-macro? ?module ?name)] + (exec [macro? (macro? ?module ?name)] (if macro? (let [macro-class (str ?module "$" (normalize-ident ?name)) output (-> (.loadClass loader macro-class) @@ -344,7 +342,7 @@ (let [branches* (reduce fold-branch base-struct data)] (match branches* [::BoolTests _] branches* - [::IntTests _] branches* + [::IntTests _] branches* [::RealTests _] branches* [::CharTests _] branches* [::TextTests _] branches* @@ -438,84 +436,85 @@ 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+]) + + [::&parser/Tuple ?submembers] + (mapcat locals-getter ?submembers) + + [::&parser/Form ([[::&parser/Tag ?subtag] & ?submembers] :seq)] + (mapcat locals-getter ?submembers) + + _ + (list) + )) + (defn ^:private analyse-case-branches [branches] (map-m (fn [[?pattern ?body]] (match ?pattern [::&parser/Bool ?token] - (exec [[=body] (analyse-n (list ?body))] + (exec [=body (analyse-1 ?body)] (return [::case-branch ?pattern =body])) [::&parser/Int ?token] - (exec [[=body] (analyse-n (list ?body))] + (exec [=body (analyse-1 ?body)] (return [::case-branch ?pattern =body])) [::&parser/Real ?token] - (exec [[=body] (analyse-n (list ?body))] + (exec [=body (analyse-1 ?body)] (return [::case-branch ?pattern =body])) [::&parser/Char ?token] - (exec [[=body] (analyse-n (list ?body))] + (exec [=body (analyse-1 ?body)] (return [::case-branch ?pattern =body])) [::&parser/Text ?token] - (exec [[=body] (analyse-n (list ?body))] + (exec [=body (analyse-1 ?body)] (return [::case-branch ?pattern =body])) [::&parser/Ident ?name] - (exec [[=body] (with-let ?name :local +dont-care-type+ - (analyse-n (list ?body)))] + (exec [=body (with-let ?name :local +dont-care-type+ + (analyse-1 ?body))] (return [::case-branch ?pattern =body])) [::&parser/Tag ?tag] - (exec [[=body] (analyse-n (list ?body))] + (exec [=body (analyse-1 ?body)] (return [::case-branch ?pattern =body])) - + [::&parser/Tuple ?members] - (exec [[=body] (with-lets (mapcat locals-getter ?members) - (analyse-n (list ?body)))] + (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-n (list ?body)))] + (exec [=body (with-lets (mapcat locals-getter ?members) + (analyse-1 ?body))] (return [::case-branch ?pattern =body])) )) branches)) -(let [locals-getter (fn locals-getter [?member] - (match ?member - [::&parser/Ident ?name] - (list [?name +dont-care-type+]) - - [::&parser/Tuple ?submembers] - (mapcat locals-getter ?submembers) - - [::&parser/Form ([[::&parser/Tag ?subtag] & ?submembers] :seq)] - (mapcat locals-getter ?submembers) - - _ - (list) - ))] - (defn ^:private analyse-case [analyse-ast ?variant ?branches] - (exec [[=variant] (analyse-n (list ?variant)) - _ (assert! (and (> (count ?branches) 0) (even? (count ?branches))) - "Imbalanced branches in \"case'\" expression.") - $base next-local-idx - [registers mappings tree] (exec [=branches (analyse-case-branches (partition 2 ?branches))] - (return (->decision-tree $base =branches)))] - (return (list [::Expression [::case $base =variant registers mappings tree] +dont-care-type+]))))) +(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 analyse-let [analyse-ast ?label ?value ?body] - (exec [[=value] (analyse-n (list ?value)) + (exec [=value (analyse-1 ?value) =value-type (expr-type =value) idx next-local-idx - [=body] (with-let ?label :local =value-type - (analyse-n (list ?body))) + =body (with-let ?label :local =value-type + (analyse-1 ?body)) =body-type (expr-type =body)] (return (list [::Expression [::let idx =value =body] =body-type])))) -(defn ^:private raise-tree-bindings [raise-expr ?tree] - (let [tree-partial-f (partial raise-tree-bindings raise-expr)] +(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 @@ -525,23 +524,24 @@ (update-in [:default] (fn [[tag local $branch :as total]] (if total - (match (raise-expr [::Expression local [::&type/Nothing]]) + (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 [::Expression ?store [::&type/Nothing]]) + (match (raise-expr arg [::Expression ?store [::&type/Nothing]]) [::Expression =store [::&type/Nothing]] [=store ?branches])))) ;; else (assert false (pr-str ?tree)) ))) -(defn ^:private raise-expr [syntax] +(defn ^:private raise-expr [arg syntax] ;; (prn 'raise-bindings body) - (let [tree-partial-f (partial raise-tree-bindings raise-expr)] + (let [partial-f (partial raise-expr arg) + tree-partial-f (partial raise-tree-bindings raise-expr arg)] (match syntax [::Expression ?form ?type] (match ?form @@ -561,10 +561,10 @@ syntax [::tuple ?members] - [::Expression [::tuple (map raise-expr ?members)] ?type] + [::Expression [::tuple (map partial-f ?members)] ?type] [::variant ?tag ?members] - [::Expression [::variant ?tag (map raise-expr ?members)] ?type] + [::Expression [::variant ?tag (map partial-f ?members)] ?type] [::local ?idx] [::Expression [::local (inc ?idx)] ?type] @@ -573,76 +573,125 @@ ?source [::self ?curried] - [::Expression [::self (map raise-expr ?curried)] ?type] + [::Expression [::self (cons arg (map partial-f ?curried))] ?type] [::global _ _] syntax - [::jvm-iadd ?x ?y] - [::Expression [::jvm-iadd (raise-expr ?x) (raise-expr ?y)] ?type] - - [::jvm-isub ?x ?y] - [::Expression [::jvm-isub (raise-expr ?x) (raise-expr ?y)] ?type] - - [::jvm-imul ?x ?y] - [::Expression [::jvm-imul (raise-expr ?x) (raise-expr ?y)] ?type] - - [::jvm-idiv ?x ?y] - [::Expression [::jvm-idiv (raise-expr ?x) (raise-expr ?y)] ?type] - - [::jvm-irem ?x ?y] - [::Expression [::jvm-irem (raise-expr ?x) (raise-expr ?y)] ?type] - [::let ?idx ?value ?body] - [::Expression [::let (inc ?idx) (raise-expr ?value) - (raise-expr ?body)] + [::Expression [::let (inc ?idx) (partial-f ?value) + (partial-f ?body)] ?type] [::case ?base ?variant ?registers ?mappings ?tree] - (let [=variant (raise-expr ?variant) + (let [=variant (partial-f ?variant) =mappings (into {} (for [[idx syntax] ?mappings] - [idx (raise-expr syntax)])) + [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 (raise-expr ?sub-syntax)])) + [?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 - (raise-expr ?obj) - (map raise-expr ?args)] + (partial-f ?obj) + (map partial-f ?args)] ?type] - [::do ?asts] - [::Expression [::do (map raise-expr ?asts)] ?type] + ;; Integer arithmetic + [::jvm-iadd ?x ?y] + [::Expression [::jvm-iadd (partial-f ?x) (partial-f ?y)] ?type] - [::call ?func ?args] - [::Expression [::call (raise-expr ?func) (map raise-expr ?args)] ?type] + [::jvm-isub ?x ?y] + [::Expression [::jvm-isub (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-imul ?x ?y] + [::Expression [::jvm-imul (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-idiv ?x ?y] + [::Expression [::jvm-idiv (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-irem ?x ?y] + [::Expression [::jvm-irem (partial-f ?x) (partial-f ?y)] ?type] + + ;; Long arithmetic + [::jvm-ladd ?x ?y] + [::Expression [::jvm-ladd (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-lsub ?x ?y] + [::Expression [::jvm-lsub (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-lmul ?x ?y] + [::Expression [::jvm-lmul (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-ldiv ?x ?y] + [::Expression [::jvm-ldiv (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-lrem ?x ?y] + [::Expression [::jvm-lrem (partial-f ?x) (partial-f ?y)] ?type] + + ;; Float arithmetic + [::jvm-fadd ?x ?y] + [::Expression [::jvm-fadd (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-fsub ?x ?y] + [::Expression [::jvm-fsub (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-fmul ?x ?y] + [::Expression [::jvm-fmul (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-fdiv ?x ?y] + [::Expression [::jvm-fdiv (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-frem ?x ?y] + [::Expression [::jvm-frem (partial-f ?x) (partial-f ?y)] ?type] + + ;; Double arithmetic + [::jvm-dadd ?x ?y] + [::Expression [::jvm-dadd (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-dsub ?x ?y] + [::Expression [::jvm-dsub (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-dmul ?x ?y] + [::Expression [::jvm-dmul (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-ddiv ?x ?y] + [::Expression [::jvm-ddiv (partial-f ?x) (partial-f ?y)] ?type] + + [::jvm-drem ?x ?y] + [::Expression [::jvm-drem (partial-f ?x) (partial-f ?y)] ?type] _ (assert false syntax) )))) (defn ^:private analyse-lambda [analyse-ast ?self ?arg ?body] - (exec [[_ =arg =return :as =function] (within ::&util/types &type/fresh-function) - [=scope =next-local =captured [=body]] (with-lambda ?self =function - ?arg =arg - (analyse-n (list ?body))) + (exec [[_ =arg =return :as =function] &type/fresh-function + [=scope =captured =body] (with-lambda ?self =function + ?arg =arg + (analyse-1 ?body)) =body-type (expr-type =body) - =function (within ::&util/types (exec [_ (&type/solve =return =body-type)] - (&type/clean =function))) + =function (exec [_ (&type/solve =return =body-type)] + (&type/clean =function)) :let [=lambda (match =body [::Expression [::lambda ?sub-scope ?sub-captured ?sub-args ?sub-body] =body-type] - [::Expression [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr ?sub-body)] =body-type] + [::Expression [::lambda =scope =captured (cons ?arg ?sub-args) (raise-expr ?arg ?sub-body)] =body-type] _ [::Expression [::lambda =scope =captured (list ?arg) =body] =body-type])]] @@ -652,10 +701,10 @@ ;; (prn 'analyse-def ?name ?value) (exec [def?? (defined? ?name)] (if def?? - (fail (str "Can't redefine function/constant: " ?name)) + (fail (str "Can't redefine " ?name)) (exec [ann?? (annotated? ?name) $module &util/get-module-name - [=value] (analyse-n (list ?value)) + =value (analyse-1 ?value) =value (match =value [::Expression =value-form =value-type] (return (match =value-form @@ -674,7 +723,7 @@ _ (define ?name)] (return (list [::Statement [::def ?name =value]])))))) -(defn ^:private analyse-annotate [?ident] +(defn ^:private analyse-declare-macro [?ident] (exec [_ (annotate ?ident ::public true [::&type/Any])] (return (list)))) @@ -682,16 +731,39 @@ (assert false) (return (list))) -(do-template [ ] +(do-template [ ] (defn [analyse-ast ?x ?y] - (exec [[=x =y] (analyse-n (list ?x ?y))] - (return (list [::Expression [ =x =y] [::&type/Data "java.lang.Integer"]])))) - - ^:private analyse-jvm-iadd "jvm;iadd" ::jvm-iadd - ^:private analyse-jvm-isub "jvm;isub" ::jvm-isub - ^:private analyse-jvm-imul "jvm;imul" ::jvm-imul - ^:private analyse-jvm-idiv "jvm;idiv" ::jvm-idiv - ^:private analyse-jvm-irem "jvm;irem" ::jvm-irem + (exec [:let [=type [::&type/Data ]] + [=x =y] (analyse-2 ?x ?y) + =x-type (expr-type =x) + =y-type (expr-type =y) + _ (&type/solve =type =x-type) + _ (&type/solve =type =y-type)] + (return (list [::Expression [ =x =y] =type])))) + + ^:private analyse-jvm-iadd "jvm;iadd" ::jvm-iadd "java.lang.Integer" + ^:private analyse-jvm-isub "jvm;isub" ::jvm-isub "java.lang.Integer" + ^:private analyse-jvm-imul "jvm;imul" ::jvm-imul "java.lang.Integer" + ^:private analyse-jvm-idiv "jvm;idiv" ::jvm-idiv "java.lang.Integer" + ^:private analyse-jvm-irem "jvm;irem" ::jvm-irem "java.lang.Integer" + + ^:private analyse-jvm-ladd "jvm;ladd" ::jvm-ladd "java.lang.Long" + ^:private analyse-jvm-lsub "jvm;lsub" ::jvm-lsub "java.lang.Long" + ^:private analyse-jvm-lmul "jvm;lmul" ::jvm-lmul "java.lang.Long" + ^:private analyse-jvm-ldiv "jvm;ldiv" ::jvm-ldiv "java.lang.Long" + ^:private analyse-jvm-lrem "jvm;lrem" ::jvm-lrem "java.lang.Long" + + ^:private analyse-jvm-iadd "jvm;fadd" ::jvm-fadd "java.lang.Float" + ^:private analyse-jvm-isub "jvm;fsub" ::jvm-fsub "java.lang.Float" + ^:private analyse-jvm-imul "jvm;fmul" ::jvm-fmul "java.lang.Float" + ^:private analyse-jvm-idiv "jvm;fdiv" ::jvm-fdiv "java.lang.Float" + ^:private analyse-jvm-irem "jvm;frem" ::jvm-frem "java.lang.Float" + + ^:private analyse-jvm-iadd "jvm;dadd" ::jvm-dadd "java.lang.Double" + ^:private analyse-jvm-isub "jvm;dsub" ::jvm-dsub "java.lang.Double" + ^:private analyse-jvm-imul "jvm;dmul" ::jvm-dmul "java.lang.Double" + ^:private analyse-jvm-idiv "jvm;ddiv" ::jvm-ddiv "java.lang.Double" + ^:private analyse-jvm-irem "jvm;drem" ::jvm-drem "java.lang.Double" ) (defn ^:private analyse-jvm-getstatic [analyse-ast ?class ?field] @@ -702,7 +774,7 @@ (defn ^:private analyse-jvm-getfield [analyse-ast ?class ?field ?object] (exec [=class (full-class-name ?class) =type (lookup-static-field =class ?field) - [=object] (analyse-n (list ?object))] + =object (analyse-1 ?object)] (return (list [::Expression [::jvm-getfield =class ?field =object] =type])))) (defn ^:private analyse-jvm-invokestatic [analyse-ast ?class ?method ?classes ?args] @@ -716,7 +788,7 @@ (exec [=class (full-class-name ?class) =classes (map-m extract-jvm-param ?classes) =return (lookup-virtual-method =class ?method =classes) - [=object] (analyse-n (list ?object)) + =object (analyse-1 ?object) =args (mapcat-m analyse-ast ?args)] (return (list [::Expression [::jvm-invokevirtual =class ?method =classes =object =args] =return])))) @@ -731,12 +803,12 @@ (return (list [::Expression [::jvm-new-array =class ?length] [::&type/Array [::&type/Data =class]]])))) (defn ^:private analyse-jvm-aastore [analyse-ast ?array ?idx ?elem] - (exec [[=array =elem] (analyse-n (list ?array ?elem)) + (exec [[=array =elem] (analyse-2 ?array ?elem) =array-type (expr-type =array)] (return (list [::Expression [::jvm-aastore =array ?idx =elem] =array-type])))) (defn ^:private analyse-jvm-aaload [analyse-ast ?array ?idx] - (exec [[=array] (analyse-n (list ?array)) + (exec [=array (analyse-1 ?array) =array-type (expr-type =array)] (return (list [::Expression [::jvm-aaload =array ?idx] =array-type])))) @@ -779,10 +851,10 @@ (return (list [::Expression [::bool ?value] [::&type/Data "java.lang.Boolean"]])) [::&parser/int ?value] - (return (list [::Expression [::int ?value] [::&type/Data "java.lang.Integer"]])) + (return (list [::Expression [::int ?value] [::&type/Data "java.lang.Long"]])) [::&parser/real ?value] - (return (list [::Expression [::real ?value] [::&type/Data "java.lang.Float"]])) + (return (list [::Expression [::real ?value] [::&type/Data "java.lang.Double"]])) [::&parser/char ?value] (return (list [::Expression [::char ?value] [::&type/Data "java.lang.Character"]])) @@ -811,8 +883,8 @@ [::&parser/form ([[::&parser/ident "def'"] [::&parser/ident ?name] ?value] :seq)] (analyse-def analyse-ast ?name ?value) - [::&parser/form ([[::&parser/ident "annotate"] [::&parser/ident ?ident] [::&parser/ident "Macro"]] :seq)] - (analyse-annotate ?ident) + [::&parser/form ([[::&parser/ident "declare-macro"] [::&parser/ident ?ident]] :seq)] + (analyse-declare-macro ?ident) [::&parser/form ([[::&parser/ident "require"] [::&parser/text ?path]] :seq)] (analyse-require analyse-ast ?path) @@ -820,7 +892,8 @@ ;; Host special forms [::&parser/form ([[::&parser/ident "do"] & ?exprs] :seq)] (analyse-do analyse-ast ?exprs) - + + ;; Integer arithmetic [::&parser/form ([[::&parser/ident "jvm;iadd"] ?x ?y] :seq)] (analyse-jvm-iadd analyse-ast ?x ?y) @@ -836,6 +909,54 @@ [::&parser/form ([[::&parser/ident "jvm;irem"] ?x ?y] :seq)] (analyse-jvm-irem analyse-ast ?x ?y) + ;; Long arithmetic + [::&parser/form ([[::&parser/ident "jvm;ladd"] ?x ?y] :seq)] + (analyse-jvm-ladd analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;lsub"] ?x ?y] :seq)] + (analyse-jvm-lsub analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;lmul"] ?x ?y] :seq)] + (analyse-jvm-lmul analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;ldiv"] ?x ?y] :seq)] + (analyse-jvm-ldiv analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;lrem"] ?x ?y] :seq)] + (analyse-jvm-lrem analyse-ast ?x ?y) + + ;; Float arithmetic + [::&parser/form ([[::&parser/ident "jvm;fadd"] ?x ?y] :seq)] + (analyse-jvm-fadd analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;fsub"] ?x ?y] :seq)] + (analyse-jvm-fsub analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;fmul"] ?x ?y] :seq)] + (analyse-jvm-fmul analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;fdiv"] ?x ?y] :seq)] + (analyse-jvm-fdiv analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;frem"] ?x ?y] :seq)] + (analyse-jvm-frem analyse-ast ?x ?y) + + ;; Double arithmetic + [::&parser/form ([[::&parser/ident "jvm;dadd"] ?x ?y] :seq)] + (analyse-jvm-dadd analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;dsub"] ?x ?y] :seq)] + (analyse-jvm-dsub analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;dmul"] ?x ?y] :seq)] + (analyse-jvm-dmul analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;ddiv"] ?x ?y] :seq)] + (analyse-jvm-ddiv analyse-ast ?x ?y) + + [::&parser/form ([[::&parser/ident "jvm;drem"] ?x ?y] :seq)] + (analyse-jvm-drem analyse-ast ?x ?y) + [::&parser/form ([[::&parser/ident "jvm;getstatic"] [::&parser/ident ?class] [::&parser/ident ?field]] :seq)] (analyse-jvm-getstatic analyse-ast ?class ?field) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index a62f66c35..daf2f1e09 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -18,9 +18,10 @@ ClassWriter MethodVisitor))) -(def +prefix+ "lux") - ;; [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))) @@ -31,31 +32,19 @@ (defn ^:private load-class! [loader name] (.loadClass loader name)) -(defn save-class! [name bytecode] +(defn ^:private save-class! [name bytecode] (exec [loader &util/loader :let [_ (write-class name bytecode) _ (load-class! loader (string/replace name #"/" "."))]] (return nil))) -(def ^:private +variant-class+ (str +prefix+ ".Variant")) -(def ^:private +tuple-class+ (str +prefix+ ".Tuple")) - -(defn ^:private unwrap-ident [ident] - (match ident - [::&parser/ident ?label] - ?label)) - -(defn ^:private with-writer [writer body] - (fn [state] - ;; (prn 'with-writer/_0 body) - (let [result (body (assoc state ::&util/writer writer))] - ;; (prn 'with-writer/_1 result) - (match result - [::&util/ok [?state ?value]] - [::&util/ok [(assoc ?state ::&util/writer (::&util/writer state)) ?value]] - - _ - result)))) +(def ^:private +prefix+ "lux.") +(def ^:private +variant-class+ (str +prefix+ "Variant")) +(def ^:private +tuple-class+ (str +prefix+ "Tuple")) +(def ^:private +function-class+ (str +prefix+ "Function")) +(def ^:private +local-prefix+ "l") +(def ^:private +partial-prefix+ "p") +(def ^:private +closure-prefix+ "c") (def ^:private ->package ->class) @@ -92,7 +81,7 @@ (->type-signature +variant-class+) [::&type/Lambda _ _] - (->type-signature (str +prefix+ "/Function")))) + (->type-signature +function-class+))) ;; [Utils/Compilers] (let [+class+ (->class "java.lang.Boolean") @@ -113,8 +102,8 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] (return nil)))) - ^:private compile-int "java.lang.Integer" "(I)V" - ^:private compile-real "java.lang.Float" "(F)V" + ^:private compile-int "java.lang.Long" "(J)V" + ^:private compile-real "java.lang.Double" "(D)V" ^:private compile-char "java.lang.Character" "(C)V" ) @@ -126,7 +115,7 @@ (defn ^:private compile-tuple [compile *type* ?elems] (exec [*writer* &util/get-writer :let [num-elems (count ?elems) - tuple-class (str +prefix+ "/Tuple" num-elems) + tuple-class (->class (str +tuple-class+ num-elems)) _ (doto *writer* (.visitTypeInsn Opcodes/NEW tuple-class) (.visitInsn Opcodes/DUP) @@ -134,14 +123,32 @@ _ (map-m (fn [idx] (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)] ret (compile (nth ?elems idx)) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str "_" (inc idx)) "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD tuple-class (str +partial-prefix+ idx) "Ljava/lang/Object;")]] (return ret))) (range num-elems))] (return nil))) +(defn ^:private compile-variant [compile *type* ?tag ?members] + (exec [*writer* &util/get-writer + :let [variant-class* (str (->class +variant-class+) (count ?members)) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW variant-class*) + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "" "()V") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ?tag) + (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String")))] + _ (map-m (fn [[?tfield ?member]] + (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)] + ret (compile ?member) + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* (str +partial-prefix+ ?tfield) "Ljava/lang/Object;")]] + (return ret))) + (map vector (range (count ?members)) ?members))] + (return nil))) + (defn ^:private compile-local [compile *type* ?idx] (exec [*writer* &util/get-writer - :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int (inc ?idx)))]] + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] (return nil))) (defn ^:private compile-captured [compile *type* ?scope ?captured-id ?source] @@ -150,13 +157,13 @@ (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD (normalize-ident ?scope) - (str "__" ?captured-id) + (str +closure-prefix+ ?captured-id) "Ljava/lang/Object;"))]] (return nil))) (defn ^:private compile-global [compile *type* ?owner-class ?name] (exec [*writer* &util/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (str ?owner-class "$" (normalize-ident ?name))) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (storage-id (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]] (return nil))) (def +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;") @@ -166,7 +173,7 @@ _ (compile ?fn) _ (map-m (fn [arg] (exec [ret (compile arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" +apply-signature+)]] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+)]] (return ret))) ?args)] (return nil))) @@ -177,7 +184,7 @@ :let [_ (match (:form ?fn) [::&analyser/global ?owner-class ?fn-name] (let [arg-sig (->type-signature "java.lang.Object") - call-class (str (->class ?owner-class) "$" (normalize-ident ?fn-name)) + call-class (storage-id (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)] @@ -186,7 +193,7 @@ (->> (doseq [arg (take ?needs-num ?args)]))) (.visitMethodInsn Opcodes/INVOKESTATIC call-class "impl" impl-sig) (-> (doto (do (compile arg)) - (.visitMethodInsn Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" +apply-signature+)) + (.visitMethodInsn Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+)) (->> (doseq [arg (drop ?needs-num ?args)]))))) (let [counter-sig "I" init-signature (str "(" (apply str counter-sig (repeat (dec ?needs-num) arg-sig)) ")" "V")] @@ -196,8 +203,7 @@ (.visitLdcInsn (int provides-num)) (-> (do (compile arg)) (->> (doseq [arg ?args]))) - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [_ (dec (- ?needs-num provides-num))]))) + (add-nulls (dec (- ?needs-num provides-num))) (.visitMethodInsn Opcodes/INVOKESPECIAL call-class "" init-signature))) )) )]] @@ -329,29 +335,59 @@ _ (compile (last ?exprs))] (return nil))) -(let [oclass (->class "java.lang.Object") - equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")] - (defn ^:private compile-compare-primitive [writer mappings default-label ?pairs wrapper-class signature] - (let [wrapper-class (->class wrapper-class)] - (doseq [[?token $body] ?pairs - :let [$else (new Label)]] - (doto writer - ;; object - (.visitInsn Opcodes/DUP) ;; object, object - (-> (doto (.visitTypeInsn Opcodes/NEW wrapper-class) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?token) - (.visitMethodInsn Opcodes/INVOKESPECIAL wrapper-class "" signature)) - (->> (if (nil? wrapper-class) - (.visitLdcInsn writer ?token)))) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B - (.visitJumpInsn Opcodes/IFEQ $else) ;; object - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO (get mappings $body)) - (.visitLabel $else))) +(do-template [ ] + (defn [writer mappings default-label ?pairs] + (doseq [[?token $body] ?pairs + :let [$else (new Label)]] + (doto writer + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class ) ) + (.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 [ ] + (defn [writer mappings default-label ?pairs] + (doseq [[?token $body] ?pairs + :let [$else (new Label)]] (doto writer + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class ) ) + (.visitLdcInsn ?token) + (.visitInsn ) + (.visitJumpInsn Opcodes/IFNE $else) (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO default-label))))) + (.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+) @@ -362,23 +398,23 @@ (defn ^:private compile-decision-tree [writer mappings default-label decision-tree] (match decision-tree [::test-bool ?pairs] - (compile-compare-primitive writer mappings default-label ?pairs "java.lang.Boolean" "(Z)V") + (compile-compare-bools writer mappings default-label ?pairs) - [::test-int ?pairs] - (compile-compare-primitive writer mappings default-label ?pairs "java.lang.Integer" "(I)V") + [::test-int ?pairs] + (compile-compare-ints writer mappings default-label ?pairs) [::test-real ?pairs] - (compile-compare-primitive writer mappings default-label ?pairs "java.lang.Float" "(F)V") + (compile-compare-reals writer mappings default-label ?pairs) [::test-char ?pairs] - (compile-compare-primitive writer mappings default-label ?pairs "java.lang.Character" "(C)V") + (compile-compare-chars writer mappings default-label ?pairs) [::test-text ?pairs] - (compile-compare-primitive writer mappings default-label ?pairs nil nil) + (compile-compare-texts writer mappings default-label ?pairs) [::store [::&analyser/local ?idx] $body] (doto writer - (.visitVarInsn Opcodes/ASTORE (inc ?idx)) + (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO (get mappings $body))) [::test-tuple ?branches ?cases] @@ -396,7 +432,7 @@ :let [sub-next-elem (new Label)]] (doto writer (.visitInsn Opcodes/DUP) ;; tuple, tuple - (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str "_" (inc ?subidx)) +variant-field-sig+) ;; tuple, object + (.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 @@ -429,7 +465,7 @@ :let [sub-next-elem (new Label)]] (doto writer (.visitInsn Opcodes/DUP) ;; variant, variant - (.visitFieldInsn Opcodes/GETFIELD variant-class** (str "_" (inc ?subidx)) +variant-field-sig+) ;; variant, object + (.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 @@ -528,7 +564,7 @@ mappings* (into {} (map first entries)) _ (dotimes [offset ?max-registers] (let [idx (+ ?base-idx offset)] - (.visitLocalVariable *writer* (str "v" idx) (->java-sig [::&type/Any]) nil start-label end-label idx)))] + (.visitLocalVariable *writer* (str +local-prefix+ idx) (->java-sig [::&type/Any]) nil start-label end-label idx)))] _ (compile ?variant) :let [_ (doto *writer* (.visitInsn Opcodes/DUP) @@ -546,7 +582,7 @@ (first (:defaults ?decision-tree)))] (doto *writer* (.visitInsn Opcodes/DUP) - (.visitVarInsn Opcodes/ASTORE (inc ?idx)) + (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO (get mappings* ?body))) (doto *writer* (.visitInsn Opcodes/POP) @@ -570,39 +606,13 @@ :let [start-label (new Label) end-label (new Label) _ (doto *writer* - (.visitLocalVariable (str "v" ?idx) (->java-sig (:type ?value)) nil start-label end-label ?idx) + (.visitLocalVariable (str +local-prefix+ ?idx) (->java-sig (:type ?value)) nil start-label end-label ?idx) (.visitLabel start-label) - (.visitVarInsn Opcodes/ASTORE (inc ?idx)))] + (.visitVarInsn Opcodes/ASTORE ?idx))] _ (compile ?body) :let [_ (.visitLabel *writer* end-label)]] (return nil))) -(defn ^:private compile-field [compile ?name body] - (exec [*writer* &util/get-writer - class-name &analyser/module-name - :let [outer-class (->class class-name) - datum-sig (->type-signature "java.lang.Object") - current-class (str outer-class "$" (normalize-ident ?name)) - _ (.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) - current-class nil "java/lang/Object" (into-array [(str +prefix+ "/Function")])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) - (doto (.visitEnd))))] - _ (with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (exec [*writer* &util/get-writer - :let [_ (.visitCode *writer*)] - _ (compile body) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd *writer*)] - _ (save-class! current-class (.toByteArray =class))] - (return nil))) - (let [clo-field-sig (->type-signature "java.lang.Object") lambda-return-sig (->type-signature "java.lang.Object") -return "V" @@ -627,19 +637,19 @@ (.visitVarInsn Opcodes/ALOAD 0) (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitVarInsn Opcodes/ALOAD ?captured-id) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str "__" ?captured-id)]) + (->> (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) - (.visitVarInsn Opcodes/ILOAD (inc num-mappings)) + (.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 "_" clo_idx)] + (->> (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)]) @@ -656,8 +666,8 @@ (.visitVarInsn Opcodes/ALOAD 0) (.visitFieldInsn Opcodes/GETFIELD class-name (str idx) clo-field-sig)))) - ^:private add-closed-over-vars "__" - ^:private add-partial-vars "_" + ^:private add-closure-vars +closure-prefix+ + ^:private add-partial-vars +partial-prefix+ ) (defn ^:private add-nulls [writer amount] @@ -678,8 +688,8 @@ (-> (doto (.visitLabel branch-label) (.visitTypeInsn Opcodes/NEW class-name) (.visitInsn Opcodes/DUP) - (add-closed-over-vars class-name closed-over) - (.visitLdcInsn (-> current-captured inc int)) + (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)) @@ -697,8 +707,8 @@ (.visitEnd)))) (defn ^:private add-lambda-impl [class compile impl-signature impl-body] - (with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) - (.visitCode)) + (&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*)] @@ -714,9 +724,7 @@ (defn ^:private instance-closure [compile lambda-class closed-over args init-signature] (exec [*writer* &util/get-writer - :let [;; _ (prn 'instance-closure/*writer* *writer*) - num-args (count args) - _ (doto *writer* + :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] _ (->> closed-over @@ -726,10 +734,10 @@ (match (:form ?captured) [::&analyser/captured ?closure-id ?captured-id ?source] (compile ?source))))) - :let [_ (do (when (> num-args 1) + :let [num-args (count args) + _ (do (when (> num-args 1) (.visitInsn *writer* Opcodes/ICONST_0) - (dotimes [_ (dec num-args)] - (.visitInsn *writer* Opcodes/ACONST_NULL))) + (add-nulls *writer* (dec num-args))) (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature))]] (return nil))) @@ -739,26 +747,25 @@ (.visitCode) (.visitTypeInsn Opcodes/NEW class-name) (.visitInsn Opcodes/DUP) - (-> (doto (.visitLdcInsn (int 0)) - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [_ (dec num-args)])))) + (-> (doto (.visitInsn *writer* Opcodes/ICONST_0) + (add-nulls (dec num-args))) (->> (when (> num-args 1)))) (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" -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 (reduce str "" (interpose "$" (map normalize-ident ?scope))) + (exec [:let [lambda-class (storage-id ?scope) impl-signature (lambda-impl-signature ?args) -sig (lambda--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 [(str +prefix+ "/Function")])) + 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 "__" ?captured-id)]) + (->> (let [captured-name (str +closure-prefix+ ?captured-id)]) (match (:form ?captured) [::&analyser/captured ?closure-id ?captured-id ?source]) (doseq [[?name ?captured] ?closure]))) @@ -779,13 +786,44 @@ (return nil)))) ) -(defn ^:private compile-def [compile *type* ?name ?value] - (exec [_ (match (:form ?value) - [::&analyser/lambda ?scope ?captured ?args ?body] - (compile-lambda compile *type* ?scope ?closure ?args ?body true false) +(defn ^:private compile-field [compile *type* ?name body] + (exec [*writer* &util/get-writer + class-name &analyser/module-name + :let [outer-class (->class class-name) + datum-sig (->type-signature "java.lang.Object") + current-class (storage-id (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) + current-class nil "java/lang/Object" (into-array [(->class +function-class+)])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) + (doto (.visitEnd))))] + _ (&util/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) + (exec [*writer* &util/get-writer + :let [_ (.visitCode *writer*)] + _ (compile body) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC current-class "_datum" datum-sig) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (save-class! current-class (.toByteArray =class))] + (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)) + _ - (compile-field compile ?name ?value))] + (fail "Can only define expressions."))] (return nil))) (defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods] @@ -829,163 +867,221 @@ _ (save-class! full-name (.toByteArray =interface))] (return nil))) -(defn ^:private compile-variant [compile *type* ?tag ?members] - (exec [*writer* &util/get-writer - :let [variant-class* (str (->class +variant-class+) (count ?members)) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW variant-class*) - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL variant-class* "" "()V") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ?tag) - (.visitFieldInsn Opcodes/PUTFIELD variant-class* "tag" (->type-signature "java.lang.String")))] - _ (map-m (fn [[?tfield ?member]] - (exec [:let [_ (.visitInsn *writer* Opcodes/DUP)] - ret (compile ?member) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD variant-class* (str "_" (inc ?tfield)) "Ljava/lang/Object;")]] - (return ret))) - (map vector (range (count ?members)) ?members))] - (return nil))) +(do-template [ ] + (defn [compile *type* ?x ?y] + (exec [:let [+wrapper-class+ (->class )] + *writer* &util/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) + _ (doto *writer* + (.visitInsn ) + (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ (str (->type-signature ))))]] + (return nil))) -(let [+int-class+ (->class "java.lang.Integer")] - (do-template [ ] - (defn [compile *type* ?x ?y] - (exec [*writer* &util/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +int-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +int-class+ "intValue" "()I"))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +int-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +int-class+ "intValue" "()I")) - _ (doto *writer* - (.visitInsn ) - (.visitMethodInsn Opcodes/INVOKESTATIC +int-class+ "valueOf" (str "(I)" (->type-signature "java.lang.Integer"))))]] - (return nil))) - - ^:private compile-jvm-iadd Opcodes/IADD - ^:private compile-jvm-isub Opcodes/ISUB - ^:private compile-jvm-imul Opcodes/IMUL - ^:private compile-jvm-idiv Opcodes/IDIV - ^:private compile-jvm-irem Opcodes/IREM - )) + ^: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)" + ) -(defn compile-self-call [compile ?assumed-args] +(defn ^:private compile-self-call [compile ?assumed-args] (exec [*writer* &util/get-writer :let [_ (.visitVarInsn *writer* Opcodes/ALOAD 0)] _ (map-m (fn [arg] (exec [ret (compile arg) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (str +prefix+ "/Function") "apply" +apply-signature+)]] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (->class +function-class+) "apply" +apply-signature+)]] (return ret))) ?assumed-args)] (return nil))) -(defn ^:private compile [syntax] +(defn ^:private compile-expression [syntax] (match (:form syntax) [::&analyser/bool ?value] - (compile-bool compile (:type syntax) ?value) + (compile-bool compile-expression (:type syntax) ?value) [::&analyser/int ?value] - (compile-int compile (:type syntax) ?value) + (compile-int compile-expression (:type syntax) ?value) [::&analyser/real ?value] - (compile-real compile (:type syntax) ?value) + (compile-real compile-expression (:type syntax) ?value) [::&analyser/char ?value] - (compile-char compile (:type syntax) ?value) + (compile-char compile-expression (:type syntax) ?value) [::&analyser/text ?value] - (compile-text compile (:type syntax) ?value) + (compile-text compile-expression (:type syntax) ?value) [::&analyser/tuple ?elems] - (compile-tuple compile (:type syntax) ?elems) + (compile-tuple compile-expression (:type syntax) ?elems) [::&analyser/local ?idx] - (compile-local compile (:type syntax) ?idx) + (compile-local compile-expression (:type syntax) ?idx) [::&analyser/captured ?scope ?captured-id ?source] - (compile-captured compile (:type syntax) ?scope ?captured-id ?source) + (compile-captured compile-expression (:type syntax) ?scope ?captured-id ?source) [::&analyser/global ?owner-class ?name] - (compile-global compile (:type syntax) ?owner-class ?name) + (compile-global compile-expression (:type syntax) ?owner-class ?name) [::&analyser/call ?fn ?args] - (compile-call compile (:type syntax) ?fn ?args) + (compile-call compile-expression (:type syntax) ?fn ?args) [::&analyser/static-call ?needs-num ?fn ?args] - (compile-static-call compile (:type syntax) ?needs-num ?fn ?args) + (compile-static-call compile-expression (:type syntax) ?needs-num ?fn ?args) [::&analyser/variant ?tag ?members] - (compile-variant compile (:type syntax) ?tag ?members) + (compile-variant compile-expression (:type syntax) ?tag ?members) [::&analyser/let ?idx ?value ?body] - (compile-let compile (:type syntax) ?idx ?value ?body) + (compile-let compile-expression (:type syntax) ?idx ?value ?body) [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree] - (compile-case compile (:type syntax) ?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/lambda ?scope ?frame ?args ?body] - (compile-lambda compile (:type syntax) ?scope ?frame ?args ?body false true) + (compile-lambda compile-expression (:type syntax) ?scope ?frame ?args ?body false true) - [::&analyser/def ?form ?body] - (compile-def compile (:type syntax) ?form ?body) - + ;; Integer arithmetic [::&analyser/jvm-iadd ?x ?y] - (compile-jvm-iadd compile (:type syntax) ?x ?y) + (compile-jvm-iadd compile-expression (:type syntax) ?x ?y) [::&analyser/jvm-isub ?x ?y] - (compile-jvm-isub compile (:type syntax) ?x ?y) + (compile-jvm-isub compile-expression (:type syntax) ?x ?y) [::&analyser/jvm-imul ?x ?y] - (compile-jvm-imul compile (:type syntax) ?x ?y) + (compile-jvm-imul compile-expression (:type syntax) ?x ?y) [::&analyser/jvm-idiv ?x ?y] - (compile-jvm-idiv compile (:type syntax) ?x ?y) + (compile-jvm-idiv compile-expression (:type syntax) ?x ?y) [::&analyser/jvm-irem ?x ?y] - (compile-jvm-irem compile (:type syntax) ?x ?y) + (compile-jvm-irem compile-expression (:type syntax) ?x ?y) + + ;; Long arithmetic + [::&analyser/jvm-ladd ?x ?y] + (compile-jvm-ladd compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-lsub ?x ?y] + (compile-jvm-lsub compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-lmul ?x ?y] + (compile-jvm-lmul compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-ldiv ?x ?y] + (compile-jvm-ldiv compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-lrem ?x ?y] + (compile-jvm-lrem compile-expression (:type syntax) ?x ?y) + ;; Float arithmetic + [::&analyser/jvm-fadd ?x ?y] + (compile-jvm-fadd compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-fsub ?x ?y] + (compile-jvm-fsub compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-fmul ?x ?y] + (compile-jvm-fmul compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-fdiv ?x ?y] + (compile-jvm-fdiv compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-frem ?x ?y] + (compile-jvm-frem compile-expression (:type syntax) ?x ?y) + + ;; Double arithmetic + [::&analyser/jvm-dadd ?x ?y] + (compile-jvm-dadd compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-dsub ?x ?y] + (compile-jvm-dsub compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-dmul ?x ?y] + (compile-jvm-dmul compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-ddiv ?x ?y] + (compile-jvm-ddiv compile-expression (:type syntax) ?x ?y) + + [::&analyser/jvm-drem ?x ?y] + (compile-jvm-drem compile-expression (:type syntax) ?x ?y) + [::&analyser/do ?exprs] - (compile-do compile (:type syntax) ?exprs) + (compile-do compile-expression (:type syntax) ?exprs) [::&analyser/jvm-new ?class ?classes ?args] - (compile-jvm-new compile (:type syntax) ?class ?classes ?args) + (compile-jvm-new compile-expression (:type syntax) ?class ?classes ?args) [::&analyser/jvm-getstatic ?class ?field] - (compile-jvm-getstatic compile (:type syntax) ?class ?field) + (compile-jvm-getstatic compile-expression (:type syntax) ?class ?field) [::&analyser/jvm-getfield ?class ?field ?object] - (compile-jvm-getfield compile (:type syntax) ?class ?field ?object) + (compile-jvm-getfield compile-expression (:type syntax) ?class ?field ?object) [::&analyser/jvm-invokestatic ?class ?method ?classes ?args] - (compile-jvm-invokestatic compile (:type syntax) ?class ?method ?classes ?args) + (compile-jvm-invokestatic compile-expression (:type syntax) ?class ?method ?classes ?args) [::&analyser/jvm-invokevirtual ?class ?method ?classes ?object ?args] - (compile-jvm-invokevirtual compile (:type syntax) ?class ?method ?classes ?object ?args) + (compile-jvm-invokevirtual compile-expression (:type syntax) ?class ?method ?classes ?object ?args) [::&analyser/jvm-new-array ?class ?length] - (compile-jvm-new-array compile (:type syntax) ?class ?length) + (compile-jvm-new-array compile-expression (:type syntax) ?class ?length) [::&analyser/jvm-aastore ?array ?idx ?elem] - (compile-jvm-aastore compile (:type syntax) ?array ?idx ?elem) + (compile-jvm-aastore compile-expression (:type syntax) ?array ?idx ?elem) [::&analyser/jvm-aaload ?array ?idx] - (compile-jvm-aaload compile (:type syntax) ?array ?idx) + (compile-jvm-aaload compile-expression (:type syntax) ?array ?idx) + [::&analyser/self ?assumed-args] + (compile-self-call compile-expression ?assumed-args) + + _ + (fail "[Compiler Error] Can't compile expressions as top-level forms.") + )) + +(defn ^:private compile-statement [syntax] + (match (:form syntax) + [::&analyser/def ?form ?body] + (compile-def compile-expression (:type syntax) ?form ?body) + [::&analyser/jvm-interface [?package ?name] ?members] - (compile-jvm-interface compile (:type syntax) ?package ?name ?members) + (compile-jvm-interface compile-expression (:type syntax) ?package ?name ?members) [::&analyser/jvm-class [?package ?name] ?super-class ?members] - (compile-jvm-class compile (:type syntax) ?package ?name ?super-class ?members) + (compile-jvm-class compile-expression (:type syntax) ?package ?name ?super-class ?members) - [::&analyser/self ?assumed-args] - (compile-self-call compile ?assumed-args) + _ + (fail "[Compiler Error] Can't compile expressions as top-level forms.") )) ;; [Interface] (let [compiler-step (exec [analysis+ &analyser/analyse] - (map-m compile analysis+))] + (map-m compile-statement analysis+))] (defn compile-module [name] (exec [loader &util/loader] (fn [state] @@ -994,28 +1090,25 @@ (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (->class name) nil "java/lang/Object" nil))] - (match ((repeat-m compiler-step) (assoc state - ::&util/source (slurp (str "source/" name ".lux")) - ::&util/current-module name - ::&util/writer =class)) - [::&util/ok [?state ?forms]] - (if (empty? (::&util/source ?state)) - (do (.visitEnd =class) - ((save-class! name (.toByteArray =class)) ?state)) - (assert false (str "[Compiler Error] Can't compile: " (::&util/source ?state)))) + (match (&util/run-state (exhaust-m compiler-step) (assoc state + ::&util/source (slurp (str "source/" name ".lux")) + ::&util/current-module name + ::&util/writer =class)) + [::&util/ok [?state _]] + (do (.visitEnd =class) + (&util/run-state (save-class! name (.toByteArray =class)) ?state)) [::&util/failure ?message] (fail* ?message)))))))) (defn compile-all [modules] (.mkdir (java.io.File. "output")) - (let [state (&util/init-state)] - (match ((map-m compile-module modules) state) - [::&util/ok [?state ?forms]] - (println (str "Compilation complete! " (pr-str modules))) + (match (&util/run-state (map-m compile-module modules) (&util/init-state)) + [::&util/ok [?state _]] + (println (str "Compilation complete! " (pr-str modules))) - [::&util/failure ?message] - (assert false ?message)))) + [::&util/failure ?message] + (assert false ?message))) (comment (compile-all ["lux"]) diff --git a/src/lux/type.clj b/src/lux/type.clj index a7bc8b522..9d9cf77aa 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -11,14 +11,14 @@ (defn ^:private resolve [id] (fn [state] - (if-let [top+bottom (get-in state [::mappings id])] + (if-let [top+bottom (get-in state [::&util/types ::mappings id])] [::&util/ok [state top+bottom]] [::&util/failure (str "Unknown type-var: " id)]))) (defn ^:private update [id top bottom] (fn [state] - (if-let [top+bottom (get-in state [::mappings id])] - [::&util/ok [(assoc-in state [::mappings id] [top bottom]) nil]] + (if-let [top+bottom (get-in state [::&util/types ::mappings id])] + [::&util/ok [(assoc-in state [::&util/types ::mappings id] [top bottom]) nil]] [::&util/failure (str "Unknown type-var: " id)]))) ;; [Interface] diff --git a/src/lux/util.clj b/src/lux/util.clj index 9bd8ed42c..207a07203 100644 --- a/src/lux/util.clj +++ b/src/lux/util.clj @@ -150,15 +150,6 @@ (exec [head (first m-values)] (sequence-m (rest monads))))) -(defn within [slot monad] - (fn [state] - (let [=return (monad (get state slot))] - (match =return - [::ok [?state ?value]] - [::ok [(assoc state slot ?state) ?value]] - _ - =return)))) - (defn ^:private normalize-char [char] (case char \* "_ASTER_" @@ -201,10 +192,15 @@ {:counter 0 :mappings {}}) +(defn scope [name] + {:name name + :inner-lambdas 0 + :locals +init-env+ + :closure +init-env+}) + (defn init-state [] {::source nil ::current-module nil - ::scope (list) ::modules {} ::global-env {} ::local-envs (list) @@ -212,12 +208,26 @@ ::writer nil ::loader (class-loader!)}) -(do-template [] +(do-template [ ] (def (fn [state] - [::ok [state (::current-module state)]])) + (if-let [datum ( state)] + [::ok [state datum]] + [::failure (str "Data does not exist: " )]))) get-module-name ::current-module - get-scope ::scope get-writer ::writer ) + +(defn with-writer [writer body] + (fn [state] + (let [output (body (assoc state ::writer writer))] + (match output + [::ok [?state ?value]] + [::ok [(assoc ?state ::writer (::writer state)) ?value]] + + _ + output)))) + +(defn run-state [monad state] + (monad state)) -- cgit v1.2.3