guix/build/compile.scm

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