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   (if (string-contains file "gnu/packages/")
  88       (optimizations-for-level 1)                 ;build faster
  89       (optimizations-for-level 3)))
  90
  91 (define (scm->go file)
  92   "Strip the \".scm\" suffix from FILE, and append \".go\"."
  93   (string-append (string-drop-right file 4) ".go"))
  94
  95 (define (relative-file directory file)
  96   "Return FILE relative to DIRECTORY, if possible."
  97   (if (string-prefix? (string-append directory "/") file)
  98       (string-drop file (+ 1 (string-length directory)))
  99       file))
 100
 101 (define* (load-files directory files
 102                      #:key
 103                      (report-load (const #f))
 104                      (debug-port (%make-void-port "w")))
 105   "Load FILES, a list of relative file names, from DIRECTORY."
 106   (define total
 107     (length files))
 108
 109   (let loop ((files files)
 110              (completed 0))
 111     (match files
 112       (()
 113        (unless (zero? total)
 114          (report-load #f total completed))
 115        *unspecified*)
 116       ((file files ...)
 117        (let ((file (relative-file directory file)))
 118          (report-load file total completed)
 119          (format debug-port "~%loading '~a'...~%" file)
 120
 121          (resolve-interface (file-name->module-name file))
 122
 123          (loop files (+ 1 completed)))))))
 124
 125 (define-syntax-rule (with-augmented-search-path path item body ...)
 126   "Within the dynamic extent of BODY, augment PATH by adding ITEM to the
 127 front."
 128   (let ((initial-value path))
 129     (dynamic-wind
 130       (lambda ()
 131         (set! path (cons item path)))
 132       (lambda ()
 133         body ...)
 134       (lambda ()
 135         (set! path initial-value)))))
 136
 137 (define (call/exit-on-exception file thunk)
 138   "Evaluate THUNK and exit right away if an exception is thrown.  Report FILE
 139 as the file that was being compiled when the exception was thrown."
 140   (catch #t
 141     thunk
 142     (const #f)
 143     (lambda (key . args)
 144       (false-if-exception
 145        ;; Duplicate stderr to avoid thread-safety issues.
 146        (let* ((port  (duplicate-port (current-error-port) "w0"))
 147               (stack (make-stack #t))
 148               (depth (stack-length stack))
 149               (frame (and (> depth 1) (stack-ref stack 1))))
 150          (newline port)
 151          (format port "error: failed to compile '~a':~%~%" file)
 152          (false-if-exception (display-backtrace stack port))
 153          (print-exception port frame key args)))
 154
 155       ;; Don't go any further.
 156       (primitive-exit 1))))
 157
 158 (define-syntax-rule (exit-on-exception file exp ...)
 159   "Evaluate EXP and exit if an exception is thrown.  Report FILE as the faulty
 160 file when an exception is thrown."
 161   (call/exit-on-exception file (lambda () exp ...)))
 162
 163 (define* (compile-files source-directory build-directory files
 164                         #:key
 165                         (host %host-type)
 166                         (workers (current-processor-count))
 167                         (optimization-options optimization-options)
 168                         (warning-options `(#:warnings ,%warnings))
 169                         (report-load (const #f))
 170                         (report-compilation (const #f))
 171                         (debug-port (%make-void-port "w")))
 172   "Compile FILES, a list of source files taken from SOURCE-DIRECTORY, to
 173 BUILD-DIRECTORY, using up to WORKERS parallel workers.  The resulting object
 174 files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
 175   (define progress-lock (make-mutex))
 176   (define total (length files))
 177   (define progress 0)
 178
 179   (define (build file)
 180     (with-mutex progress-lock
 181       (report-compilation file total progress)
 182       (set! progress (+ 1 progress)))
 183
 184     ;; Exit as soon as something goes wrong.
 185     (exit-on-exception
 186      file
 187      (let ((relative (relative-file source-directory file)))
 188        (compile-file file
 189                      #:output-file (string-append build-directory "/"
 190                                                   (scm->go relative))
 191                      #:opts (append warning-options
 192                                     (optimization-options relative))))))
 193
 194   (with-augmented-search-path %load-path source-directory
 195     (with-augmented-search-path %load-compiled-path build-directory
 196       (with-fluids ((*current-warning-prefix* ""))
 197         (with-target host
 198           (lambda ()
 199             ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first
 200             ;; load all of FILES.
 201             (load-files source-directory files
 202                         #:report-load report-load
 203                         #:debug-port debug-port)
 204
 205             ;; Make sure compilation related modules are loaded before
 206             ;; starting to compile files in parallel.
 207             (compile #f)
 208
 209             ;; XXX: Don't use too many workers to work around the insane
 210             ;; memory requirements of the compiler in Guile 2.2.2:
 211             ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
 212             (n-par-for-each (min workers 8) build files)
 213
 214             (unless (zero? total)
 215               (report-compilation #f total total))))))))
 216
 217 (eval-when (eval load)
 218   (when (and (string=? "2" (major-version))
 219              (or (string=? "0" (minor-version))
 220                  (and (string=? (minor-version) "2")
 221                       (< (string->number (micro-version)) 4))))
 222     ;; Work around <https://bugs.gnu.org/31878> on Guile < 2.2.4.
 223     ;; Serialize 'try-module-autoload' calls.
 224     (set! (@ (guile) try-module-autoload)
 225       (let ((mutex (make-mutex 'recursive))
 226             (real  (@ (guile) try-module-autoload)))
 227         (lambda* (module #:optional version)
 228           (with-mutex mutex
 229             (real module version)))))))
 230
 231 ;;; Local Variables:
 232 ;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2)
 233 ;;; eval: (put 'with-target 'scheme-indent-function 1)
 234 ;;; End: