;;; 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, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; 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)
(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 #\/))))
+(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)))))))))
-;;; 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*)
+ ;; 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 (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.
+(sigaction SIGINT
+ (lambda args
+ (exit 1)))
(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)))))))))
HCoop / jackhill / guix / guix.git / blobdiff