build-aux/compile-all.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
   3 ;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (use-modules (ice-9 format)
  21              (ice-9 match)
  22              (ice-9 threads)
  23              (srfi srfi-1)
  24              (guix build compile)
  25              (guix build utils))
  26
  27 (define host (getenv "host"))
  28 (define srcdir (getenv "srcdir"))
  29
  30 (define (relative-file file)
  31   (if (string-prefix? (string-append srcdir "/") file)
  32       (string-drop file (+ 1 (string-length srcdir)))
  33       file))
  34
  35 (define (file-mtime<? f1 f2)
  36   (< (stat:mtime (stat f1))
  37      (stat:mtime (stat f2))))
  38
  39 (define (scm->go file)
  40   (let* ((relative (relative-file file))
  41          (without-extension (string-drop-right relative 4)))
  42     (string-append without-extension ".go")))
  43
  44 (define (file-needs-compilation? file)
  45   (let ((go (scm->go file)))
  46     (or (not (file-exists? go))
  47         (file-mtime<? go file))))
  48
  49 (define* (parallel-job-count #:optional (flags (getenv "MAKEFLAGS")))
  50   "Return the number of parallel jobs as determined by FLAGS, the flags passed
  51 to 'make'."
  52   (match flags
  53     (#f (current-processor-count))
  54     (flags
  55      (let ((initial-flags (string-tokenize flags)))
  56        (let loop ((flags initial-flags))
  57          (match flags
  58            (()
  59             ;; Note: GNU make prior to version 4.2 would hide "-j" flags from
  60             ;; $MAKEFLAGS.  Thus, check for a "--jobserver" flag here and
  61             ;; assume we're using all cores if specified.
  62             (if (any (lambda (flag)
  63                        (string-prefix? "--jobserver" flag))
  64                      initial-flags)
  65                 (current-processor-count)         ;GNU make < 4.2
  66                 1))                               ;sequential make
  67            (("-j" (= string->number count) _ ...)
  68             (if (integer? count)
  69                 count
  70                 (current-processor-count)))
  71            ((head tail ...)
  72             (if (string-prefix? "-j" head)
  73                 (match (string-drop head 2)
  74                   (""
  75                    (current-processor-count))
  76                   ((= string->number count)
  77                    (if (integer? count)
  78                        count
  79                        (current-processor-count))))
  80                 (loop tail)))))))))
  81
  82 (define (parallel-job-count*)
  83   ;; XXX: Work around memory requirements not sustainable on i686 above '-j4'
  84   ;; or so: <https://bugs.gnu.org/40522>.
  85   (let ((count (parallel-job-count)))
  86     (if (string-prefix? "i686" %host-type)
  87         (min count 4)
  88         count)))
  89
  90 (define (% completed total)
  91   "Return the completion percentage of COMPLETED over TOTAL as an integer."
  92   (inexact->exact (round (* 100. (/ completed total)))))
  93
  94 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
  95 ;; opportunity to run upon SIGINT and to remove temporary output files.
  96 (sigaction SIGINT
  97   (lambda args
  98     (exit 1)))
  99
 100 (match (command-line)
 101   ((_ . files)
 102    (catch #t
 103      (lambda ()
 104        (compile-files srcdir (getcwd)
 105                       (filter file-needs-compilation? files)
 106                       #:workers (parallel-job-count*)
 107                       #:host host
 108                       #:report-load (lambda (file total completed)
 109                                       (when file
 110                                         (format #t "[~3d%] LOAD     ~a~%"
 111                                                 (% (+ 1 completed) (* 2 total))
 112                                                 file)
 113                                         (force-output)))
 114                       #:report-compilation (lambda (file total completed)
 115                                              (when file
 116                                                (format #t "[~3d%] GUILEC   ~a~%"
 117                                                        (% (+ total completed 1)
 118                                                           (* 2 total))
 119                                                        (scm->go file))
 120                                                (force-output)))))
 121      (lambda _
 122        (primitive-exit 1))
 123      (lambda args
 124        ;; Try to report the error in an intelligible way.
 125        (let* ((stack   (make-stack #t))
 126               (frame   (if (> (stack-length stack) 1)
 127                            (stack-ref stack 1)    ;skip the 'throw' frame
 128                            (stack-ref stack 0)))
 129               (ui      (false-if-exception
 130                         (resolve-module '(guix ui))))
 131               (report  (and ui
 132                             (false-if-exception
 133                              (module-ref ui 'report-load-error)))))
 134          (if report
 135              ;; In Guile <= 2.2.5, 'current-load-port' was not exported.
 136              (let ((load-port ((module-ref (resolve-module '(ice-9 ports))
 137                                            'current-load-port))))
 138                (report (or (and=> load-port port-filename) "?.scm")
 139                        args frame))
 140              (begin
 141                (print-exception (current-error-port) frame
 142                                 (car args) (cdr args))
 143                (display-backtrace stack (current-error-port)))))))))