Merge pull request #18 from LuxLang/parallel_compilation

Parallel compilation

7 files changed, 204 insertions, 59 deletions

diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 208890d78..8a8f22586 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -4,7 +4,8 @@
 ;;  You can obtain one at http://mozilla.org/MPL/2.0/.
 
 (ns lux.analyser.lux
-  (:require (clojure [template :refer [do-template]])
+  (:require (clojure [template :refer [do-template]]
+                     [set :as set])
             clojure.core.match
             clojure.core.match.array
             (lux [base :as & :refer [|do return return* fail fail* |let |list |case]]
@@ -32,7 +33,7 @@
     0))
 
 ;; TODO: This technique won't work if the body of the type contains
-;; nested quantifications that are cannot be directly counted.
+;; nested quantifications that cannot be directly counted.
 (defn ^:private next-bound-type [type]
   "(-> Type Type)"
   (&/$BoundT (->> (count-univq type) (* 2) (+ 1))))
@@ -521,8 +522,6 @@
             (return (&&/|meta exo-type* _cursor
                               (&&/$lambda =scope =captured =body))))
 
-          
-          
           _
           (fail "")))
       (fn [err]
@@ -575,6 +574,63 @@
         (return &/$Nil))
       )))
 
+(defn ^:private merge-hosts
+  "(-> Host Host Host)"
+  [new old]
+  (|let [merged-module-states (&/fold (fn [total m-state]
+                                        (|let [[_name _state] m-state]
+                                          (|case _state
+                                            (&/$Cached)
+                                            (&/|put _name _state total)
+                                            
+                                            (&/$Compiled)
+                                            (&/|put _name _state total)
+
+                                            _
+                                            total)))
+                                      (&/get$ &/$module-states old)
+                                      (&/get$ &/$module-states new))]
+    (->> old
+         (&/set$ &/$module-states merged-module-states))))
+
+(defn ^:private merge-modules
+  "(-> Text Module Module Module)"
+  [current-module new old]
+  (&/fold (fn [total* entry]
+            (|let [[_name _module] entry]
+              (if (or (= current-module _name)
+                      (->> _module
+                           (&/get$ &&module/$defs)
+                           &/|length
+                           (= 0)))
+                ;; Don't modify the entry of the current module, to
+                ;; avoid overwritting it's data in improper ways.
+                ;; Since it's assumed the "original" old module
+                ;; contains all the proper own-module information.
+                total*
+                (&/|put _name _module total*))))
+          old new))
+
+(defn ^:private merge-compilers
+  "(-> Text Compiler Compiler Compiler)"
+  [current-module new old]
+  (->> old
+       (&/set$ &/$modules (merge-modules current-module
+                                         (&/get$ &/$modules new)
+                                         (&/get$ &/$modules old)))
+       (&/set$ &/$seed (max (&/get$ &/$seed new)
+                            (&/get$ &/$seed old)))
+       (&/set$ &/$host (merge-hosts (&/get$ &/$host new)
+                                    (&/get$ &/$host old)))))
+
+(def ^:private get-compiler
+  (fn [compiler]
+    (return* compiler compiler)))
+
+(defn ^:private set-compiler [compiler*]
+  (fn [_]
+    (return* compiler* compiler*)))
+
 (defn analyse-module [analyse optimize eval! compile-module ?meta]
   (|do [_ &/ensure-statement
         =anns (&&/analyse-1 analyse &type/Anns ?meta)
@@ -582,27 +638,46 @@
         module-name &/get-module-name
         _ (&&module/set-anns ==anns module-name)
         _imports (&&module/fetch-imports ==anns)
-        current-module &/get-module-name]
-    (&/map% (fn [_import]
-              (|let [[path alias] _import]
-                (&/without-repl
-                 (&/save-module
-                  (|do [_ (if (= current-module path)
-                            (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path))
-                            (return nil))
-                        already-compiled? (&&module/exists? path)
-                        active? (&/active-module? path)
-                        _ (&/assert! (not active?)
-                                     (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module))
-                        _ (&&module/add-import path)
-                        ?module-hash (if (not already-compiled?)
-                                       (compile-module path)
-                                       (&&module/module-hash path))
-                        _ (if (= "" alias)
-                            (return nil)
-                            (&&module/alias current-module alias path))]
-                    (return &/$Nil))))))
-            _imports)))
+        current-module &/get-module-name
+        =asyncs (&/map% (fn [_import]
+                          (|let [[path alias] _import]
+                            (&/without-repl
+                             (&/save-module
+                              (|do [_ (if (= current-module path)
+                                        (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path))
+                                        (return nil))
+                                    already-compiled? (&&module/exists? path)
+                                    active? (&/active-module? path)
+                                    _ (&/assert! (not active?)
+                                                 (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module))
+                                    _ (&&module/add-import path)
+                                    ?async (if (not already-compiled?)
+                                             (compile-module path)
+                                             (|do [_compiler get-compiler]
+                                               (return (doto (promise)
+                                                         (deliver (&/$Right _compiler))))))
+                                    _ (if (= "" alias)
+                                        (return nil)
+                                        (&&module/alias current-module alias path))]
+                                (return ?async))))))
+                        _imports)
+        _compiler get-compiler
+        ;; Some type-vars in the typing environment stay in
+        ;; the environment forever, making type-checking slower.
+        ;; The merging process for compilers more-or-less "fixes" the
+        ;; problem by resetting the typing enviroment, but ideally
+        ;; those type-vars shouldn't survive in the first place.
+        ;; TODO: MUST FIX
+        _ (&/fold% (fn [compiler _async]
+                     (|case @_async
+                       (&/$Right _new-compiler)
+                       (set-compiler (merge-compilers current-module _new-compiler compiler))
+
+                       (&/$Left ?error)
+                       (fail ?error)))
+                   _compiler
+                   =asyncs)]
+    (return &/$Nil)))
 
 (defn ^:private coerce [new-type analysis]
   "(-> Type Analysis Analysis)"
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index a06988a3f..21aa324e8 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -43,8 +43,9 @@
        ))
 
 ;; [Exports]
-(defn add-import [module]
+(defn add-import
   "(-> Text (Lux Null))"
+  [module]
   (|do [current-module &/get-module-name]
     (fn [state]
       (if (&/|member? module (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $imports)))
@@ -58,8 +59,9 @@
                             state)
                  nil)))))
 
-(defn set-imports [imports]
+(defn set-imports
   "(-> (List Text) (Lux Null))"
+  [imports]
   (|do [current-module &/get-module-name]
     (fn [state]
       (return* (&/update$ &/$modules
@@ -91,8 +93,9 @@
       ((&/fail-with-loc (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))
        state))))
 
-(defn def-type [module name]
+(defn def-type
   "(-> Text Text (Lux Type))"
+  [module name]
   (fn [state]
     (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
       (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
@@ -103,8 +106,9 @@
       ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module))
        state))))
 
-(defn type-def [module name]
+(defn type-def
   "(-> Text Text (Lux [Bool Type]))"
+  [module name]
   (fn [state]
     (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))]
       (if-let [$def (->> $module (&/get$ $defs) (&/|get name))]
@@ -127,8 +131,9 @@
       ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module))
        state))))
 
-(defn exists? [name]
+(defn exists?
   "(-> Text (Lux Bool))"
+  [name]
   (fn [state]
     (return* state
              (->> state (&/get$ &/$modules) (&/|contains? name)))))
@@ -162,12 +167,12 @@
                    nil))))
     ))
 
-(defn ^:private imports? [state imported-module source-module]
+(defn ^:private imports? [state imported-module-name source-module-name]
   (->> state
        (&/get$ &/$modules)
-       (&/|get source-module)
+       (&/|get source-module-name)
        (&/get$ $imports)
-       (&/|any? (partial = imported-module))))
+       (&/|any? (partial = imported-module-name))))
 
 (defn get-anns [module-name]
   (fn [state]
@@ -210,18 +215,19 @@
                   (return* state (&/T [(&/T [module name]) $def]))
 
                   _
-                  ((&/fail-with-loc (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))
+                  ((&/fail-with-loc (str "[Analyser Error @ find-def] Can't use unexported definition: " (str module &/+name-separator+ name)))
                    state))))
-            ((&/fail-with-loc (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))
+            ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name)))
              state))
-          ((&/fail-with-loc (str "[Analyser Error] Module doesn't exist: " module))
+          ((&/fail-with-loc (str "[Analyser Error @ find-def] Module doesn't exist: " module))
            state))
-        ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module))
+        ((&/fail-with-loc (str "[Analyser Error @ find-def] Unknown module: " module))
          state))
       )))
 
-(defn ensure-type-def [def-data]
+(defn ensure-type-def
   "(-> DefData (Lux Type))"
+  [def-data]
   (|let [[?type ?meta ?value] def-data]
     (|case (&meta/meta-get &meta/type?-tag ?meta)
       (&/$Some _)
@@ -235,8 +241,9 @@
                          (return true))
                        (return false))))
 
-(defn create-module [name hash]
+(defn create-module
   "(-> Text Hash-Code (Lux Null))"
+  [name hash]
   (fn [state]
     (return* (->> state
                   (&/update$ &/$modules #(&/|put name (new-module hash) %))
@@ -244,8 +251,9 @@
              nil)))
 
 (do-template [<name> <tag> <type>]
-  (defn <name> [module]
+  (defn <name>
     <type>
+    [module]
     (fn [state]
       (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
         (return* state (&/get$ <tag> =module))
@@ -282,8 +290,9 @@
                      (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T [module name]))))]
     (return nil)))
 
-(defn declare-tags [module tag-names was-exported? type]
+(defn declare-tags
   "(-> Text (List Text) Bool Type (Lux Null))"
+  [module tag-names was-exported? type]
   (|do [_ (ensure-undeclared-tags module tag-names)
         type-name (&type/type-name type)
         :let [[_module _name] type-name]
@@ -309,8 +318,9 @@
         ((&/fail-with-loc (str "[Lux Error] Unknown module: " module))
          state)))))
 
-(defn ensure-can-see-tag [module tag-name]
+(defn ensure-can-see-tag
   "(-> Text Text (Lux Unit))"
+  [module tag-name]
   (|do [current-module &/get-module-name]
     (fn [state]
       (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
@@ -327,8 +337,9 @@
          state)))))
 
 (do-template [<name> <part> <doc>]
-  (defn <name> [module tag-name]
+  (defn <name>
     <doc>
+    [module tag-name]
     (fn [state]
       (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))]
         (if-let [^objects idx+tags+exported+type (&/|get tag-name (&/get$ $tags =module))]
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 88d50002b..54a0354c6 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -2,6 +2,7 @@
 ;;  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.base
   (:require (clojure [template :refer [do-template]]
                      [string :as string])
@@ -901,7 +902,7 @@
   (fn [state]
     (if-let [module (|get name (get$ $modules state))]
       (return* state module)
-      ((fail-with-loc (str "Unknown module: " name)) state))))
+      ((fail-with-loc (str "[Error] Unknown module: " name)) state))))
 
 (def get-current-module
   "(Lux (Module Compiler))"
@@ -1444,3 +1445,9 @@
 
                   _
                   class-name)]))))
+
+(let [!out! *out*]
+  (defn |log! [& parts]
+    (binding [*out* !out!]
+      (do (print (apply str parts))
+        (flush)))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 7bf53ada7..6506c867b 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -29,7 +29,8 @@
                           [case :as &&case]
                           [lambda :as &&lambda]
                           [module :as &&module]
-                          [io :as &&io])
+                          [io :as &&io]
+                          [parallel :as &&parallel])
             [lux.packager.program :as &packager-program])
   (:import (org.objectweb.asm Opcodes
                               Label
@@ -118,6 +119,7 @@
     ))
 
 (defn init! []
+  (&&parallel/setup!)
   (reset! !source->last-line {})
   (.mkdirs (java.io.File. &&/output-dir))
   (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL]))
@@ -167,10 +169,11 @@
   (defn compile-module [source-dirs name]
     (let [file-name (str name ".lux")]
       (|do [file-content (&&io/read-file source-dirs file-name)
-            :let [file-hash (hash file-content)]]
+            :let [file-hash (hash file-content)
+                  compile-module!! (&&parallel/parallel-compilation (partial compile-module source-dirs))]]
         (if (&&cache/cached? name)
-          (&&cache/load source-dirs name file-hash compile-module)
-          (let [compiler-step (&analyser/analyse &optimizer/optimize eval! (partial compile-module source-dirs) all-compilers)]
+          (&&cache/load source-dirs name file-hash compile-module!!)
+          (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)]
             (|do [module-exists? (&a-module/exists? name)]
               (if module-exists?
                 (fail "[Compiler Error] Can't redefine a module!")
@@ -252,13 +255,14 @@
       )))
 
 (defn compile-program [mode program-module source-dirs]
-  (init!)
-  (let [m-action (&/map% (partial compile-module source-dirs) (&/|list "lux" program-module))]
-    (|case (m-action (&/init-state mode))
-      (&/$Right ?state _)
-      (do (println "Compilation complete!")
-        (&&cache/clean ?state)
-        (&packager-program/package program-module))
+  (do (init!)
+    (let [m-action (|do [_ (compile-module source-dirs "lux")]
+                     (compile-module source-dirs program-module))]
+      (|case (m-action (&/init-state mode))
+        (&/$Right ?state _)
+        (do (println "Compilation complete!")
+          (&&cache/clean ?state)
+          (&packager-program/package program-module))
 
-      (&/$Left ?message)
-      (assert false ?message))))
+        (&/$Left ?message)
+        (assert false ?message)))))
diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj
index f2668f8b5..4f90c7cce 100644
--- a/src/lux/compiler/cache.clj
+++ b/src/lux/compiler/cache.clj
@@ -89,7 +89,7 @@
       (if already-loaded?
         (return module-hash)
         (|let [redo-cache (|do [_ (delete module)]
-                            (compile-module source-dirs module))]
+                            (compile-module module))]
           (if (cached? module)
             (|do [loader &/loader
                   !classes &/classes
diff --git a/src/lux/compiler/parallel.clj b/src/lux/compiler/parallel.clj
new file mode 100644
index 000000000..8f6fee99d
--- /dev/null
+++ b/src/lux/compiler/parallel.clj
@@ -0,0 +1,47 @@
+;;  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.parallel
+  (:require (clojure [string :as string]
+                     [set :as set]
+                     [template :refer [do-template]])
+            clojure.core.match
+            clojure.core.match.array
+            (lux [base :as & :refer [|let |do return* return fail fail* |case]])))
+
+;; [Utils]
+(def ^:private !state! (ref {}))
+
+(def ^:private get-compiler
+  (fn [compiler]
+    (return* compiler compiler)))
+
+;; [Exports]
+(defn setup!
+  "Must always call this function before using parallel compilation to make sure that the state that is being tracked is in proper shape."
+  []
+  (dosync (ref-set !state! {})))
+
+(defn parallel-compilation [compile-module*]
+  (fn [module-name]
+    (|do [compiler get-compiler
+          :let [[task new?] (dosync (if-let [existing-task (get @!state! module-name)]
+                                      (&/T [existing-task false])
+                                      (let [new-task (promise)]
+                                        (do (alter !state! assoc module-name new-task)
+                                          (&/T [new-task true])))))
+                _ (when new?
+                    (.start (new Thread
+                                 (fn []
+                                   (let [out-str (with-out-str
+                                                   (|case (&/run-state (compile-module* module-name)
+                                                                       compiler)
+                                                     (&/$Right post-compiler _)
+                                                     (deliver task (&/$Right post-compiler))
+
+                                                     (&/$Left ?error)
+                                                     (deliver task (&/$Left ?error))))]
+                                     (&/|log! out-str))))))]]
+      (return task))))
diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj
index 54cc8a813..2afda2674 100644
--- a/src/lux/packager/program.clj
+++ b/src/lux/packager/program.clj
@@ -85,7 +85,8 @@
        (filter #(.endsWith ^String % ".jar"))
        (filter #(not (or (.contains ^String % "org/ow2/asm/asm-all")
                          (.contains ^String % "org/clojure/core.match")
-                         (.contains ^String % "org/clojure/clojure"))))))
+                         (.contains ^String % "org/clojure/clojure")
+                         )))))
 
 (let [init-capacity (* 100 1024)
       buffer-size 1024]