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
  25 (define (mkdir-p dir)
  26   "Create directory DIR and all its ancestors."
  27   (define absolute?
  28     (string-prefix? "/" dir))
  29
  30   (define not-slash
  31     (char-set-complement (char-set #\/)))
  32
  33   (let loop ((components (string-tokenize dir not-slash))
  34              (root       (if absolute?
  35                              ""
  36                              ".")))
  37     (match components
  38       ((head tail ...)
  39        (let ((path (string-append root "/" head)))
  40          (catch 'system-error
  41            (lambda ()
  42              (mkdir path)
  43              (loop tail path))
  44            (lambda args
  45              (if (= EEXIST (system-error-errno args))
  46                  (loop tail path)
  47                  (apply throw args))))))
  48       (() #t))))
  49
  50 (define warnings
  51   '(unsupported-warning format unbound-variable arity-mismatch))
  52
  53 (define host (getenv "host"))
  54
  55 (define srcdir (getenv "srcdir"))
  56
  57 (define (relative-file file)
  58   (if (string-prefix? (string-append srcdir "/") file)
  59       (string-drop file (+ 1 (string-length srcdir)))
  60       file))
  61
  62 (define (file-mtime<? f1 f2)
  63   (< (stat:mtime (stat f1))
  64      (stat:mtime (stat f2))))
  65
  66 (define (scm->go file)
  67   (let* ((relative (relative-file file))
  68          (without-extension (string-drop-right relative 4)))
  69     (string-append without-extension ".go")))
  70
  71 (define (scm->mes file)
  72   (let* ((relative (relative-file file))
  73          (without-extension (string-drop-right relative 4)))
  74     (string-append without-extension ".mes")))
  75
  76 (define (file-needs-compilation? file)
  77   (let ((go (scm->go file)))
  78     (or (not (file-exists? go))
  79         (file-mtime<? go file)
  80         (let ((mes (scm->mes file))) ; FIXME: try to respect (include-from-path ".mes")
  81           (and (file-exists? mes)
  82                (file-mtime<? go mes))))))
  83
  84 (define (file->module file)
  85   (let* ((relative (relative-file file))
  86          (module-path (string-drop-right relative 4)))
  87     (map string->symbol
  88          (string-split module-path #\/))))
  89
  90 ;;; To work around <http://bugs.gnu.org/15602> (FIXME), we want to load all
  91 ;;; files to be compiled first.  We do this via resolve-interface so that the
  92 ;;; top-level of each file (module) is only executed once.
  93 (define (load-module-file file)
  94   (let ((module (file->module file)))
  95     (format #t "  LOAD     ~a~%" module)
  96     (resolve-interface module)))
  97
  98 (cond-expand
  99  (guile-2.2 (use-modules (language tree-il optimize)
 100                          (language cps optimize)))
 101  (else #f))
 102
 103 (define %default-optimizations
 104   ;; Default optimization options (equivalent to -O2 on Guile 2.2).
 105   (cond-expand
 106    (guile-2.2 (append (tree-il-default-optimization-options)
 107                       (cps-default-optimization-options)))
 108     (else '())))
 109
 110 (define %lightweight-optimizations
 111   ;; Lightweight optimizations (like -O0, but with partial evaluation).
 112   (let loop ((opts %default-optimizations)
 113              (result '()))
 114     (match opts
 115       (() (reverse result))
 116       ((#:partial-eval? _ rest ...)
 117        (loop rest `(#t #:partial-eval? ,@result)))
 118       ((kw _ rest ...)
 119        (loop rest `(#f ,kw ,@result))))))
 120
 121 (define (optimization-options file)
 122   (if (string-contains file "gnu/packages/")
 123       %lightweight-optimizations                  ;build faster
 124       '()))
 125
 126 (define (compile-file* file output-mutex)
 127   (let ((go (scm->go file)))
 128     (with-mutex output-mutex
 129       (format #t "  GUILEC   ~a~%" go)
 130       (force-output))
 131     (mkdir-p (dirname go))
 132     (with-fluids ((*current-warning-prefix* ""))
 133       (with-target host
 134         (lambda ()
 135           (compile-file file
 136                         #:output-file go
 137                         #:opts `(#:warnings ,warnings
 138                                  ,@(optimization-options file))))))))
 139
 140 ;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
 141 ;; opportunity to run upon SIGINT and to remove temporary output files.
 142 (sigaction SIGINT
 143   (lambda args
 144     (exit 1)))
 145
 146 (match (command-line)
 147   ((_ . files)
 148    (let ((files (filter file-needs-compilation? files)))
 149      (for-each load-module-file files)
 150      (let ((mutex (make-mutex)))
 151        ;; Make sure compilation related modules are loaded before starting to
 152        ;; compile files in parallel.
 153        (compile #f)
 154        (par-for-each (lambda (file)
 155                        (compile-file* file mutex))
 156                      files)))))
 157
 158 ;;; Local Variables:
 159 ;;; eval: (put 'with-target 'scheme-indent-function 1)
 160 ;;; End: