guix/build/compile.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
   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 (define-module (guix build compile)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 format)
  24   #:use-module (ice-9 threads)
  25   #:use-module (system base target)
  26   #:use-module (system base compile)
  27   #:use-module (system base message)
  28   #:use-module (guix modules)
  29   #:use-module (guix build utils)
  30   #:use-module (language tree-il optimize)
  31   #:use-module (language cps optimize)
  32   #:export (%default-optimizations
  33             %lightweight-optimizations
  34             compile-files))
  35
  36 ;;; Commentary:
  37 ;;;
  38 ;;; Support code to compile Guile code as efficiently as possible (with 2.2).
  39 ;;;
  40 ;;; Code:
  41
  42 (define %default-optimizations
  43   ;; Default optimization options (equivalent to -O2 on Guile 2.2).
  44   (append (if (defined? 'tree-il-default-optimization-options)
  45               (tree-il-default-optimization-options) ;Guile 2.2
  46               (tree-il-optimizations))               ;Guile 3
  47           (if (defined? 'cps-default-optimization-options)
  48               (cps-default-optimization-options)  ;Guile 2.2
  49               (cps-optimizations))))              ;Guile 3
  50
  51 (define %lightweight-optimizations
  52   ;; Lightweight optimizations (like -O0, but with partial evaluation).
  53   (let loop ((opts %default-optimizations)
  54              (result '()))
  55     (match opts
  56       (() (reverse result))
  57       ((#:partial-eval? _ rest ...)
  58        (loop rest `(#t #:partial-eval? ,@result)))
  59       ((kw _ rest ...)
  60        (loop rest `(#f ,kw ,@result))))))
  61
  62 (define (supported-warning-type? type)
  63   "Return true if TYPE, a symbol, denotes a supported warning type."
  64   (find (lambda (warning-type)
  65           (eq? type (warning-type-name warning-type)))
  66         %warning-types))
  67
  68 (define %warnings
  69   ;; FIXME: 'format' is missing because it reports "non-literal format
  70   ;; strings" due to the fact that we use 'G_' instead of '_'.  We'll need
  71   ;; help from Guile to solve this.
  72   (let ((optional (lambda (type)
  73                     (if (supported-warning-type? type)
  74                         (list type)
  75                         '()))))
  76     `(unbound-variable arity-mismatch
  77       macro-use-before-definition                         ;new in 2.2
  78       ,@(optional 'shadowed-toplevel))))                  ;new in 2.2.5
  79
  80 (define (optimization-options file)
  81   "Return the default set of optimizations options for FILE."
  82   (if (string-contains file "gnu/packages/")
  83       %lightweight-optimizations                  ;build faster
  84       '()))
  85
  86 (define (scm->go file)
  87   "Strip the \".scm\" suffix from FILE, and append \".go\"."
  88   (string-append (string-drop-right file 4) ".go"))
  89
  90 (define (relative-file directory file)
  91   "Return FILE relative to DIRECTORY, if possible."
  92   (if (string-prefix? (string-append directory "/") file)
  93       (string-drop file (+ 1 (string-length directory)))
  94       file))
  95
  96 (define* (load-files directory files
  97                      #:key
  98                      (report-load (const #f))
  99                      (debug-port (%make-void-port "w")))
 100   "Load FILES, a list of relative file names, from DIRECTORY."
 101   (define total
 102     (length files))
 103
 104   (let loop ((files files)
 105              (completed 0))
 106     (match files
 107       (()
 108        (unless (zero? total)
 109          (report-load #f total completed))
 110        *unspecified*)
 111       ((file files ...)
 112        (let ((file (relative-file directory file)))
 113          (report-load file total completed)
 114          (format debug-port "~%loading '~a'...~%" file)
 115
 116          (resolve-interface (file-name->module-name file))
 117
 118          (loop files (+ 1 completed)))))))
 119
 120 (define-syntax-rule (with-augmented-search-path path item body ...)
 121   "Within the dynamic extent of BODY, augment PATH by adding ITEM to the
 122 front."
 123   (let ((initial-value path))
 124     (dynamic-wind
 125       (lambda ()
 126         (set! path (cons item path)))
 127       (lambda ()
 128         body ...)
 129       (lambda ()
 130         (set! path initial-value)))))
 131
 132 (define (call/exit-on-exception file thunk)
 133   "Evaluate THUNK and exit right away if an exception is thrown.  Report FILE
 134 as the file that was being compiled when the exception was thrown."
 135   (catch #t
 136     thunk
 137     (const #f)
 138     (lambda (key . args)
 139       (false-if-exception
 140        ;; Duplicate stderr to avoid thread-safety issues.
 141        (let* ((port  (duplicate-port (current-error-port) "w0"))
 142               (stack (make-stack #t))
 143               (depth (stack-length stack))
 144               (frame (and (> depth 1) (stack-ref stack 1))))
 145          (newline port)
 146          (format port "error: failed to compile '~a':~%~%" file)
 147          (false-if-exception (display-backtrace stack port))
 148          (print-exception port frame key args)))
 149
 150       ;; Don't go any further.
 151       (primitive-exit 1))))
 152
 153 (define-syntax-rule (exit-on-exception file exp ...)
 154   "Evaluate EXP and exit if an exception is thrown.  Report FILE as the faulty
 155 file when an exception is thrown."
 156   (call/exit-on-exception file (lambda () exp ...)))
 157
 158 (define* (compile-files source-directory build-directory files
 159                         #:key
 160                         (host %host-type)
 161                         (workers (current-processor-count))
 162                         (optimization-options optimization-options)
 163                         (warning-options `(#:warnings ,%warnings))
 164                         (report-load (const #f))
 165                         (report-compilation (const #f))
 166                         (debug-port (%make-void-port "w")))
 167   "Compile FILES, a list of source files taken from SOURCE-DIRECTORY, to
 168 BUILD-DIRECTORY, using up to WORKERS parallel workers.  The resulting object
 169 files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
 170   (define progress-lock (make-mutex))
 171   (define total (length files))
 172   (define progress 0)
 173
 174   (define (build file)
 175     (with-mutex progress-lock
 176       (report-compilation file total progress)
 177       (set! progress (+ 1 progress)))
 178
 179     ;; Exit as soon as something goes wrong.
 180     (exit-on-exception
 181      file
 182      (with-target host
 183        (lambda ()
 184          (let ((relative (relative-file source-directory file)))
 185            (compile-file file
 186                          #:output-file (string-append build-directory "/"
 187                                                       (scm->go relative))
 188                          #:opts (append warning-options
 189                                         (optimization-options relative))))))))
 190
 191   (with-augmented-search-path %load-path source-directory
 192     (with-augmented-search-path %load-compiled-path build-directory
 193       (with-fluids ((*current-warning-prefix* ""))
 194
 195         ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all
 196         ;; of FILES.
 197         (load-files source-directory files
 198                     #:report-load report-load
 199                     #:debug-port debug-port)
 200
 201         ;; Make sure compilation related modules are loaded before starting to
 202         ;; compile files in parallel.
 203         (compile #f)
 204
 205         ;; XXX: Don't use too many workers to work around the insane memory
 206         ;; requirements of the compiler in Guile 2.2.2:
 207         ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
 208         (n-par-for-each (min workers 8) build files)
 209
 210         (unless (zero? total)
 211           (report-compilation #f total total))))))
 212
 213 (eval-when (eval load)
 214   (when (and (string=? "2" (major-version))
 215              (or (string=? "0" (minor-version))
 216                  (and (string=? (minor-version) "2")
 217                       (< (string->number (micro-version)) 4))))
 218     ;; Work around <https://bugs.gnu.org/31878> on Guile < 2.2.4.
 219     ;; Serialize 'try-module-autoload' calls.
 220     (set! (@ (guile) try-module-autoload)
 221       (let ((mutex (make-mutex 'recursive))
 222             (real  (@ (guile) try-module-autoload)))
 223         (lambda* (module #:optional version)
 224           (with-mutex mutex
 225             (real module version)))))))
 226
 227 ;;; Local Variables:
 228 ;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2)
 229 ;;; eval: (put 'with-target 'scheme-indent-function 1)
 230 ;;; End: