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 (system base target)
  21              (system base message)
  22              (ice-9 match)
  23              (ice-9 threads)
  24              (guix build utils))
  25
  26 (define warnings
  27   ;; FIXME: 'format' is missing because it reports "non-literal format
  28   ;; strings" due to the fact that we use 'G_' instead of '_'.  We'll need
  29   ;; help from Guile to solve this.
  30   '(unsupported-warning unbound-variable arity-mismatch
  31     macro-use-before-definition))                 ;new in 2.2
  32
  33 (define host (getenv "host"))
  34
  35 (define srcdir (getenv "srcdir"))
  36
  37 (define (relative-file file)
  38   (if (string-prefix? (string-append srcdir "/") file)
  39       (string-drop file (+ 1 (string-length srcdir)))
  40       file))
  41
  42 (define (file-mtime<? f1 f2)
  43   (< (stat:mtime (stat f1))
  44      (stat:mtime (stat f2))))
  45
  46 (define (scm->go file)
  47   (let* ((relative (relative-file file))
  48          (without-extension (string-drop-right relative 4)))
  49     (string-append without-extension ".go")))
  50
  51 (define (file-needs-compilation? file)
  52   (let ((go (scm->go file)))
  53     (or (not (file-exists? go))
  54         (file-mtime<? go file))))
  55
  56 (define (file->module file)
  57   (let* ((relative (relative-file file))
  58          (module-path (string-drop-right relative 4)))
  59     (map string->symbol
  60          (string-split module-path #\/))))
  61
  62 ;;; To work around <http://bugs.gnu.org/15602> (FIXME), we want to load all
  63 ;;; files to be compiled first.  We do this via resolve-interface so that the
  64 ;;; top-level of each file (module) is only executed once.
  65 (define (load-module-file file)
  66   (let ((module (file->module file)))
  67     (format #t "  LOAD     ~a~%" module)
  68     (resolve-interface module)))
  69
  70 (cond-expand
  71   (guile-2.2 (use-modules (language tree-il optimize)
  72                           (language cps optimize)))
  73   (else #f))
  74
  75 (define %default-optimizations
  76   ;; Default optimization options (equivalent to -O2 on Guile 2.2).
  77   (cond-expand
  78     (guile-2.2 (append (tree-il-default-optimization-options)
  79                        (cps-default-optimization-options)))
  80     (else '())))
  81
  82 (define %lightweight-optimizations
  83   ;; Lightweight optimizations (like -O0, but with partial evaluation).
  84   (let loop ((opts %default-optimizations)
  85              (result '()))
  86     (match opts
  87       (() (reverse result))
  88       ((#:partial-eval? _ rest ...)
  89        (loop rest `(#t #:partial-eval? ,@result)))
  90       ((kw _ rest ...)
  91        (loop rest `(#f ,kw ,@result))))))
  92
  93 (define (optimization-options file)
  94   (if (string-contains file "gnu/packages/")
  95       %lightweight-optimizations                  ;build faster
  96       '()))
  97
  98 (define (compile-file* file output-mutex)
  99   (let ((go (scm->go file)))
 100     (with-mutex output-mutex
 101       (format #t "  GUILEC   ~a~%" go)
 102       (force-output))
 103     (mkdir-p (dirname go))
 104     (with-fluids ((*current-warning-prefix* ""))
 105       (with-target host
 106         (lambda ()
 107           (compile-file file
 108                         #:output-file go
 109                         #:opts `(#:warnings ,warnings
 110                                  ,@(optimization-options file))))))))
 111
 112 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
 113 ;; opportunity to run upon SIGINT and to remove temporary output files.
 114 (sigaction SIGINT
 115   (lambda args
 116     (exit 1)))
 117
 118 (match (command-line)
 119   ((_ . files)
 120    (let ((files (filter file-needs-compilation? files)))
 121      (for-each load-module-file files)
 122      (let ((mutex (make-mutex)))
 123        ;; Make sure compilation related modules are loaded before starting to
 124        ;; compile files in parallel.
 125        (compile #f)
 126        (par-for-each (lambda (file)
 127                        (compile-file* file mutex))
 128                      files)))))
 129
 130 ;;; Local Variables:
 131 ;;; eval: (put 'with-target 'scheme-indent-function 1)
 132 ;;; End: