Parallel compilation for the new compiler(s).

5 files changed, 270 insertions, 120 deletions

diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 76939bb08..f562e762a 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -7,7 +7,8 @@
    [control
     ["." try (#+ Try)]
     [concurrency
-     ["." promise (#+ Promise) ("#@." monad)]]]
+     ["." promise (#+ Promise Resolver) ("#@." monad)]
+     ["." stm (#+ Var STM)]]]
    [data
     ["." binary (#+ Binary)]
     ["." bit]
@@ -15,10 +16,10 @@
     ["." text
      ["%" format (#+ format)]]
     [collection
-     [dictionary (#+ Dictionary)]
-     ["." row ("#@." fold)]
+     ["." dictionary (#+ Dictionary)]
+     ["." row (#+ Row) ("#@." fold)]
      ["." set]
-     ["." list ("#@." monoid)]]
+     ["." list ("#@." monoid functor fold)]]
     [format
      ["_" binary (#+ Writer)]]]
    [world
@@ -51,7 +52,8 @@
       ["ioW" archive]]]]]
   [program
    [compositor
-    ["." cli (#+ Configuration)]]])
+    ["." cli (#+ Configuration)]
+    ["." static (#+ Static)]]])
 
 (type: #export (Platform anchor expression directive)
   {#&file-system (file.System Promise)
@@ -79,23 +81,23 @@
     (_.and descriptor.writer
            (document.writer $.writer)))
 
-  (def: (cache-module platform host target-dir module-id extension [[descriptor document] output])
+  (def: (cache-module static platform module-id [[descriptor document] output])
     (All [<type-vars>]
-      (-> <Platform> Host Path archive.ID Text [[Descriptor (Document Any)] Output]
+      (-> Static <Platform> archive.ID [[Descriptor (Document Any)] Output]
           (Promise (Try Any))))
     (let [system (get@ #&file-system platform)
           write-artifact! (: (-> [Text Binary] (Action Any))
                              (function (_ [name content])
-                               (ioW.write system host target-dir module-id name extension content)))]
+                               (ioW.write system (get@ #static.host static) (get@ #static.target static) module-id name (get@ #static.artifact-extension static) content)))]
       (do ..monad
-        [_ (ioW.prepare system host target-dir module-id)
+        [_ (ioW.prepare system (get@ #static.host static) (get@ #static.target static) module-id)
          _ (|> output
                row.to-list
                (monad.map ..monad write-artifact!)
                (: (Action (List Any))))
          document (:: promise.monad wrap
                       (document.check $.key document))]
-        (ioW.cache system host target-dir module-id
+        (ioW.cache system (get@ #static.host static) (get@ #static.target static) module-id
                    (_.run ..writer [descriptor document])))))
 
   ## TODO: Inline ASAP
@@ -173,11 +175,9 @@
         (///phase.run' state)
         (:: try.monad map product.left)))
 
-  (def: #export (initialize extension target host module expander host-analysis platform generation-bundle host-directive-bundle program extender)
+  (def: #export (initialize static module expander host-analysis platform generation-bundle host-directive-bundle program extender)
     (All [<type-vars>]
-      (-> Text
-          Path
-          Host
+      (-> Static
           Module
           Expander
           ///analysis.Bundle
@@ -188,7 +188,7 @@
           Extender
           (Promise (Try [<State+> Archive]))))
     (do (try.with promise.monad)
-      [#let [state (//init.state host
+      [#let [state (//init.state (get@ #static.host static)
                                  module
                                  expander
                                  host-analysis
@@ -198,8 +198,8 @@
                                  host-directive-bundle
                                  program
                                  extender)]
-       _ (ioW.enable (get@ #&file-system platform) host target)
-       [archive analysis-state bundles] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target)
+       _ (ioW.enable (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static))
+       [archive analysis-state bundles] (ioW.thaw (get@ #static.artifact-extension static) (get@ #host platform) (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static))
        state (promise@wrap (initialize-state extender bundles analysis-state state))]
       (if (archive.archived? archive archive.runtime-module)
         (wrap [state archive])
@@ -207,7 +207,7 @@
           [[state [archive payload]] (|> (..process-runtime archive platform)
                                          (///phase.run' state)
                                          promise@wrap)
-           _ (..cache-module platform host target 0 extension payload)]
+           _ (..cache-module static platform 0 payload)]
           (wrap [state archive])))))
 
   (def: module-compilation-log
@@ -232,83 +232,212 @@
            #///generation.log]
           row.empty))
 
-  (def: #export (compile target partial-host-extension expander platform host configuration archive extension state)
-    (All [<type-vars>]
-      (-> Text Text Expander <Platform> Host Configuration Archive Text <State+> (Promise (Try [Archive <State+>]))))
-    (let [source-module (get@ #cli.module configuration)
-          compiler (:share [<type-vars>]
-                           {<State+>
-                            state}
-                           {(///.Compiler <State+> .Module Any)
-                            ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))})]
-      (loop [module source-module
-             [archive state] [archive state]]
-        (if (archive.archived? archive module)
-          (promise@wrap (#try.Success [archive state]))
-          (let [import! (:share [<type-vars>]
-                                {<Platform>
-                                 platform}
-                                {(-> Module [Archive <State+>]
-                                     (Action [Archive <State+>]))
-                                 recur})]
-            (do (try.with promise.monad)
-              [[module-id archive] (promise@wrap (archive.reserve module archive))
-               input (context.read (get@ #&file-system platform)
-                                   (get@ #cli.sources configuration)
-                                   partial-host-extension
-                                   module)]
-              (loop [archive archive
-                     state state
-                     compilation (compiler (:coerce ///.Input input))
-                     all-dependencies (: (List Module)
-                                         (list))]
-                (do @
-                  [#let [new-dependencies (get@ #///.dependencies compilation)
-                         all-dependencies (list@compose new-dependencies all-dependencies)]
-                   [archive state] (:share [<type-vars>]
-                                           {<Platform>
-                                            platform}
-                                           {(Action [Archive <State+>])
-                                            (monad.fold ..monad import! [archive state] new-dependencies)})
-                   #let [continue! (:share [<type-vars>]
-                                           {<Platform>
-                                            platform}
-                                           {(-> Archive <State+> (///.Compilation <State+> .Module Any) (List Module)
-                                                (Action [Archive <State+>]))
-                                            recur})]]
-                  (case ((get@ #///.process compilation)
-                         (case new-dependencies
-                           #.Nil
-                           state
+  (with-expansions [<Context> (as-is [Archive <State+>])
+                    <Result> (as-is (Try <Context>))
+                    <Return> (as-is (Promise <Result>))
+                    <Signal> (as-is (Resolver <Result>))
+                    <Pending> (as-is [<Return> <Signal>])
+                    <Importer> (as-is (-> Module <Return>))
+                    <Compiler> (as-is (-> <Importer> archive.ID <Context> Module <Return>))]
+    (def: (parallel initial)
+      (All [<type-vars>]
+        (-> <Context>
+            (-> <Compiler> <Importer>)))
+      (let [current (:share [<type-vars>]
+                            {<Context>
+                             initial}
+                            {(Var <Context>)
+                             (stm.var initial)})
+            pending (:share [<type-vars>]
+                            {<Context>
+                             initial}
+                            {(Var (Dictionary Module <Pending>))
+                             (stm.var (dictionary.new text.hash))})]
+        (function (_ compile)
+          (function (import! module)
+            (do promise.monad
+              [[return signal] (:share [<type-vars>]
+                                       {<Context>
+                                        initial}
+                                       {(Promise [<Return> (Maybe [<Context>
+                                                                   archive.ID
+                                                                   <Signal>])])
+                                        (stm.commit
+                                         (do stm.monad
+                                           [[archive state] (stm.read current)]
+                                           (if (archive.archived? archive module)
+                                             (wrap [(promise@wrap (#try.Success [archive state]))
+                                                    #.None])
+                                             (do @
+                                               [@pending (stm.read pending)]
+                                               (case (dictionary.get module @pending)
+                                                 (#.Some [return signal])
+                                                 (wrap [return
+                                                        #.None])
+                                                 
+                                                 #.None
+                                                 (case (archive.reserve module archive)
+                                                   (#try.Success [module-id archive])
+                                                   (do @
+                                                     [_ (stm.write [archive state] current)
+                                                      #let [[return signal] (:share [<type-vars>]
+                                                                                    {<Context>
+                                                                                     initial}
+                                                                                    {<Pending>
+                                                                                     (promise.promise [])})]
+                                                      _ (stm.update (dictionary.put module [return signal]) pending)]
+                                                     (wrap [return
+                                                            (#.Some [[archive state]
+                                                                     module-id
+                                                                     signal])]))
+                                                   
+                                                   (#try.Failure error)
+                                                   (wrap [(promise@wrap (#try.Failure error))
+                                                          #.None])))))))})
+               _ (case signal
+                   #.None
+                   (wrap [])
+                   
+                   (#.Some [context module-id resolver])
+                   (do @
+                     [result (compile import! module-id context module)
+                      result (case result
+                               (#try.Failure error)
+                               (wrap result)
+
+                               (#try.Success [resulting-archive resulting-state])
+                               (stm.commit (do stm.monad
+                                             [[_ [merged-archive _]] (stm.update (function (_ [archive state])
+                                                                                   [(archive.merge resulting-archive archive)
+                                                                                    state])
+                                                                                 current)]
+                                             (wrap (#try.Success [merged-archive resulting-state])))))
+                      _ (promise.future (resolver result))]
+                     (wrap [])))]
+              return)))))
+
+    ## TODO: Find a better way, as this only works for the Lux compiler.
+    (def: (updated-state archive state)
+      (All [<type-vars>]
+        (-> Archive <State+> (Try <State+>)))
+      (do try.monad
+        [modules (monad.map @ (function (_ module)
+                                (do @
+                                  [[descriptor document] (archive.find module archive)
+                                   lux-module (document.read $.key document)]
+                                  (wrap [module lux-module])))
+                            (archive.archived archive))
+         #let [additions (|> modules
+                             (list@map product.left)
+                             (set.from-list text.hash))]]
+        (wrap (update@ [#extension.state
+                        #///directive.analysis
+                        #///directive.state
+                        #extension.state]
+                       (function (_ analysis-state)
+                         (|> analysis-state
+                             (:coerce .Lux)
+                             (update@ #.modules (function (_ current)
+                                                  (list@compose (list.filter (|>> product.left
+                                                                                  (set.member? additions)
+                                                                                  not)
+                                                                             current)
+                                                                modules)))
+                             :assume))
+                       state))))
+
+    (def: (set-current-module module state)
+      (All [<type-vars>]
+        (-> Module <State+> <State+>))
+      (|> (///directive.set-current-module module)
+          (///phase.run' state)
+          try.assume
+          product.left))
+
+    (def: #export (compile static expander platform configuration context)
+      (All [<type-vars>]
+        (-> Static Expander <Platform> Configuration <Context> <Return>))
+      (let [base-compiler (:share [<type-vars>]
+                                  {<Context>
+                                   context}
+                                  {(///.Compiler <State+> .Module Any)
+                                   ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))})
+            parallel-compiler (..parallel
+                               context
+                               (function (_ import! module-id [archive state] module)
+                                 (do (try.with promise.monad)
+                                   [#let [state (..set-current-module module state)]
+                                    input (context.read (get@ #&file-system platform)
+                                                        (get@ #cli.sources configuration)
+                                                        (get@ #static.host-module-extension static)
+                                                        module)]
+                                   (loop [[archive state] [archive state]
+                                          compilation (base-compiler (:coerce ///.Input input))
+                                          all-dependencies (: (List Module)
+                                                              (list))]
+                                     (do (try.with promise.monad)
+                                       [#let [new-dependencies (get@ #///.dependencies compilation)
+                                              all-dependencies (list@compose new-dependencies all-dependencies)
+                                              continue! (:share [<type-vars>]
+                                                                {<Platform>
+                                                                 platform}
+                                                                {(-> <Context> (///.Compilation <State+> .Module Any) (List Module)
+                                                                     (Action [Archive <State+>]))
+                                                                 recur})]
+                                        archive,document+ (|> new-dependencies
+                                                              (list@map import!)
+                                                              (monad.seq ..monad))
+                                        #let [archive (case archive,document+
+                                                        #.Nil
+                                                        archive
+
+                                                        archive,document+
+                                                        (|> archive,document+
+                                                            (list@map product.left)
+                                                            (list@fold archive.merge archive)))
+                                              state (case archive,document+
+                                                      #.Nil
+                                                      state
 
-                           _
-                           ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
-                           ## TODO: The context shouldn't need to be re-set either.
-                           (|> (///directive.set-current-module module)
-                               (///phase.run' state)
-                               try.assume
-                               product.left))
-                         archive)
-                    (#try.Success [state more|done])
-                    (case more|done
-                      (#.Left more)
-                      (continue! archive state more all-dependencies)
+                                                      archive,document+
+                                                      (try.assume
+                                                       (:share [|state|]
+                                                               {|state|
+                                                                state}
+                                                               {(Try |state|)
+                                                                (..updated-state archive state)})))]]
+                                       (case ((get@ #///.process compilation)
+                                              ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
+                                              ## TODO: The context shouldn't need to be re-set either.
+                                              (|> (///directive.set-current-module module)
+                                                  (///phase.run' state)
+                                                  try.assume
+                                                  product.left)
+                                              archive)
+                                         (#try.Success [state more|done])
+                                         (case more|done
+                                           (#.Left more)
+                                           (continue! [archive state] more all-dependencies)
 
-                      (#.Right [[descriptor document] output])
-                      (do (try.with promise.monad)
-                        [#let [_ (log! (..module-compilation-log state))
-                               descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
-                         _ (..cache-module platform host target module-id extension [[descriptor document] output])]
-                        (case (archive.add module [descriptor document] archive)
-                          (#try.Success archive)
-                          (wrap [archive
-                                 (..with-reset-log state)])
-                          
-                          (#try.Failure error)
-                          (promise@wrap (#try.Failure error)))))
+                                           (#.Right [[descriptor document] output])
+                                           (do (try.with promise.monad)
+                                             [#let [_ (log! (..module-compilation-log state))
+                                                    descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
+                                              _ (..cache-module static platform module-id [[descriptor document] output])]
+                                             (case (archive.add module [descriptor document] archive)
+                                               (#try.Success archive)
+                                               (wrap [archive
+                                                      (..with-reset-log state)])
+                                               
+                                               (#try.Failure error)
+                                               (promise@wrap (#try.Failure error)))))
 
-                    (#try.Failure error)
-                    (do (try.with promise.monad)
-                      [_ (ioW.freeze (get@ #&file-system platform) host target archive)]
-                      (promise@wrap (#try.Failure error))))))))))))
-  )
+                                         (#try.Failure error)
+                                         (do (try.with promise.monad)
+                                           [_ (ioW.freeze (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static) archive)]
+                                           (promise@wrap (#try.Failure error))))
+                                       ))
+                                   )))]
+        (parallel-compiler (get@ #cli.module configuration))
+        ))
+    ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux
index 66efb1dde..2e42e2c45 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux
@@ -1,16 +1,18 @@
 (.module:
-  [lux #*
+  [lux (#- Module)
    [abstract
     [monad (#+ do)]]
    [control
     ["." try]]
    [data
-    [text
-     ["%" format (#+ format)]]]]
+    ["." text
+     ["%" format (#+ format)]]]
+   ["." macro]]
   [// (#+ Operation)
    [macro (#+ Expander)]
    [//
     [phase
+     [".P" extension]
      [".P" synthesis]
      [".P" analysis
       ["." type]]
@@ -20,11 +22,20 @@
       [///
        ["." phase]
        [meta
-        [archive (#+ Archive)]]]]]]])
+        [archive (#+ Archive)
+         [descriptor (#+ Module)]]]]]]]])
 
 (type: #export Eval
   (-> Archive Nat Type Code (Operation Any)))
 
+(def: #export (id prefix module count)
+  (-> Text Module Nat Text)
+  (format prefix
+          "$"
+          (text.replace-all "/" "$" module)
+          "$"
+          (%.nat count)))
+
 (def: #export (evaluator expander synthesis-state generation-state generate)
   (All [anchor expression artifact]
     (-> Expander
@@ -36,10 +47,13 @@
     (function (eval archive count type exprC)
       (do phase.monad
         [exprA (type.with-type type
-                 (analyze archive exprC))]
+                 (analyze archive exprC))
+         module (extensionP.lift
+                 macro.current-module-name)]
         (phase.lift (do try.monad
                       [exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis-state))]
                       (phase.run generation-state
                                  (do phase.monad
                                    [exprO (generate archive exprS)]
-                                   (generation.evaluate! (format "eval" (%.nat count)) exprO)))))))))
+                                   (generation.evaluate! (..id "analysis" module count)
+                                                         exprO)))))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
index 41dcdd990..7196d13f1 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
@@ -177,6 +177,11 @@
     (-> Module (Operation anchor expression directive Any)))
   (extension.update (set@ #module module)))
 
+(def: #export module
+  (All [anchor expression directive]
+    (Operation anchor expression directive Module))
+  (extension.read (get@ #module)))
+
 (template [<name> <inputT>]
   [(def: #export (<name> label code)
      (All [anchor expression directive]
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
index 24d059031..96eb95f41 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
@@ -11,7 +11,7 @@
    [data
     ["." product]
     ["." maybe]
-    [text
+    ["." text
      ["%" format (#+ format)]]
     [collection
      ["." dictionary]]]
@@ -65,9 +65,11 @@
         (Operation anchor expression directive [Type expression Any])))
   (/////directive.lift-generation
    (do phase.monad
-     [codeG (generate archive codeS)
+     [module /////generation.module
       id /////generation.next
-      codeV (/////generation.evaluate! (format "evaluate" (%.nat id)) codeG)]
+      codeG (generate archive codeS)
+      codeV (/////generation.evaluate! (/////analysis/evaluation.id "directive" module id)
+                                       codeG)]
      (wrap [code//type codeG codeV]))))
 
 (def: #export (evaluate! archive type codeC)
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
index 37b47777d..3756e257a 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive.lux
@@ -173,22 +173,22 @@
                      [module id]))))
 
   (def: #export (merge additions archive)
-    (-> Archive Archive (Try Archive))
-    (|> additions
-        :representation
-        (get@ #resolver)
-        dictionary.entries
-        (monad.fold try.monad
-                    (function (_ [module' [id descriptor+document']] archive')
-                      (case descriptor+document'
-                        (#.Some descriptor+document')
-                        (if (archived? archive' module')
-                          (#try.Success archive')
-                          (..add module' descriptor+document' archive'))
-                        
-                        #.None
-                        (#try.Success archive')))
-                    archive)))
+    (-> Archive Archive Archive)
+    (let [[+next +resolver] (:representation additions)]
+      (|> archive
+          :representation
+          (update@ #next (n.max +next))
+          (update@ #resolver (function (_ resolver)
+                               (list@fold (function (_ [module [id entry]] resolver)
+                                            (case entry
+                                              (#.Some _)
+                                              (dictionary.put module [id entry] resolver)
+                                              
+                                              #.None
+                                              resolver))
+                                          resolver
+                                          (dictionary.entries +resolver))))
+          :abstraction)))
 
   (type: Reservation [Module ID])
   (type: Frozen [Version ID (List Reservation)])