Merge branch 'master' into core-updates

2 files changed, 47 insertions, 79 deletions

diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 4933e02712..ed8ff5f4ce 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -245,6 +245,7 @@ Please upgrade to an intermediate version first, for instance with:
     (gexp->derivation "guix-latest" builder
                       #:modules '((guix build pull)
                                   (guix build utils)
+                                  (guix build compile)
 
                                   ;; Closure of (guix modules).
                                   (guix modules)
diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm
index fe25c5d065..c7ca5a6f67 100644
--- a/build-aux/compile-all.scm
+++ b/build-aux/compile-all.scm
@@ -17,21 +17,13 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-(use-modules (system base target)
-             (system base message)
-             (ice-9 match)
+(use-modules (ice-9 match)
              (ice-9 threads)
+             (srfi srfi-1)
+             (guix build compile)
              (guix build utils))
 
-(define warnings
-  ;; FIXME: 'format' is missing because it reports "non-literal format
-  ;; strings" due to the fact that we use 'G_' instead of '_'.  We'll need
-  ;; help from Guile to solve this.
-  '(unsupported-warning unbound-variable arity-mismatch
-    macro-use-before-definition))                 ;new in 2.2
-
 (define host (getenv "host"))
-
 (define srcdir (getenv "srcdir"))
 
 (define (relative-file file)
@@ -53,61 +45,38 @@
     (or (not (file-exists? go))
         (file-mtime<? go file))))
 
-(define (file->module file)
-  (let* ((relative (relative-file file))
-         (module-path (string-drop-right relative 4)))
-    (map string->symbol
-         (string-split module-path #\/))))
-
-;;; To work around <http://bugs.gnu.org/15602> (FIXME), we want to load all
-;;; files to be compiled first.  We do this via resolve-interface so that the
-;;; top-level of each file (module) is only executed once.
-(define (load-module-file file)
-  (let ((module (file->module file)))
-    (format #t "  LOAD     ~a~%" module)
-    (resolve-interface module)))
-
-(cond-expand
-  (guile-2.2 (use-modules (language tree-il optimize)
-                          (language cps optimize)))
-  (else #f))
-
-(define %default-optimizations
-  ;; Default optimization options (equivalent to -O2 on Guile 2.2).
-  (cond-expand
-    (guile-2.2 (append (tree-il-default-optimization-options)
-                       (cps-default-optimization-options)))
-    (else '())))
-
-(define %lightweight-optimizations
-  ;; Lightweight optimizations (like -O0, but with partial evaluation).
-  (let loop ((opts %default-optimizations)
-             (result '()))
-    (match opts
-      (() (reverse result))
-      ((#:partial-eval? _ rest ...)
-       (loop rest `(#t #:partial-eval? ,@result)))
-      ((kw _ rest ...)
-       (loop rest `(#f ,kw ,@result))))))
-
-(define (optimization-options file)
-  (if (string-contains file "gnu/packages/")
-      %lightweight-optimizations                  ;build faster
-      '()))
-
-(define (compile-file* file output-mutex)
-  (let ((go (scm->go file)))
-    (with-mutex output-mutex
-      (format #t "  GUILEC   ~a~%" go)
-      (force-output))
-    (mkdir-p (dirname go))
-    (with-fluids ((*current-warning-prefix* ""))
-      (with-target host
-        (lambda ()
-          (compile-file file
-                        #:output-file go
-                        #:opts `(#:warnings ,warnings
-                                 ,@(optimization-options file))))))))
+(define* (parallel-job-count #:optional (flags (getenv "MAKEFLAGS")))
+  "Return the number of parallel jobs as determined by FLAGS, the flags passed
+to 'make'."
+  (match flags
+    (#f (current-processor-count))
+    (flags
+     (let ((initial-flags (string-tokenize flags)))
+       (let loop ((flags initial-flags))
+         (match flags
+           (()
+            ;; Note: GNU make prior to version 4.2 would hide "-j" flags from
+            ;; $MAKEFLAGS.  Thus, check for a "--jobserver" flag here and
+            ;; assume we're using all cores if specified.
+            (if (any (lambda (flag)
+                       (string-prefix? "--jobserver" flag))
+                     initial-flags)
+                (current-processor-count)         ;GNU make < 4.2
+                1))                               ;sequential make
+           (("-j" (= string->number count) _ ...)
+            (if (integer? count)
+                count
+                (current-processor-count)))
+           ((head tail ...)
+            (if (string-prefix? "-j" head)
+                (match (string-drop head 2)
+                  (""
+                   (current-processor-count))
+                  ((= string->number count)
+                   (if (integer? count)
+                       count
+                       (current-processor-count))))
+                (loop tail)))))))))
 
 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
 ;; opportunity to run upon SIGINT and to remove temporary output files.
@@ -117,16 +86,14 @@
 
 (match (command-line)
   ((_ . files)
-   (let ((files (filter file-needs-compilation? files)))
-     (for-each load-module-file files)
-     (let ((mutex (make-mutex)))
-       ;; Make sure compilation related modules are loaded before starting to
-       ;; compile files in parallel.
-       (compile #f)
-       (par-for-each (lambda (file)
-                       (compile-file* file mutex))
-                     files)))))
-
-;;; Local Variables:
-;;; eval: (put 'with-target 'scheme-indent-function 1)
-;;; End:
+   (compile-files srcdir (getcwd)
+                  (filter file-needs-compilation? files)
+                  #:workers (parallel-job-count)
+                  #:host host
+                  #:report-load (lambda (file total completed)
+                                  (when file
+                                    (format #t "  LOAD     ~a~%" file)))
+                  #:report-compilation (lambda (file total completed)
+                                         (when file
+                                           (format #t "  GUILEC   ~a~%"
+                                                   (scm->go file)))))))