X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/061d7f3bd2cc67c964acb2cb1bde07ee61df5d1a..f78f0d7ffee6a51d997705038842b3f8341bfa4b:/build-aux/compile-all.scm

diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm
index 6ce4040887..e9f3e957d9 100644
--- a/build-aux/compile-all.scm
+++ b/build-aux/compile-all.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,17 +17,14 @@
 ;;; 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)
+(use-modules (ice-9 format)
              (ice-9 match)
              (ice-9 threads)
+             (srfi srfi-1)
+             (guix build compile)
              (guix build utils))
 
-(define warnings
-  '(unsupported-warning format unbound-variable arity-mismatch))
-
 (define host (getenv "host"))
-
 (define srcdir (getenv "srcdir"))
 
 (define (relative-file file)
@@ -49,32 +46,42 @@
     (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)))
+(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)))))))))
 
-(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)))))))
+(define (% completed total)
+  "Return the completion percentage of COMPLETED over TOTAL as an integer."
+  (inexact->exact (round (* 100. (/ completed total)))))
 
 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
 ;; opportunity to run upon SIGINT and to remove temporary output files.
@@ -84,16 +91,45 @@
 
 (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:
+   (catch #t
+     (lambda ()
+       (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 "[~3d%] LOAD     ~a~%"
+                                                (% (+ 1 completed) (* 2 total))
+                                                file)
+                                        (force-output)))
+                      #:report-compilation (lambda (file total completed)
+                                             (when file
+                                               (format #t "[~3d%] GUILEC   ~a~%"
+                                                       (% (+ total completed 1)
+                                                          (* 2 total))
+                                                       (scm->go file))
+                                               (force-output)))))
+     (lambda _
+       (primitive-exit 1))
+     (lambda args
+       ;; Try to report the error in an intelligible way.
+       (let* ((stack   (make-stack #t))
+              (frame   (if (> (stack-length stack) 1)
+                           (stack-ref stack 1)    ;skip the 'throw' frame
+                           (stack-ref stack 0)))
+              (ui      (false-if-exception
+                        (resolve-module '(guix ui))))
+              (report  (and ui
+                            (false-if-exception
+                             (module-ref ui 'report-load-error)))))
+         (if report
+             ;; In Guile <= 2.2.5, 'current-load-port' was not exported.
+             (let ((load-port ((module-ref (resolve-module '(ice-9 ports))
+                                           'current-load-port))))
+               (report (or (and=> load-port port-filename) "?.scm")
+                       args frame))
+             (begin
+               (print-exception (current-error-port) frame
+                                (car args) (cdr args))
+               (display-backtrace stack (current-error-port)))))))))