guix/build/compile.scm

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