From b059fa2a5efb4cab8b62d895e8c9adf1434bde2d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 18 Aug 2015 23:30:50 -0400 Subject: - Tags data is now stored in the cache. - Fixed a caching bug wherein imports data wasn't being installed when loading cached modules. - Fixed a compilation error regarding tags in compile-program. - Refactored the names of fields inside the generated classes, and also the named of the "module class". - Refactored some of the details of how module info is stored inside the fields of module classes. --- src/lux/analyser/module.clj | 30 ++++++++++++++++++++++++++-- src/lux/base.clj | 48 +++++++++++++++++++++++++++++++++------------ src/lux/compiler.clj | 37 +++++++++++++++++++++++----------- src/lux/compiler/base.clj | 10 ++++++++++ src/lux/compiler/cache.clj | 39 ++++++++++++++++++++++++++---------- src/lux/compiler/host.clj | 2 ++ src/lux/compiler/lux.clj | 19 +++++++++--------- src/lux/compiler/module.clj | 28 ++++++++++++++++++++++++++ 8 files changed, 168 insertions(+), 45 deletions(-) create mode 100644 src/lux/compiler/module.clj diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 5190e2dcf..d23953f5e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -49,6 +49,18 @@ state) nil)))) +(defn set-imports [imports] + "(-> (List Text) (Lux (,)))" + (|do [current-module &/get-module-name] + (fn [state] + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) + nil)))) + (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] @@ -89,6 +101,20 @@ (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) (fail* (str "[Analyser Error] Unknown module: " module))))) +(defn type-def [module name] + "(-> Text Text (Lux Type))" + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + [_ (&/$TypeD _type)] + (return* state _type) + + _ + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown module: " module))))) + (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] @@ -179,7 +205,7 @@ ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) - (.getField "_datum") + (.getField &/datum-field) (.get nil))]] (fn [state*] (return* (&/update$ &/$modules @@ -293,7 +319,7 @@ (defn declare-tags [module tag-names type] "(-> Text (List Text) Type (Lux (,)))" - (|do [;; :let [_ (prn 'declare-tags (&/->seq tag-names) (&/adt->text type))] + (|do [;; :let [_ (prn 'declare-tags module (&/->seq tag-names) (&type/show-type type))] _ (ensure-undeclared-tags module tag-names) type-name (&type/type-name type) :let [[_module _name] type-name] diff --git a/src/lux/base.clj b/src/lux/base.clj index 84b09bcac..6247524af 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -61,7 +61,18 @@ "AppT" "NamedT") -;; [Fields] +;; Vars +(deftags "lux;" + "Local" + "Global") + +;; Definitions +(deftags "lux;" + "ValueD" + "TypeD" + "MacroD" + "AliasD") + ;; Binding (deftags "" "counter" @@ -92,19 +103,18 @@ "eval?" "host") -;; Vars -(deftags "lux;" - "Local" - "Global") - -;; Definitions -(deftags "lux;" - "ValueD" - "TypeD" - "MacroD" - "AliasD") - ;; [Exports] +(def datum-field "_datum") +(def meta-field "_meta") +(def name-field "_name") +(def hash-field "_hash") +(def compiler-field "_compiler") +(def imports-field "_imports") +(def defs-field "_defs") +(def eval-field "_eval") +(def tags-field "_tags") +(def module-class-name "_") + (def +name-separator+ ";") (defn T [& elems] @@ -686,6 +696,18 @@ ($Cons ?global _) (return* state (get$ $name ?global))))) +(defn find-module [name] + "(-> Text (Lux (Module Compiler)))" + (fn [state] + (if-let [module (|get name (get$ $modules state))] + (return* state module) + (fail* (str "Unknown module: " name))))) + +(def get-current-module + "(Lux (Module Compiler))" + (|do [module-name get-module-name] + (find-module module-name))) + (defn with-scope [name body] (fn [state] (let [output (body (update$ $envs #(|cons (env name) %) state))] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 1814a97c0..79d2c84f8 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -30,6 +30,7 @@ [case :as &&case] [lambda :as &&lambda] [package :as &&package] + [module :as &&module] [io :as &&io])) (:import (org.objectweb.asm Opcodes Label @@ -378,14 +379,14 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) (doto (.visitEnd))))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitCode *writer*)] _ (compile-expression expr) :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] @@ -395,7 +396,7 @@ _ (&&/save-class! (str id) bytecode) loader &/loader] (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id)) - (.getField "_eval") + (.getField &/eval-field) (.get nil) return)))) @@ -414,9 +415,9 @@ :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/hash-field "I" nil file-hash) .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version) .visitEnd)) ;; _ (prn 'compile-module name =class) ]] @@ -427,22 +428,36 @@ (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports + tag-groups &&module/tag-groups :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/defs-field "Ljava/lang/String;" nil (->> defs (&/|map (fn [_def] (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") + (str (if ?exported &&/exported-true &&/exported-false) + &&/exported-separator + ?name + &&/exported-separator + ?ann)))) + (&/|interpose &&/def-separator) (&/fold str ""))) .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/imports-field "Ljava/lang/String;" nil + (->> imports (&/|interpose &&/import-separator) (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/tags-field "Ljava/lang/String;" nil + (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags (&/|interpose &&/tag-separator) (&/fold str "") + (str type &&/type-separator))))) + (&/|interpose &&/tag-group-separator) + (&/fold str ""))) .visitEnd) (.visitEnd)) ;; _ (prn 'CLOSED name =class) ]] - (&&/save-class! "_" (.toByteArray =class))) + (&&/save-class! &/module-class-name (.toByteArray =class))) ?state) (&/$Left ?message) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 03fae9fec..1e5f3a024 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -33,11 +33,21 @@ (def ^String output-package (str output-dir "/program.jar")) (def ^String function-class "lux/Function") +;; Formats (def ^String local-prefix "l") (def ^String partial-prefix "p") (def ^String closure-prefix "c") (def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") +(def exported-true "1") +(def exported-false "0") +(def exported-separator " ") +(def def-separator "\t") +(def import-separator "\t") +(def tag-separator " ") +(def type-separator "\t") +(def tag-group-separator "\n") + ;; [Utils] (defn ^:private write-file [^String file ^bytes data] (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 85488553c..dc224f52e 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -12,7 +12,7 @@ [clojure.java.io :as io] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |case]] + (lux [base :as & :refer [|do return* return fail fail* |case |let]] [type :as &type] [host :as &host]) (lux.analyser [base :as &a] @@ -88,9 +88,9 @@ class-name (str module* "._") ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= &&/version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + (if (and (= module-hash (get-field &/hash-field module-meta)) + (= &&/version (get-field &/compiler-field module-meta))) + (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator))) ;; _ (prn 'load/IMPORTS module imports) ] (|do [loads (&/map% (fn [_import] @@ -108,24 +108,38 @@ ;; _ (prn 'load module real-name) ] (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator))) + ;; _ (prn module '(get-field &/tags-field module-meta) + ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))) + tag-groups (let [all-tags (get-field &/tags-field module-meta)] + (if (= "" all-tags) + (&/|list) + (-> all-tags + (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) + (->> (map (fn [_group] + ;; (prn '_group _group) + (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] + ;; (prn '[_type _tags] [_type _tags]) + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) + _ (&a-module/set-imports imports) _ (&/map% (fn [_def] (let [[_exported? _name _ann] (string/split _def #" ") ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) ] (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field "_datum" def-class)] + def-value (get-field &/datum-field def-class)] (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field "_datum" def-class)] + def-value (get-field &/datum-field def-class)] (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-meta (get-field "_meta" def-class)] + def-meta (get-field &/meta-field def-class)] (|case def-meta (&/$ValueD def-type _) (&a-module/define module _name def-meta def-type))) @@ -134,13 +148,18 @@ (|do [__type (&a-module/def-type __module __name)] (do ;; (prn '__type [__module __name] (&type/show-type __type)) (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) + (if (= &&/exported-true _exported?) (&a-module/export module _name) (return nil))) )) (if (= [""] defs) (&/|list) - (&/->list defs)))] + (&/->list defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [=type (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags =type)))) + tag-groups)] (return true)))) redo-cache))) redo-cache) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 0ae4ce2da..26ef73cb7 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -571,6 +571,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$Nil) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -616,6 +617,7 @@ (.visitInsn Opcodes/DUP) ;; I2VV (.visitLdcInsn (int 0)) ;; I2VVI (.visitLdcInsn &/$Cons) ;; I2VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; I2V (.visitInsn Opcodes/DUP_X1) ;; IV2V (.visitInsn Opcodes/SWAP) ;; IVV2 diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index e2b9f0e89..83e294c1a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -73,6 +73,7 @@ (return nil))) (defn compile-variant [compile *type* ?tag ?value] + ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) @@ -105,7 +106,7 @@ (defn compile-global [compile *type* ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) &/datum-field "Ljava/lang/Object;")]] (return nil))) (defn compile-apply [compile *type* ?fn ?args] @@ -134,7 +135,7 @@ (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI - (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") ;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN (.visitInsn Opcodes/AASTORE) ;; V )] @@ -173,7 +174,7 @@ :let [_ (doto **writer** (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI - (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") (.visitInsn Opcodes/AASTORE))] :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] (return nil))) @@ -194,19 +195,19 @@ =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 [&&/function-class])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_name" "Ljava/lang/String;" nil ?name) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/name-field "Ljava/lang/String;" nil ?name) (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/datum-field datum-sig nil nil) (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_meta" datum-sig nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/meta-field datum-sig nil nil) (doto (.visitEnd))))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] _ (compile ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)] + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] _ (compile-def-type compile current-class ?body def-type) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_meta" datum-sig)] + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] :let [_ (doto **writer** (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -216,7 +217,7 @@ _ (&&/save-class! def-name (.toByteArray =class)) class-loader &/loader :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] - _ (&a-module/define module-name ?name (-> def-class (.getField "_meta") (.get nil)) =value-type)] + _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] (return nil))) (defn compile-ann [compile *type* ?value-ex ?type-ex] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj new file mode 100644 index 000000000..db73e8bb4 --- /dev/null +++ b/src/lux/compiler/module.clj @@ -0,0 +1,28 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.module + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]) + [lux.analyser.module :as &module])) + +;; [Exports] +(def tag-groups + "(Lux (List (, Text (List Text))))" + (|do [module &/get-current-module] + (return (&/|map (fn [pair] + (|case pair + [name [tags _]] + (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&/get$ &module/$types module))) + )) -- cgit v1.2.3