From 3eabc421e559e7e2f903e06eb6b47a2ee0cd25b9 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 20 Nov 2017 21:46:49 -0400
Subject: - Added parallel compilation. - Added aliasing. - Several bug fixes.
- Some minor refactoring.
---
.../source/luxc/lang/translation/common.jvm.lux | 10 +-
new-luxc/source/luxc/lang/translation/eval.jvm.lux | 15 ++-
.../source/luxc/lang/translation/function.jvm.lux | 2 +
.../source/luxc/lang/translation/imports.jvm.lux | 150 +++++++++++++++++++++
.../source/luxc/lang/translation/reference.jvm.lux | 4 +-
.../source/luxc/lang/translation/statement.jvm.lux | 91 +++++++------
6 files changed, 219 insertions(+), 53 deletions(-)
create mode 100644 new-luxc/source/luxc/lang/translation/imports.jvm.lux
(limited to 'new-luxc/source/luxc/lang/translation')
diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux
index 49e135709..7a16a749a 100644
--- a/new-luxc/source/luxc/lang/translation/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux
@@ -2,7 +2,7 @@
[lux #- function]
(lux (control ["ex" exception #+ exception:])
[io]
- (concurrency ["A" atom])
+ (concurrency [atom #+ Atom atom])
(data ["e" error]
[text]
text/format
@@ -30,7 +30,7 @@
(type: #export Bytecode Blob)
-(type: #export Class-Store (A;Atom (Dict Text Bytecode)))
+(type: #export Class-Store (Atom (Dict Text Bytecode)))
(type: #export Artifacts (Dict File Blob))
@@ -84,16 +84,16 @@
(let [store (|> (get@ #;host compiler)
(:! Host)
(get@ #store))]
- (if (dict;contains? name (|> store A;get io;run))
+ (if (dict;contains? name (|> store atom;read io;run))
(ex;throw Class-Already-Stored name)
- (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))])
+ (#e;Success [compiler (io;run (atom;update (dict;put name byte-code) store))])
))))
(def: #export (load-class name)
(-> Text (Meta (Class Object)))
(;function [compiler]
(let [host (:! Host (get@ #;host compiler))
- store (|> host (get@ #store) A;get io;run)]
+ store (|> host (get@ #store) atom;read io;run)]
(if (dict;contains? name store)
(#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))])
(ex;throw Unknown-Class name)))))
diff --git a/new-luxc/source/luxc/lang/translation/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/eval.jvm.lux
index 11baa3856..6b9ee9743 100644
--- a/new-luxc/source/luxc/lang/translation/eval.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/eval.jvm.lux
@@ -1,7 +1,8 @@
(;module:
lux
(lux (control monad)
- (data text/format)
+ (data [text]
+ text/format)
[macro]
[host #+ do-to])
(luxc ["&" lang]
@@ -56,8 +57,10 @@
(def: #export (eval valueI)
(-> $;Inst (Meta Top))
(do macro;Monad
- [class-name (:: @ map %code (macro;gensym "eval"))
- #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
+ [current-module macro;current-module-name
+ class-name (:: @ map %code (macro;gensym (format current-module "/eval")))
+ #let [store-name (text;replace-all "/" "." class-name)
+ writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS)
(ClassWriter.visit [commonT;bytecode-version
(i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER)
class-name
@@ -70,11 +73,11 @@
""
($t;method (list) #;None (list))
(|>. valueI
- ($i;PUTSTATIC class-name commonT;value-field commonT;$Object)
+ ($i;PUTSTATIC store-name commonT;value-field commonT;$Object)
$i;RETURN)))
bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))]
- _ (commonT;store-class class-name bytecode)
- class (commonT;load-class class-name)]
+ _ (commonT;store-class store-name bytecode)
+ class (commonT;load-class store-name)]
(wrap (|> class
(Class.getField [commonT;value-field])
(Field.get (host;null))))))
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
index d8a2077bc..ab3382952 100644
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux
@@ -291,6 +291,8 @@
[function-class bodyI] (hostL;with-sub-context
(hostL;with-anchor [@begin +1]
(translate bodyS)))
+ this-module macro;current-module-name
+ #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)]
[functionD instanceI] (with-function @begin function-class env arity bodyI)
_ (commonT;store-class function-class
($d;class #$;V1.6 #$;Public $;finalC
diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux
new file mode 100644
index 000000000..c30f61225
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/imports.jvm.lux
@@ -0,0 +1,150 @@
+(;module:
+ lux
+ (lux (control [monad #+ do]
+ ["p" parser]
+ ["ex" exception #+ exception:]
+ pipe)
+ (concurrency [promise #+ Promise]
+ [stm #+ Var STM])
+ (data ["e" error #+ Error]
+ [maybe]
+ [product]
+ [text "text/" Eq]
+ text/format
+ (coll [list "list/" Functor Fold]
+ [dict #+ Dict]))
+ [macro]
+ (macro [code]
+ ["s" syntax])
+ [io #+ IO Process io]
+ [host])
+ (luxc ["&" lang]
+ (lang [";L" module])))
+
+(exception: #export Invalid-Imports)
+(exception: #export Module-Cannot-Import-Itself)
+(exception: #export Circular-Dependency)
+
+(host;import (java.util.concurrent.Future a)
+ (get [] #io a))
+
+(host;import (java.util.concurrent.CompletableFuture a)
+ (new [])
+ (complete [a] boolean)
+ (#static [a] completedFuture [a] (CompletableFuture a)))
+
+(type: Import
+ {#module Text
+ #alias Text})
+
+(def: import (s;Syntax Import) (s;tuple (p;seq s;text s;text)))
+
+(def: compilations
+ (Var (Dict Text (CompletableFuture (Error Compiler))))
+ (stm;var (dict;new text;Hash)))
+
+(def: (promise-to-future promise)
+ (All [a] (-> (Promise a) (Future a)))
+ (let [future (CompletableFuture.new [])]
+ (exec (:: promise;Functor map
+ (function [value] (CompletableFuture.complete [value] future))
+ promise)
+ future)))
+
+(def: from-io
+ (All [a] (-> (IO a) (Process a)))
+ (:: io;Monad map (|>. #e;Success)))
+
+(def: (translate-dependency translate-module dependency compiler)
+ (-> (-> Text Compiler (Process Compiler))
+ (-> Text Compiler (IO (Future (Error Compiler)))))
+ (<| (Future.get [])
+ promise-to-future
+ (do promise;Monad
+ [[new? future] (stm;commit (: (STM [Bool (CompletableFuture (Error Compiler))])
+ (do stm;Monad
+ [current-compilations (stm;read compilations)]
+ (case (dict;get dependency current-compilations)
+ (#;Some ongoing)
+ (wrap [false ongoing])
+
+ #;None
+ (do @
+ [#let [pending (: (CompletableFuture (Error Compiler))
+ (CompletableFuture.new []))]
+ _ (stm;write (dict;put dependency pending current-compilations)
+ compilations)]
+ (wrap [true pending]))))))]
+ (if new?
+ (exec (promise;future (io (CompletableFuture.complete [(io;run (translate-module dependency compiler))]
+ future)))
+ (wrap future))
+ (wrap future)))))
+
+(def: compiled?
+ (-> Module Bool)
+ (|>. (get@ #;module-state)
+ (case>
+ (^or #;Cached #;Compiled)
+ true
+
+ _
+ false)))
+
+(def: (merge-modules current-module from-dependency from-current)
+ (-> Text (List [Text Module]) (List [Text Module]) (List [Text Module]))
+ (|> from-dependency
+ (list;filter (|>. product;right compiled?))
+ (list/fold (function [[dep-name dep-module] total] (&;pl-put dep-name dep-module total))
+ from-current)))
+
+(def: (merge-compilers current-module dependency total)
+ (-> Text Compiler Compiler Compiler)
+ (|> total
+ (update@ #;modules (merge-modules current-module (get@ #;modules dependency)))
+ (set@ #;seed (get@ #;seed dependency))))
+
+(def: #export (translate-imports translate-module annotations)
+ (-> (-> Text Compiler (Process Compiler))
+ Code
+ (Meta (Process Compiler)))
+ (do macro;Monad
+ [_ (moduleL;set-annotations annotations)
+ current-module macro;current-module-name
+ #let [_ (log! (format "{translate-imports} " current-module))]
+ imports (let [imports (|> (macro;get-tuple-ann (ident-for #;imports) annotations)
+ (maybe;default (list)))]
+ (case (s;run imports (p;some import))
+ (#e;Success imports)
+ (wrap imports)
+
+ (#e;Error error)
+ (&;throw Invalid-Imports (%code (code;tuple imports)))))
+ dependencies (monad;map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler)))))
+ (function [[dependency alias]]
+ (do @
+ [_ (&;assert Module-Cannot-Import-Itself current-module
+ (not (text/= current-module dependency)))
+ already-seen? (moduleL;exists? dependency)
+ circular-dependency? (if already-seen?
+ (moduleL;active? dependency)
+ (wrap false))
+ _ (&;assert Circular-Dependency (format "From: " current-module "\n"
+ " To: " dependency)
+ (not circular-dependency?))
+ _ (moduleL;import dependency)
+ _ (if (text/= "" alias)
+ (wrap [])
+ (moduleL;alias alias dependency))
+ compiler macro;get-compiler]
+ (if already-seen?
+ (wrap (io (CompletableFuture.completedFuture [(#e;Success compiler)])))
+ (wrap (translate-dependency translate-module dependency compiler))))))
+ imports)
+ compiler macro;get-compiler]
+ (wrap (do io;Monad
+ [dependencies (monad;seq io;Monad (list/map from-io dependencies))
+ dependencies (|> dependencies
+ (list/map (Future.get []))
+ (monad;seq io;Monad))]
+ (wrap (list/fold (merge-compilers current-module) compiler dependencies))))))
diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
index 9d0cc91e4..bfc838041 100644
--- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
@@ -25,7 +25,9 @@
(def: #export (translate-captured variable)
(-> Variable (Meta $;Inst))
(do macro;Monad
- [function-class hostL;context]
+ [this-module macro;current-module-name
+ function-class hostL;context
+ #let [function-class (format (text;replace-all "/" "." this-module) "." function-class)]]
(wrap (|>. ($i;ALOAD +0)
($i;GETFIELD function-class
(|> variable i.inc (i.* -1) int-to-nat captured)
diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux
index 387181f98..df7e26741 100644
--- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux
@@ -36,48 +36,57 @@
(-> Text Type $;Inst $;Inst Code (Meta Unit))
(do macro;Monad
[current-module macro;current-module-name
- #let [def-ident [current-module def-name]
- normal-name (format (&;normalize-name def-name) (%n (text/hash def-name)))
- bytecode-name (format current-module "/" normal-name)
- class-name (format current-module "." normal-name)
- bytecode ($d;class #$;V1.6
- #$;Public $;finalC
- bytecode-name
- (list) ["java.lang.Object" (list)]
- (list)
- (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) commonT;value-field commonT;$Object)
- ($d;method #$;Public $;staticM "" ($t;method (list) #;None (list))
- (|>. valueI
- ($i;PUTSTATIC bytecode-name commonT;value-field commonT;$Object)
- $i;RETURN))))]
- _ (commonT;store-class class-name bytecode)
- class (commonT;load-class class-name)
- valueV (: (Meta Top)
- (case (do e;Monad
- [field (Class.getField [commonT;value-field] class)]
- (Field.get [#;None] field))
- (#e;Success #;None)
- (&;throw Invalid-Definition-Value (%ident def-ident))
-
- (#e;Success (#;Some valueV))
- (wrap valueV)
-
- (#e;Error error)
- (&;throw Cannot-Evaluate-Definition
- (format "Definition: " (%ident def-ident) "\n"
- "Error:\n"
- error))))
- _ (&module;define def-ident [valueT metaV valueV])
- _ (if (macro;type? metaV)
- (case (macro;declared-tags metaV)
- #;Nil
- (wrap [])
+ #let [def-ident [current-module def-name]]]
+ (case (macro;get-symbol-ann (ident-for #;alias) metaV)
+ (#;Some real-def)
+ (do @
+ [[realT realA realV] (macro;find-def real-def)
+ _ (&module;define def-ident [realT metaV realV])]
+ (wrap []))
- tags
- (&module;declare-tags tags (macro;export? metaV) (:! Type valueV)))
- (wrap []))
- #let [_ (log! (format "DEF " (%ident def-ident)))]]
- (commonT;record-artifact (format bytecode-name ".class") bytecode)))
+ _
+ (do @
+ [#let [normal-name (format (&;normalize-name def-name) (%n (text/hash def-name)))
+ bytecode-name (format current-module "/" normal-name)
+ class-name (format (text;replace-all "/" "." current-module) "." normal-name)
+ bytecode ($d;class #$;V1.6
+ #$;Public $;finalC
+ bytecode-name
+ (list) ["java.lang.Object" (list)]
+ (list)
+ (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) commonT;value-field commonT;$Object)
+ ($d;method #$;Public $;staticM "" ($t;method (list) #;None (list))
+ (|>. valueI
+ ($i;PUTSTATIC bytecode-name commonT;value-field commonT;$Object)
+ $i;RETURN))))]
+ _ (commonT;store-class class-name bytecode)
+ class (commonT;load-class class-name)
+ valueV (: (Meta Top)
+ (case (do e;Monad
+ [field (Class.getField [commonT;value-field] class)]
+ (Field.get [#;None] field))
+ (#e;Success #;None)
+ (&;throw Invalid-Definition-Value (%ident def-ident))
+
+ (#e;Success (#;Some valueV))
+ (wrap valueV)
+
+ (#e;Error error)
+ (&;throw Cannot-Evaluate-Definition
+ (format "Definition: " (%ident def-ident) "\n"
+ "Error:\n"
+ error))))
+ _ (&module;define def-ident [valueT metaV valueV])
+ _ (if (macro;type? metaV)
+ (case (macro;declared-tags metaV)
+ #;Nil
+ (wrap [])
+
+ tags
+ (&module;declare-tags tags (macro;export? metaV) (:! Type valueV)))
+ (wrap []))
+ #let [_ (log! (format "DEF " (%ident def-ident)))]]
+ (commonT;record-artifact (format bytecode-name ".class") bytecode)))))
(def: #export (translate-program program-args programI)
(-> Text $;Inst (Meta Unit))
--
cgit v1.2.3