diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation')
6 files changed, 219 insertions, 53 deletions
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<Meta> - [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 @@ "<clinit>" ($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>] + text/format + (coll [list "list/" Functor<List> Fold<List>] + [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<Text>))) + +(def: (promise-to-future promise) + (All [a] (-> (Promise a) (Future a))) + (let [future (CompletableFuture.new [])] + (exec (:: promise;Functor<Promise> map + (function [value] (CompletableFuture.complete [value] future)) + promise) + future))) + +(def: from-io + (All [a] (-> (IO a) (Process a))) + (:: io;Monad<IO> 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<Promise> + [[new? future] (stm;commit (: (STM [Bool (CompletableFuture (Error Compiler))]) + (do stm;Monad<STM> + [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<Meta> + [_ (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<Process> + [dependencies (monad;seq io;Monad<Process> (list/map from-io dependencies)) + dependencies (|> dependencies + (list/map (Future.get [])) + (monad;seq io;Monad<Process>))] + (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<Meta> - [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<Meta> [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 "<clinit>" ($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<Error> - [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 "<clinit>" ($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<Error> + [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)) |