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 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 match)
  21              (ice-9 threads)
  22              (srfi srfi-1)
  23              (guix build compile)
  24              (guix build utils))
  25
  26 (define host (getenv "host"))
  27 (define srcdir (getenv "srcdir"))
  28
  29 (define (relative-file file)
  30   (if (string-prefix? (string-append srcdir "/") file)
  31       (string-drop file (+ 1 (string-length srcdir)))
  32       file))
  33
  34 (define (file-mtime<? f1 f2)
  35   (< (stat:mtime (stat f1))
  36      (stat:mtime (stat f2))))
  37
  38 (define (scm->go file)
  39   (let* ((relative (relative-file file))
  40          (without-extension (string-drop-right relative 4)))
  41     (string-append without-extension ".go")))
  42
  43 (define (file-needs-compilation? file)
  44   (let ((go (scm->go file)))
  45     (or (not (file-exists? go))
  46         (file-mtime<? go file))))
  47
  48 (define* (parallel-job-count #:optional (flags (getenv "MAKEFLAGS")))
  49   "Return the number of parallel jobs as determined by FLAGS, the flags passed
  50 to 'make'."
  51   (match flags
  52     (#f (current-processor-count))
  53     (flags
  54      (let ((initial-flags (string-tokenize flags)))
  55        (let loop ((flags initial-flags))
  56          (match flags
  57            (()
  58             ;; Note: GNU make prior to version 4.2 would hide "-j" flags from
  59             ;; $MAKEFLAGS.  Thus, check for a "--jobserver" flag here and
  60             ;; assume we're using all cores if specified.
  61             (if (any (lambda (flag)
  62                        (string-prefix? "--jobserver" flag))
  63                      initial-flags)
  64                 (current-processor-count)         ;GNU make < 4.2
  65                 1))                               ;sequential make
  66            (("-j" (= string->number count) _ ...)
  67             (if (integer? count)
  68                 count
  69                 (current-processor-count)))
  70            ((head tail ...)
  71             (if (string-prefix? "-j" head)
  72                 (match (string-drop head 2)
  73                   (""
  74                    (current-processor-count))
  75                   ((= string->number count)
  76                    (if (integer? count)
  77                        count
  78                        (current-processor-count))))
  79                 (loop tail)))))))))
  80
  81 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
  82 ;; opportunity to run upon SIGINT and to remove temporary output files.
  83 (sigaction SIGINT
  84   (lambda args
  85     (exit 1)))
  86
  87 (match (command-line)
  88   ((_ . files)
  89    (compile-files srcdir (getcwd)
  90                   (filter file-needs-compilation? files)
  91                   #:workers (parallel-job-count)
  92                   #:host host
  93                   #:report-load (lambda (file total completed)
  94                                   (when file
  95                                     (format #t "  LOAD     ~a~%" file)
  96                                     (force-output)))
  97                   #:report-compilation (lambda (file total completed)
  98                                          (when file
  99                                            (format #t "  GUILEC   ~a~%"
 100                                                    (scm->go file))
 101                                            (force-output))))))