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 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 (% completed total)
  83   "Return the completion percentage of COMPLETED over TOTAL as an integer."
  84   (inexact->exact (round (* 100. (/ completed total)))))
  85
  86 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
  87 ;; opportunity to run upon SIGINT and to remove temporary output files.
  88 (sigaction SIGINT
  89   (lambda args
  90     (exit 1)))
  91
  92 (match (command-line)
  93   ((_ . files)
  94    (compile-files srcdir (getcwd)
  95                   (filter file-needs-compilation? files)
  96                   #:workers (parallel-job-count)
  97                   #:host host
  98                   #:report-load (lambda (file total completed)
  99                                   (when file
 100                                     (format #t "[~3d%] LOAD     ~a~%"
 101                                             (% (+ 1 completed) (* 2 total))
 102                                             file)
 103                                     (force-output)))
 104                   #:report-compilation (lambda (file total completed)
 105                                          (when file
 106                                            (format #t "[~3d%] GUILEC   ~a~%"
 107                                                    (% (+ total completed 1)
 108                                                       (* 2 total))
 109                                                    (scm->go file))
 110                                            (force-output))))))