From 0143d8b7595c136d2464582c46ab57fe322efc50 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 18 Nov 2016 13:32:57 -0400 Subject: - Now using a special file for caching module information for defs (types and anns). --- src/lux/analyser/module.clj | 7 +- src/lux/compiler.clj | 21 +++-- src/lux/compiler/base.clj | 17 +++++ src/lux/compiler/cache.clj | 46 +++++------ src/lux/compiler/cache/ann.clj | 159 ++++++++++++++++++++++++++++++++++++++ src/lux/compiler/cache/type.clj | 164 ++++++++++++++++++++++++++++++++++++++++ src/lux/compiler/lux.clj | 55 +++----------- 7 files changed, 394 insertions(+), 75 deletions(-) create mode 100644 src/lux/compiler/cache/ann.clj create mode 100644 src/lux/compiler/cache/type.clj diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 21aa324e8..61b11b596 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -361,13 +361,14 @@ (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|map (fn [kv] - (|let [[k [?def-type ?def-meta ?def-value]] kv] + (|let [[k _def-data] kv + [_ ?def-meta _] _def-data] (|case (&meta/meta-get &meta/alias-tag ?def-meta) (&/$Some (&/$IdentM [?r-module ?r-name])) - (&/T [k (str ?r-module ";" ?r-name)]) + (&/T [k (str ?r-module ";" ?r-name) _def-data]) _ - (&/T [k ""]) + (&/T [k "" _def-data]) ))))))))) (do-template [ ] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 39e475aaa..869ee84d7 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -30,7 +30,9 @@ [lambda :as &&lambda] [module :as &&module] [io :as &&io] - [parallel :as &¶llel])) + [parallel :as &¶llel]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -213,12 +215,20 @@ defs &a-module/defs imports &a-module/imports tag-groups &&module/tag-groups - :let [^String defs-value (->> defs + :let [^String def-entries (->> defs + (&/|map (fn [_def] + (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def] + (if (= "" ?alias) + (str ?name &&/def-datum-separator (&&&type/serialize-type ?def-type) &&/def-datum-separator (&&&ann/serialize-anns ?def-anns)) + (str ?name &&/def-datum-separator ?alias))))) + (&/|interpose &&/def-entry-separator) + (&/fold str "")) + ^String defs-value (->> defs (&/|filter (fn [_def] - (|let [[?name ?alias] _def] + (|let [[?name ?alias [?def-type ?def-meta ?def-value]] _def] (= "" ?alias)))) (&/|map (fn [_def] - (|let [[?name ?alias] _def] + (|let [[?name ?alias [?def-type ?def-meta ?def-value]] _def] (str ?name &&/exported-separator ?alias)))) @@ -258,7 +268,8 @@ (return nil))) :let [_ (.visitEnd =class)] _ (&/flag-compiled-module name) - _ (&&/save-class! &/module-class-name (.toByteArray =class))] + _ (&&/save-class! &/module-class-name (.toByteArray =class)) + _ (&&/write-module-descriptor! name def-entries)] (return file-hash)) ?state) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index a369b7436..fcb153662 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -52,6 +52,9 @@ (def ^:const field-separator "\t") (def ^:const entry-separator "\n") +(def ^:const def-datum-separator (->> 31 char str)) +(def ^:const def-entry-separator (->> 30 char str)) + ;; [Utils] (defn ^:private write-file [^String file-name ^bytes data] (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) @@ -88,6 +91,20 @@ _ (load-class! loader real-name)]] (return nil))) +(def ^String lux-module-descriptor-name "lux_module_descriptor") + +(defn write-module-descriptor! [^String name ^String descriptor] + (|do [_ (return nil) + :let [lmd-dir (str @!output-dir "/" name) + _ (.mkdirs (File. lmd-dir)) + _ (write-file (str lmd-dir "/" lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]] + (return nil))) + +(defn read-module-descriptor! [^String name] + (|do [_ (return nil)] + (return (slurp (str @!output-dir "/" name "/" lux-module-descriptor-name) + :encoding "UTF-8")))) + (do-template [ ] (do (defn [^MethodVisitor writer] (doto writer diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index c0b0bc344..ba221b73d 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -17,7 +17,9 @@ [module :as &a-module] [meta :as &a-meta]) (lux.compiler [base :as &&] - [io :as &&io])) + [io :as &&io]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) (:import (java.io File BufferedOutputStream FileOutputStream) @@ -152,33 +154,31 @@ (&/T [_type (&/->list (string/split (or _tags "") tag-separator-re))]))))) &/->list)))] (|do [_ (&a-module/create-module module module-hash) + ^String descriptor (&&/read-module-descriptor! module) :let [module-anns (get-field &/anns-field module-class)] _ (&a-module/set-anns module-anns module) _ (&/flag-cached-module module) _ (&a-module/set-imports imports) - _ (&/map% (fn [_def] - (let [[_name _alias] (string/split _def #" ")] - (if (= nil _alias) - (let [def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) - def-meta (get-field &/anns-field def-class) - def-type (|case (&a-meta/meta-get &a-meta/type?-tag def-meta) - (&/$Some (&/$BoolM true)) - &type/Type - - _ - (get-field &/type-field def-class)) - def-value (get-field &/value-field def-class)] - (&a-module/define module _name def-type def-meta def-value)) - (let [[_ __module __name] (re-find #"^(.*);(.*)$" _alias) - def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) - def-type (get-field &/type-field def-class) - def-meta (&/|list (&/T [&a-meta/alias-tag (&/$IdentM (&/T [__module __name]))])) - def-value (get-field &/value-field def-class)] - (&a-module/define module _name def-type def-meta def-value))) - )) - (if (= [""] defs) + :let [desc-defs (vec (.split descriptor &&/def-entry-separator))] + _ (&/map% (fn [^String _def-entry] + (let [parts (.split _def-entry &&/def-datum-separator)] + (case (alength parts) + 2 (let [[_name _alias] parts + [_ __module __name] (re-find #"^(.*);(.*)$" _alias) + def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) + def-type (&a-module/def-type __module __name) + def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentM (&/T [__module __name]))])) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-anns def-value)) + 3 (let [[_name _type _anns] parts + def-class (&&/load-class! loader (str module* "." (&host/def-name _name))) + [def-anns _] (&&&ann/deserialize-anns _anns) + [def-type _] (&&&type/deserialize-type _type) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-anns def-value))))) + (if (= [""] desc-defs) &/$Nil - (&/->list defs))) + (&/->list desc-defs))) _ (&/map% (fn [group] (|let [[_type _tags] group] (|do [[was-exported? =type] (&a-module/type-def module _type)] diff --git a/src/lux/compiler/cache/ann.clj b/src/lux/compiler/cache/ann.clj new file mode 100644 index 000000000..d50c02465 --- /dev/null +++ b/src/lux/compiler/cache/ann.clj @@ -0,0 +1,159 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.cache.ann + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]]))) + +(def ^:private stop (->> 7 char str)) +(def ^:private cons-signal (->> 5 char str)) +(def ^:private nil-signal (->> 6 char str)) +(def ^:private ident-separator ";") + +(defn ^:private serialize-seq [serialize-ann params] + (str (&/fold (fn [so-far param] + (str so-far cons-signal (serialize-ann param))) + "" + params) + nil-signal)) + +(defn ^:private serialize-text [value] + (str "T" value stop)) + +(defn ^:private serialize-ident [ident] + (|let [[module name] ident] + (str "@" module ident-separator name stop))) + +(defn serialize-ann + "(-> Ann-Value Text)" + [ann] + (|case ann + (&/$BoolM value) + (str "B" value stop) + + (&/$NatM value) + (str "N" value stop) + + (&/$IntM value) + (str "I" value stop) + + (&/$FracM value) + (str "F" value stop) + + (&/$RealM value) + (str "R" value stop) + + (&/$CharM value) + (str "C" value stop) + + (&/$TextM value) + (serialize-text value) + + (&/$IdentM ident) + (serialize-ident ident) + + (&/$ListM elems) + (str "L" (serialize-seq serialize-ann elems)) + + (&/$DictM kvs) + (str "D" (serialize-seq (fn [kv] + (|let [[k v] kv] + (str (serialize-text k) + (serialize-ann v)))) + kvs)) + + _ + (assert false) + )) + +(defn serialize-anns + "(-> Anns Text)" + [anns] + (serialize-seq (fn [kv] + (|let [[k v] kv] + (str (serialize-ident k) + (serialize-ann v)))) + anns)) + +(declare deserialize-ann) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (let [[value* ^String input*] (.split (.substring input 1) stop 2)] + [( ( value*)) input*]))) + + ^:private deserialize-bool "B" &/$BoolM Boolean/parseBoolean + ^:private deserialize-nat "N" &/$NatM Long/parseLong + ^:private deserialize-int "I" &/$IntM Long/parseLong + ^:private deserialize-frac "F" &/$FracM Long/parseLong + ^:private deserialize-real "R" &/$RealM Double/parseDouble + ^:private deserialize-char "C" &/$CharM (fn [^String input] (.charAt input 0)) + ^:private deserialize-text "T" &/$TextM identity + ) + +(defn ^:private deserialize-ident* [^String input] + (when (.startsWith input "@") + (let [[ident* ^String input*] (.split (.substring input 1) stop 2) + [_module _name] (.split ident* ident-separator 2)] + [(&/T [_module _name]) input*]))) + +(defn ^:private deserialize-ident [^String input] + (when (.startsWith input "@") + (let [[ident* ^String input*] (.split (.substring input 1) stop 2) + [_module _name] (.split ident* ident-separator 2)] + [(&/$IdentM (&/T [_module _name])) input*]))) + +(defn ^:private deserialize-seq [deserializer input] + (cond (.startsWith input nil-signal) + [&/$Nil (.substring input 1)] + + (.startsWith input cons-signal) + (when-let [[head ^String input*] (deserializer (.substring input 1))] + (when-let [[tail ^String input*] (deserialize-seq deserializer input*)] + [(&/$Cons head tail) input*])) + )) + +(do-template [ ] + (defn [input] + (when-let [[key input*] ( input)] + (when-let [[ann input*] (deserialize-ann input*)] + [(&/T [key ann]) input*]))) + + ^:private deserialize-kv deserialize-text + ^:private deserialize-ann-entry deserialize-ident* + ) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (when-let [[elems ^String input*] (deserialize-seq + (.substring input 1))] + [( elems) input*]))) + + ^:private deserialize-list "L" &/$ListM deserialize-ann + ^:private deserialize-dict "D" &/$DictM deserialize-kv + ) + +(defn ^:private deserialize-ann + "(-> Text Anns)" + [input] + (or (deserialize-bool input) + (deserialize-nat input) + (deserialize-int input) + (deserialize-frac input) + (deserialize-real input) + (deserialize-char input) + (deserialize-text input) + (deserialize-ident input) + (deserialize-list input) + (deserialize-dict input) + (assert false "[Cache error] Can't deserialize annocation."))) + +(defn deserialize-anns [^String input] + (deserialize-seq deserialize-ann-entry input)) diff --git a/src/lux/compiler/cache/type.clj b/src/lux/compiler/cache/type.clj new file mode 100644 index 000000000..80d3a93d6 --- /dev/null +++ b/src/lux/compiler/cache/type.clj @@ -0,0 +1,164 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.compiler.cache.type + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]))) + +(def ^:private stop (->> 7 char str)) +(def ^:private cons-signal (->> 5 char str)) +(def ^:private nil-signal (->> 6 char str)) +(def ^:private ident-separator ";") + +(defn ^:private serialize-list [serialize-type params] + (str (&/fold (fn [so-far param] + (str so-far cons-signal (serialize-type param))) + "" + params) + nil-signal)) + +(defn serialize-type + "(-> Type Text)" + [type] + (if (clojure.lang.Util/identical &type/Type type) + "T" + (|case type + (&/$HostT name params) + (str "^" name stop (serialize-list serialize-type params)) + + (&/$VoidT) + "0" + + (&/$UnitT) + "1" + + (&/$ProdT left right) + (str "*" (serialize-type left) (serialize-type right)) + + (&/$SumT left right) + (str "+" (serialize-type left) (serialize-type right)) + + (&/$LambdaT left right) + (str ">" (serialize-type left) (serialize-type right)) + + (&/$UnivQ env body) + (str "U" (serialize-list serialize-type env) (serialize-type body)) + + (&/$ExQ env body) + (str "E" (serialize-list serialize-type env) (serialize-type body)) + + (&/$BoundT idx) + (str "$" idx stop) + + (&/$ExT idx) + (str "!" idx stop) + + (&/$VarT idx) + (str "?" idx stop) + + (&/$AppT left right) + (str "%" (serialize-type left) (serialize-type right)) + + (&/$NamedT [module name] type*) + (str "@" module ident-separator name stop (serialize-type type*)) + + _ + (assert false (prn 'serialize-type (&type/show-type type))) + ))) + +(declare deserialize-type) + +(defn ^:private deserialize-list [input] + (cond (.startsWith input nil-signal) + [&/$Nil (.substring input 1)] + + (.startsWith input cons-signal) + (when-let [[head ^String input*] (deserialize-type (.substring input 1))] + (when-let [[tail ^String input*] (deserialize-list input*)] + [(&/$Cons head tail) input*])) + )) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + [ (.substring input 1)] + )) + + ^:private deserialize-void "0" &/$VoidT + ^:private deserialize-unit "1" &/$UnitT + ^:private deserialize-type* "T" &type/Type + ) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (when-let [[left ^String input*] (deserialize-type (.substring input 1))] + (when-let [[right ^String input*] (deserialize-type input*)] + [( left right) input*])) + )) + + ^:private deserialize-sum "+" &/$SumT + ^:private deserialize-prod "*" &/$ProdT + ^:private deserialize-lambda ">" &/$LambdaT + ^:private deserialize-app "%" &/$AppT + ) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (let [[idx ^String input*] (.split (.substring input 1) stop 2)] + [( (Long/parseLong idx)) input*]))) + + ^:private deserialize-bound "$" &/$BoundT + ^:private deserialize-ex "!" &/$ExT + ^:private deserialize-var "?" &/$VarT + ) + +(defn ^:private deserialize-named [^String input] + (when (.startsWith input "@") + (let [[^String module+name ^String input*] (.split (.substring input 1) stop 2) + [module name] (.split module+name ident-separator 2)] + (when-let [[type* ^String input*] (deserialize-type input*)] + [(&/$NamedT (&/T [module name]) type*) input*])))) + +(do-template [ ] + (defn [^String input] + (when (.startsWith input ) + (when-let [[env ^String input*] (deserialize-list (.substring input 1))] + (when-let [[body ^String input*] (deserialize-type input*)] + [( env body) input*])))) + + ^:private deserialize-univq "U" &/$UnivQ + ^:private deserialize-exq "E" &/$ExQ + ) + +(defn ^:private deserialize-host [^String input] + (when (.startsWith input "^") + (let [[name ^String input*] (.split (.substring input 1) stop 2)] + (when-let [[params ^String input*] (deserialize-list input*)] + [(&/$HostT name params) input*])))) + +(defn deserialize-type + "(-> Text Type)" + [input] + (or (deserialize-type* input) + (deserialize-void input) + (deserialize-unit input) + (deserialize-sum input) + (deserialize-prod input) + (deserialize-lambda input) + (deserialize-app input) + (deserialize-bound input) + (deserialize-ex input) + (deserialize-var input) + (deserialize-named input) + (deserialize-univq input) + (deserialize-exq input) + (deserialize-host input) + (assert false (str "[Cache error] Can't deserialize type. --- " input)))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index a6b636107..1ea078e76 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -267,7 +267,6 @@ (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name))) def-class (&&/load-class! class-loader current-class) def-type (&a-module/def-type r-module r-name) - ;; def-type (-> def-class (.getField &/type-field) (.get nil)) def-meta ?meta def-value (-> def-class (.getField &/value-field) (.get nil))] _ (&/without-repl-closure @@ -285,7 +284,6 @@ false (de-ann ?body))] (|do [:let [=value-type (&a/expr-type* ?body)] - ;; ^ClassWriter *writer* &/get-writer [file-name _ _] &/cursor :let [datum-sig "Ljava/lang/Object;" def-name (&host/def-name ?name) @@ -295,10 +293,6 @@ current-class nil &&/function-class (into-array String [])) (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) (doto (.visitEnd))) - ;; (-> (.visitField field-flags &/type-field datum-sig nil nil) - ;; (doto (.visitEnd))) - ;; (-> (.visitField field-flags &/anns-field datum-sig nil nil) - ;; (doto (.visitEnd))) (-> (.visitField field-flags &/value-field datum-sig nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] @@ -306,10 +300,6 @@ _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] - ;; _ (compile-def-type compile ?body) - ;; :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/type-field datum-sig)] - ;; _ (&&/compile-meta compile ?meta) - ;; :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/anns-field datum-sig)] _ instancer :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] @@ -318,23 +308,16 @@ (.visitMaxs 0 0) (.visitEnd))]] (return nil))) - ;; :let [_ (.visitEnd *writer*)] :let [_ (.visitEnd =class)] _ (&&/save-class! def-name (.toByteArray =class)) :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) def-type (&a/expr-type* ?body) - [;; def-type - is-type?] (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) - (&/$Some (&/$BoolM true)) - (&/T [;; &type/Type - true]) - - _ - (if (&type/type= &type/Type =value-type) - (&/T [;; &type/Type - false]) - (&/T [;; (-> def-class (.getField &/type-field) (.get nil)) - false]))) + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolM true)) + true + + _ + false) def-meta ?meta def-value (-> def-class (.getField &/value-field) (.get nil))] _ (&/without-repl-closure @@ -371,7 +354,6 @@ _ (|do [:let [=value-type (&a/expr-type* ?body)] - ;; ^ClassWriter *writer* &/get-writer [file-name _ _] &/cursor :let [datum-sig "Ljava/lang/Object;" def-name (&host/def-name ?name) @@ -381,20 +363,12 @@ current-class nil "java/lang/Object" (into-array String [])) (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) (doto (.visitEnd))) - ;; (-> (.visitField field-flags &/type-field datum-sig nil nil) - ;; (doto (.visitEnd))) - ;; (-> (.visitField field-flags &/anns-field datum-sig nil nil) - ;; (doto (.visitEnd))) (-> (.visitField field-flags &/value-field datum-sig nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] - ;; _ (compile-def-type compile ?body) - ;; :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/type-field datum-sig)] - ;; _ (&&/compile-meta compile ?meta) - ;; :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/anns-field datum-sig)] _ (compile nil ?body) :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] @@ -403,23 +377,16 @@ (.visitMaxs 0 0) (.visitEnd))]] (return nil))) - ;; :let [_ (.visitEnd *writer*)] :let [_ (.visitEnd =class)] _ (&&/save-class! def-name (.toByteArray =class)) :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) def-type (&a/expr-type* ?body) - [;; def-type - is-type?] (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) - (&/$Some (&/$BoolM true)) - (&/T [;; &type/Type - true]) + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolM true)) + true - _ - (if (&type/type= &type/Type =value-type) - (&/T [;; &type/Type - false]) - (&/T [;; (-> def-class (.getField &/type-field) (.get nil)) - false]))) + _ + false) def-meta ?meta def-value (-> def-class (.getField &/value-field) (.get nil))] _ (&/without-repl-closure -- cgit v1.2.3