X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/eda8a841ac7457ffe05c4a4248d6dff074b72326..6182897c98e11676b9a370da297a688c311f4cab:/build-aux/compile-all.scm

diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm
index c7ca5a6f67..ad75e33a85 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, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,7 +17,8 @@
 ;;; 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 (ice-9 match)
+(use-modules (ice-9 format)
+             (ice-9 match)
              (ice-9 threads)
              (srfi srfi-1)
              (guix build compile)
@@ -78,6 +79,18 @@ to 'make'."
                        (current-processor-count))))
                 (loop tail)))))))))
 
+(define (parallel-job-count*)
+  ;; XXX: Work around memory requirements not sustainable on i686 above '-j4'
+  ;; or so: <https://bugs.gnu.org/40522>.
+  (let ((count (parallel-job-count)))
+    (if (string-prefix? "i686" %host-type)
+        (min count 4)
+        count)))
+
+(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.
 (sigaction SIGINT
@@ -86,14 +99,45 @@ to 'make'."
 
 (match (command-line)
   ((_ . files)
-   (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)))))))
+   (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)))))))))