diff options
author | LuxLang | 2016-11-18 19:18:47 -0400 |
---|---|---|
committer | GitHub | 2016-11-18 19:18:47 -0400 |
commit | 0a11fd59e47438af8a8999eb5f749f4b9f5d4cf0 (patch) | |
tree | 65e8f42732790e6fc2233e35782768792a2bf239 /src | |
parent | 969cfa5f52085de2b92fc47387a9550a07a34452 (diff) | |
parent | 2e9a2faa53f7e9d5cb792aa34ee06f905cffad79 (diff) |
Merge pull request #21 from LuxLang/android_support
Android support
Diffstat (limited to '')
-rw-r--r-- | src/lux/analyser/host.clj | 10 | ||||
-rw-r--r-- | src/lux/analyser/module.clj | 7 | ||||
-rw-r--r-- | src/lux/base.clj | 5 | ||||
-rw-r--r-- | src/lux/compiler.clj | 82 | ||||
-rw-r--r-- | src/lux/compiler/base.clj | 32 | ||||
-rw-r--r-- | src/lux/compiler/cache.clj | 173 | ||||
-rw-r--r-- | src/lux/compiler/cache/ann.clj | 159 | ||||
-rw-r--r-- | src/lux/compiler/cache/type.clj | 164 | ||||
-rw-r--r-- | src/lux/compiler/host.clj | 356 | ||||
-rw-r--r-- | src/lux/compiler/lux.clj | 83 | ||||
-rw-r--r-- | src/lux/compiler/type.clj | 157 | ||||
-rw-r--r-- | src/lux/host.clj | 4 |
12 files changed, 805 insertions, 427 deletions
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 98baad662..180e3ef54 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -676,6 +676,15 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) +(defn analyse-jvm-synchronized [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + =expr (&&/analyse-1 analyse exo-type ?expr) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) + (do-template [<name> <tag>] (defn <name> [analyse exo-type ?values] (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values] @@ -1228,6 +1237,7 @@ "jvm" (case proc + "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) "load-class" (analyse-jvm-load-class analyse exo-type ?values) "try" (analyse-jvm-try analyse exo-type ?values) "throw" (analyse-jvm-throw analyse exo-type ?values) 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 [<name> <type> <tag> <desc>] diff --git a/src/lux/base.clj b/src/lux/base.clj index da5ef48f8..fd8cc2423 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -230,14 +230,9 @@ ;; [Exports] (def ^:const name-field "_name") (def ^:const hash-field "_hash") -(def ^:const type-field "_type") -(def ^:const anns-field "_anns") (def ^:const value-field "_value") (def ^:const compiler-field "_compiler") -(def ^:const imports-field "_imports") -(def ^:const defs-field "_defs") (def ^:const eval-field "_eval") -(def ^:const tags-field "_tags") (def ^:const module-class-name "_") (def ^:const +name-separator+ ";") diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 030df1dd6..298445905 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 @@ -146,7 +148,7 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitCode *writer*)] _ (compile-expression nil expr) @@ -196,8 +198,6 @@ .visitEnd) (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version) .visitEnd) - (-> (.visitField +field-flags+ &/anns-field +datum-sig+ nil nil) - (doto (.visitEnd))) (.visitSource file-name nil))] _ (if (= "lux" name) (|do [_ &&host/compile-Function-class @@ -209,51 +209,43 @@ (&/exhaust% compiler-step)) (&/set$ &/$source (&reader/from name file-content) state)) (&/$Right ?state _) - (&/run-state (|do [==anns (&a-module/get-anns name) + (&/run-state (|do [:let [_ (.visitEnd =class)] + module-anns (&a-module/get-anns name) 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-field "Ljava/lang/String;" nil - (->> defs - (&/|map (fn [_def] - (|let [[?name ?alias] _def] - (str ?name - &&/exported-separator - ?alias)))) - (&/|interpose &&/def-separator) - (&/fold str ""))) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/imports-field "Ljava/lang/String;" nil - (->> imports - (&/|map (fn [import] - (|let [[_module _hash] import] - (str _module &&/field-separator _hash)))) - (&/|interpose &&/entry-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))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (&&/compile-meta compile-expression ==anns) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC module-class-name &/anns-field +datum-sig+)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd =class)] + :let [def-entries (->> defs + (&/|map (fn [_def] + (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def] + (if (= "" ?alias) + (str ?name &&/datum-separator (&&&type/serialize-type ?def-type) &&/datum-separator (&&&ann/serialize-anns ?def-anns)) + (str ?name &&/datum-separator ?alias))))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + import-entries (->> imports + (&/|map (fn [import] + (|let [[_module _hash] import] + (str _module &&/datum-separator _hash)))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + tag-entries (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags + (&/|interpose &&/datum-separator) + (&/fold str "") + (str type &&/datum-separator))))) + (&/|interpose &&/entry-separator) + (&/fold str "")) + module-descriptor (->> (&/|list import-entries + tag-entries + (&&&ann/serialize-anns module-anns) + def-entries) + (&/|interpose &&/section-separator) + (&/fold str ""))] _ (&/flag-compiled-module name) - _ (&&/save-class! &/module-class-name (.toByteArray =class))] + _ (&&/save-class! &/module-class-name (.toByteArray =class)) + _ (&&/write-module-descriptor! name module-descriptor)] (return file-hash)) ?state) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index a369b7436..e57571fef 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -14,8 +14,7 @@ [host :as &host]) (lux.analyser [base :as &a] [module :as &a-module]) - [lux.host.generics :as &host-generics] - (lux.compiler [type :as &&type])) + [lux.host.generics :as &host-generics]) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -43,14 +42,9 @@ (def ^:const arity-field "_arity_") (def ^:const partials-field "_partials_") -(def ^:const exported-separator " ") -(def ^:const def-separator "\t") -(def ^:const tag-separator " ") -(def ^:const type-separator "\t") -(def ^:const tag-group-separator "\n") - -(def ^:const field-separator "\t") -(def ^:const entry-separator "\n") +(def ^:const section-separator (->> 29 char str)) +(def ^:const datum-separator (->> 31 char str)) +(def ^:const entry-separator (->> 30 char str)) ;; [Utils] (defn ^:private write-file [^String file-name ^bytes data] @@ -88,6 +82,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 [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>] (do (defn <wrap-name> [^MethodVisitor writer] (doto writer @@ -106,7 +114,3 @@ wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 ) - -(defn compile-meta [compile anns] - (|let [analysis (&&type/defmeta->analysis anns)] - (compile nil analysis))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index c0b0bc344..788080b04 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) @@ -99,93 +101,84 @@ (&/$Right compiler) (return* compiler nil)))) -(let [->regex (fn [text] (re-pattern (java.util.regex.Pattern/quote text))) - entry-separator-re (->regex &&/entry-separator) - field-separator-re (->regex &&/field-separator) - type-separator-re (->regex &&/type-separator) - tag-separator-re (->regex &&/tag-separator) - def-separator-re (->regex &&/def-separator) - tag-group-separator-re (->regex &&/tag-group-separator)] - (defn load [source-dirs module module-hash compile-module] - "(-> (List Text) Text Int (-> Text (Lux (,))) (Lux Bool))" - (|do [already-loaded? (&a-module/exists? module)] - (if already-loaded? - (return module-hash) - (|let [redo-cache (|do [_ (delete module) - async (compile-module module)] - (assume-async-result @async))] - (if (cached? module) - (|do [loader &/loader - !classes &/classes - :let [module* (&host-generics/->class-name module) - module-path (str @&&/!output-dir "/" module) - class-name (str module* "._") - old-classes @!classes - ^Class module-class (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (&&/load-class! loader class-name)) - _ (install-all-classes-in-module !classes module* module-path)]] - (if (and (= module-hash (get-field &/hash-field module-class)) - (= &/compiler-version (get-field &/compiler-field module-class))) - (let [imports (string/split (get-field &/imports-field module-class) entry-separator-re)] - (|do [loads (&/map% (fn [_import] - (let [[_module _hash] (string/split _import field-separator-re)] - (|do [file-content (&&io/read-file source-dirs (str _module ".lux")) - :let [file-hash (hash file-content) - __hash (Integer/parseInt _hash)] - _ (load source-dirs _module file-hash compile-module) - cached? (&/cached-module? _module) - :let [consistent-cache? (= file-hash __hash)]] - (return (and cached? - consistent-cache?))))) - (if (= [""] imports) - &/$Nil - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (let [defs (string/split (get-field &/defs-field module-class) def-separator-re) - tag-groups (let [all-tags (get-field &/tags-field module-class)] - (if (= "" all-tags) +(defn load [source-dirs module module-hash compile-module] + "(-> (List Text) Text Int (-> Text (Lux (,))) (Lux Bool))" + (|do [already-loaded? (&a-module/exists? module)] + (if already-loaded? + (return module-hash) + (|let [redo-cache (|do [_ (delete module) + async (compile-module module)] + (assume-async-result @async))] + (if (cached? module) + (|do [loader &/loader + !classes &/classes + :let [module* (&host-generics/->class-name module) + module-path (str @&&/!output-dir "/" module) + class-name (str module* "._") + old-classes @!classes + ^Class module-class (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name)) + _ (install-all-classes-in-module !classes module* module-path)]] + (if (and (= module-hash (get-field &/hash-field module-class)) + (= &/compiler-version (get-field &/compiler-field module-class))) + (|do [^String descriptor (&&/read-module-descriptor! module) + :let [sections (.split descriptor &&/section-separator) + [^String imports-section ^String tags-section module-anns-section ^String defs-section] sections + imports (vec (.split imports-section &&/entry-separator))] + loads (&/map% (fn [^String _import] + (let [[_module _hash] (.split _import &&/datum-separator 2)] + (|do [file-content (&&io/read-file source-dirs (str _module ".lux")) + :let [file-hash (hash file-content) + __hash (Integer/parseInt _hash)] + _ (load source-dirs _module file-hash compile-module) + cached? (&/cached-module? _module) + :let [consistent-cache? (= file-hash __hash)]] + (return (and cached? + consistent-cache?))))) + (if (= [""] imports) + &/$Nil + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (|do [:let [tag-groups (if (= "" tags-section) &/$Nil - (-> all-tags - (string/split tag-group-separator-re) - (->> (map (fn [_group] - (let [[_type _tags] (string/split _group type-separator-re)] - (&/T [_type (&/->list (string/split (or _tags "") tag-separator-re))]))))) - &/->list)))] - (|do [_ (&a-module/create-module module module-hash) - :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) - &/$Nil - (&/->list defs))) - _ (&/map% (fn [group] - (|let [[_type _tags] group] - (|do [[was-exported? =type] (&a-module/type-def module _type)] - (&a-module/declare-tags module _tags was-exported? =type)))) - tag-groups)] - (return module-hash))) - redo-cache))) - (do (reset! !classes old-classes) - redo-cache))) - redo-cache)))))) + (-> tags-section + (.split &&/entry-separator) + seq + (->> (map (fn [^String _group] + (let [[_type & _tags] (.split _group &&/datum-separator)] + (&/T [_type (->> _tags seq &/->list)]))))) + &/->list))] + _ (&a-module/create-module module module-hash) + _ (&a-module/set-anns (&&&ann/deserialize-anns module-anns-section) module) + _ (&/flag-cached-module module) + _ (&a-module/set-imports imports) + :let [desc-defs (vec (.split defs-section &&/entry-separator))] + _ (&/map% (fn [^String _def-entry] + (let [parts (.split _def-entry &&/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 desc-defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [[was-exported? =type] (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags was-exported? =type)))) + tag-groups)] + (return module-hash)) + redo-cache)) + (do (reset! !classes old-classes) + redo-cache))) + redo-cache))))) 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 [<name> <signal> <ctor> <parser>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (let [[value* ^String input*] (.split (.substring input 1) stop 2)] + [(<ctor> (<parser> 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 [<name> <deserialize-key>] + (defn <name> [input] + (when-let [[key input*] (<deserialize-key> 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 [<name> <signal> <type> <deserializer>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[elems ^String input*] (deserialize-seq <deserializer> + (.substring input 1))] + [(<type> 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 [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + [<type> (.substring input 1)] + )) + + ^:private deserialize-void "0" &/$VoidT + ^:private deserialize-unit "1" &/$UnitT + ^:private deserialize-type* "T" &type/Type + ) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[left ^String input*] (deserialize-type (.substring input 1))] + (when-let [[right ^String input*] (deserialize-type input*)] + [(<type> left right) input*])) + )) + + ^:private deserialize-sum "+" &/$SumT + ^:private deserialize-prod "*" &/$ProdT + ^:private deserialize-lambda ">" &/$LambdaT + ^:private deserialize-app "%" &/$AppT + ) + +(do-template [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (let [[idx ^String input*] (.split (.substring input 1) stop 2)] + [(<type> (Long/parseLong idx)) input*]))) + + ^:private deserialize-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 [<name> <signal> <type>] + (defn <name> [^String input] + (when (.startsWith input <signal>) + (when-let [[env ^String input*] (deserialize-list (.substring input 1))] + (when-let [[body ^String input*] (deserialize-type input*)] + [(<type> env body) input*])))) + + ^:private deserialize-univq "U" &/$UnivQ + ^:private deserialize-exq "E" &/$ExQ + ) + +(defn ^:private deserialize-host [^String input] + (when (.startsWith input "^") + (let [[name ^String input*] (.split (.substring input 1) stop 2)] + (when-let [[params ^String input*] (deserialize-list input*)] + [(&/$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/host.clj b/src/lux/compiler/host.clj index 6c1646933..d987076c1 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -484,7 +484,7 @@ _ (return nil)) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil) (|do [^MethodVisitor =method &/get-writer :let [_ (doto =method (.visitCode))] @@ -1088,56 +1088,272 @@ (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] - (|let [_ (let [$end (new Label) - ;; $then (new Label) - $else (new Label) - $from (new Label) + (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 + _ (let [$from (new Label) $to (new Label) - $handler (new Label)] + $handler (new Label) + + $good-start (new Label) + $short-enough (new Label) + $bad-digit (new Label) + $out-of-bounds (new Label)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + ;; Remove the + at the beginning... (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitLdcInsn (int 0)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") (.visitLdcInsn "+") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFNE $good-start) + ;; Doesn't start with + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Starts with + + (.visitLabel $good-start) (.visitVarInsn Opcodes/ALOAD 0) (.visitLdcInsn (int 1)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") - (.visitLabel $to) - ;; (.visitJumpInsn Opcodes/GOTO $then) - ;; (.visitLabel $then) - (&&/wrap-long) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... + ;; Begin parsing processs + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 18)) + (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) + ;; Too long + ;; Get prefix... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... + ;; Get last digit... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") + (.visitLdcInsn (int 10)) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") + ;; Test last digit... + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFLT $bad-digit) + ;; Good digit... + ;; Stack: prefix::L, prefix::L, last-digit::I + (.visitInsn Opcodes/I2L) + ;; Build the result... + swap2 + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L + (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L + swap2 ;; Stack: result::L, result::L, prefix::L + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $out-of-bounds) + ;; Within bounds + ;; Stack: result::L + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Out of bounds + (.visitLabel $out-of-bounds) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Bad digit... + (.visitLabel $bad-digit) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; 18 chars or less + (.visitLabel $short-enough) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + &&/wrap-long (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) - (.visitJumpInsn Opcodes/GOTO $end) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) (.visitLabel $handler) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"])) - (.visitInsn Opcodes/POP) (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) - (.visitJumpInsn Opcodes/GOTO $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 + _ (let [$else (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitLdcInsn "+") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $else) + ;; then + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + ;; else (.visitLabel $else) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array [])) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitLabel $end) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + ;; Set up parts of the number string... + ;; First digits + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/LUSHR) + (.visitLdcInsn (long 5)) + (.visitInsn Opcodes/LDIV) ;; quot + ;; Last digit + (.visitInsn Opcodes/DUP2) + (.visitVarInsn Opcodes/LLOAD 0) + swap2 + (.visitInsn Opcodes/LSUB) + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) ;; quot, rem + ;; Conversion to string... + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* + (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* + (.visitInsn Opcodes/POP) ;; rem*, quot + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* + (.visitInsn Opcodes/SWAP) ;; quot*, rem* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd))) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 + _ (let [$else (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $else) + ;; then + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + ;; else + (.visitLabel $else) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitLdcInsn (int 32)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) (.visitCode) (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ "toUnsignedString" "(J)Ljava/lang/String;") - (.visitLdcInsn "+") - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitInsn Opcodes/LCMP) + (.visitInsn Opcodes/IRETURN) (.visitMaxs 0 0) - (.visitEnd))] + (.visitEnd)) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 + _ (let [$case-1 (new Label) + $0 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $case-1) + ;; Test #2 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LDIV) + (.visitInsn Opcodes/LRETURN) + ;; Case #1 + (.visitLabel $case-1) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $0) + ;; 1 + (.visitLdcInsn (long 1)) + (.visitInsn Opcodes/LRETURN) + ;; 0 + (.visitLabel $0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 + _ (let [$case-1 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitInsn Opcodes/IAND) + (.visitJumpInsn Opcodes/IFGT $case-1) + ;; Test #2 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitInsn Opcodes/LRETURN) + ;; Case #1 + (.visitLabel $case-1) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LREM) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)))] nil))) (defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] @@ -1608,6 +1824,21 @@ (.visitLabel $end))]] (return nil))) +(defn compile-jvm-synchronized [compile ?values special-args] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?monitor) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/MONITORENTER))] + _ (compile ?expr) + :let [_ (doto *writer* + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/MONITOREXIT))]] + (return nil))) + (do-template [<name> <op>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Cons ?monitor (&/$Nil)) ?values @@ -1914,41 +2145,41 @@ ^:private compile-frac-scale Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long ) -(do-template [<name> <wrapper-class> <value-method> <value-method-sig> <wrap> <comp-method> <comp-sig>] +(do-template [<name> <comp-method>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] ^MethodVisitor *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <comp-method> <comp-sig>) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <comp-method> "(JJ)J") (&&/wrap-long))]] (return nil))) - ^:private compile-nat-div "java.lang.Long" "longValue" "()J" &&/wrap-long "divideUnsigned" "(JJ)J" - ^:private compile-nat-rem "java.lang.Long" "longValue" "()J" &&/wrap-long "remainderUnsigned" "(JJ)J" + ^:private compile-nat-div "div_nat" + ^:private compile-nat-rem "rem_nat" ) -(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig> <comp-method> <comp-sig>] +(do-template [<name> <cmp-output>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name <wrapper-class>)] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] ^MethodVisitor *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))] + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) $then (new Label) $end (new Label) _ (doto *writer* @@ -1962,13 +2193,37 @@ (.visitLabel $end))]] (return nil))) - ^:private compile-nat-eq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I" - ^:private compile-nat-lt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I" - - ^:private compile-frac-eq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I" - ^:private compile-frac-lt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I" + ^:private compile-nat-eq 0 + + ^:private compile-frac-eq 0 + ^:private compile-frac-lt -1 ) +(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + (defn ^:private compile-nat-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J")) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil)))) + (do-template [<name> <instr> <wrapper>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Nil) ?values] @@ -2131,6 +2386,7 @@ "jvm" (case proc-name + "synchronized" (compile-jvm-synchronized compile ?values special-args) "load-class" (compile-jvm-load-class compile ?values special-args) "instanceof" (compile-jvm-instanceof compile ?values special-args) "try" (compile-jvm-try compile ?values special-args) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index f44375e97..9d5837fe2 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -21,8 +21,7 @@ [module :as &a-module] [meta :as &a-meta]) (lux.compiler [base :as &&] - [lambda :as &&lambda] - [type :as &&type])) + [lambda :as &&lambda])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -236,18 +235,6 @@ _ (.visitLabel *writer* $end)]] (return nil))) -(defn ^:private compile-def-type [compile ?body] - (|do [:let [?def-type (|case ?body - [[?def-type ?def-cursor] (&o/$ann ?def-value ?type-expr)] - (&o/optimize ?type-expr) - - [[?def-type ?def-cursor] ?def-value] - (if (&type/type= &type/Type ?def-type) - (&/T [(&/T [?def-type ?def-cursor]) - (&o/$tuple (&/|list))]) - (&&type/type->analysis ?def-type)))]] - (compile nil ?def-type))) - (defn ^:private de-ann [optim] (|case optim [_ (&o/$ann value-expr _)] @@ -266,7 +253,7 @@ (if (= 1 (&/|length ?meta)) (|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 (-> def-class (.getField &/type-field) (.get nil)) + def-type (&a-module/def-type r-module r-name) def-meta ?meta def-value (-> def-class (.getField &/value-field) (.get nil))] _ (&/without-repl-closure @@ -284,7 +271,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) @@ -294,43 +280,31 @@ 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))] instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()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 [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") + _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] :let [_ (doto **writer** (.visitInsn Opcodes/RETURN) (.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 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]))) + def-type (&a/expr-type* ?body) + 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 @@ -367,7 +341,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) @@ -377,42 +350,30 @@ 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_PUBLIC "<clinit>" "()V" nil nil) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()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 [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (.visitTypeInsn **writer** Opcodes/CHECKCAST "java/lang/Object") + _ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] :let [_ (doto **writer** (.visitInsn Opcodes/RETURN) (.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 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]))) + def-type (&a/expr-type* ?body) + 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 diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj deleted file mode 100644 index b2b0f9cb9..000000000 --- a/src/lux/compiler/type.clj +++ /dev/null @@ -1,157 +0,0 @@ -;; 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.type - (:require [clojure.template :refer [do-template]] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type] - [optimizer :as &o]) - [lux.analyser.base :as &a])) - -;; [Utils] -(defn ^:private variant$ [tag body] - "(-> clojure.lang.Var Analysis Analysis)" - (let [tag-meta (meta tag)] - (&a/|meta &/$VoidT &/empty-cursor - (&o/$variant (::&/idx tag-meta) (::&/is-last? tag-meta) body)))) - -(defn ^:private tuple$ [members] - "(-> (List Analysis) Analysis)" - (&a/|meta &/$VoidT &/empty-cursor - (&o/$tuple members))) - -(do-template [<name> <tag> <doc>] - (defn <name> [value] - <doc> - (&a/|meta &/$VoidT &/empty-cursor - (<tag> value))) - - ^:private bool$ &o/$bool "(-> Bool Analysis)" - ^:private nat$ &o/$nat "(-> Nat Analysis)" - ^:private int$ &o/$int "(-> Int Analysis)" - ^:private frac$ &o/$frac "(-> Nat Analysis)" - ^:private real$ &o/$real "(-> Real Analysis)" - ^:private char$ &o/$char "(-> Char Analysis)" - ^:private text$ &o/$text "(-> Text Analysis)" - ) - -(defn ^:private ident$ [value] - "(-> Ident Analysis)" - (|let [[p n] value] - (tuple$ (&/|list (text$ p) (text$ n))))) - -(def ^:private $Nil - "Analysis" - (variant$ #'&/$Nil (tuple$ &/$Nil))) - -(defn ^:private Cons$ [head tail] - "(-> Analysis Analysis Analysis)" - (variant$ #'&/$Cons (tuple$ (&/|list head tail)))) - -(defn ^:private List$ [elems] - "(-> (List Analysis) Analysis)" - (&/fold (fn [tail head] - (Cons$ head tail)) - $Nil - (&/|reverse elems))) - -;; [Exports] -(defn type->analysis [type] - "(-> Type Analysis)" - (|case type - (&/$HostT class params) - (variant$ #'&/$HostT (tuple$ (&/|list (text$ class) - (List$ (&/|map type->analysis params))))) - - (&/$VoidT) - (variant$ #'&/$VoidT (tuple$ (&/|list))) - - (&/$UnitT) - (variant$ #'&/$UnitT (tuple$ (&/|list))) - - (&/$ProdT left right) - (variant$ #'&/$ProdT (tuple$ (&/|list (type->analysis left) (type->analysis right)))) - - (&/$SumT left right) - (variant$ #'&/$SumT (tuple$ (&/|list (type->analysis left) (type->analysis right)))) - - (&/$LambdaT input output) - (variant$ #'&/$LambdaT (tuple$ (&/|list (type->analysis input) (type->analysis output)))) - - (&/$UnivQ env body) - (variant$ #'&/$UnivQ - (tuple$ (&/|list (List$ (&/|map type->analysis env)) - (type->analysis body)))) - - (&/$ExQ env body) - (variant$ #'&/$ExQ - (tuple$ (&/|list (List$ (&/|map type->analysis env)) - (type->analysis body)))) - - (&/$BoundT idx) - (variant$ #'&/$BoundT (int$ idx)) - - (&/$AppT fun arg) - (variant$ #'&/$AppT (tuple$ (&/|list (type->analysis fun) (type->analysis arg)))) - - (&/$NamedT [module name] type*) - (variant$ #'&/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name))) - (type->analysis type*)))) - - _ - (assert false (prn 'type->analysis (&type/show-type type))) - )) - -(defn ^:private defmetavalue->analysis [dmv] - "(-> Ann-Value Analysis)" - (|case dmv - (&/$BoolM value) - (variant$ #'&/$BoolM (bool$ value)) - - (&/$NatM value) - (variant$ #'&/$NatM (nat$ value)) - - (&/$IntM value) - (variant$ #'&/$IntM (int$ value)) - - (&/$FracM value) - (variant$ #'&/$FracM (frac$ value)) - - (&/$RealM value) - (variant$ #'&/$RealM (real$ value)) - - (&/$CharM value) - (variant$ #'&/$CharM (char$ value)) - - (&/$TextM value) - (variant$ #'&/$TextM (text$ value)) - - (&/$IdentM value) - (variant$ #'&/$IdentM (ident$ value)) - - (&/$ListM xs) - (variant$ #'&/$ListM (List$ (&/|map defmetavalue->analysis xs))) - - (&/$DictM kvs) - (variant$ #'&/$DictM - (List$ (&/|map (fn [kv] - (|let [[k v] kv] - (tuple$ (&/|list (text$ k) - (defmetavalue->analysis v))))) - kvs))) - - _ - (assert false (prn 'defmetavalue->analysis (&/adt->text dmv))) - )) - -(defn defmeta->analysis [xs] - "(-> Anns Analysis)" - (List$ (&/|map (fn [kv] - (|let [[k v] kv] - (tuple$ (&/|list (ident$ k) - (defmetavalue->analysis v))))) - xs))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 26176b840..3c8cef536 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -104,7 +104,7 @@ (do-template [<name> <static?> <method-type>] (defn <name> [class-loader target method-name args] (|let [target-class (Class/forName target true class-loader)] - (if-let [[^Method method ^Class declarer] (first (for [^Method =method (.getMethods target-class) + (if-let [[^Method method ^Class declarer] (first (for [^Method =method (.getDeclaredMethods target-class) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method))) (let [param-types (&/->list (seq (.getParameterTypes =method)))] @@ -394,7 +394,7 @@ (defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] (|do [module &/get-module-name :let [[?name ?params] class-decl - dummy-name (str ?name "__DUMMY__") + dummy-name ?name;; (str ?name "__DUMMY__") dummy-full-name (str module "/" dummy-name) real-name (str (&host-generics/->class-name module) "." ?name) store-name (str (&host-generics/->class-name module) "." dummy-name) |