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>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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
38 ;;; Support code to compile Guile code as efficiently as possible (with 2.2).
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
51 (define %lightweight-optimizations
52 ;; Lightweight optimizations (like -O0, but with partial evaluation).
53 (let loop ((opts %default-optimizations)
57 ((#:partial-eval? _ rest ...)
58 (loop rest `(#t #:partial-eval? ,@result)))
60 (loop rest `(#f ,kw ,@result))))))
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)))
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)
76 `(unbound-variable arity-mismatch
77 macro-use-before-definition ;new in 2.2
78 ,@(optional 'shadowed-toplevel)))) ;new in 2.2.5
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
86 (define (scm->go file)
87 "Strip the \".scm\" suffix from FILE, and append \".go\"."
88 (string-append (string-drop-right file 4) ".go"))
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)))
96 (define* (load-files directory files
98 (report-load (const #f))
99 (debug-port (%make-void-port "w")))
100 "Load FILES, a list of relative file names, from DIRECTORY."
104 (let loop ((files files)
108 (unless (zero? total)
109 (report-load #f total completed))
112 (let ((file (relative-file directory file)))
113 (report-load file total completed)
114 (format debug-port "~%loading '~a'...~%" file)
116 (resolve-interface (file-name->module-name file))
118 (loop files (+ 1 completed)))))))
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
123 (let ((initial-value path))
126 (set! path (cons item path)))
130 (set! path initial-value)))))
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."
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))))
146 (format port "error: failed to compile '~a':~%~%" file)
147 (false-if-exception (display-backtrace stack port))
148 (print-exception port frame key args)))
150 ;; Don't go any further.
151 (primitive-exit 1))))
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 ...)))
158 (define* (compile-files source-directory build-directory files
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))
175 (with-mutex progress-lock
176 (report-compilation file total completed))
178 ;; Exit as soon as something goes wrong.
183 (let ((relative (relative-file source-directory file)))
185 #:output-file (string-append build-directory "/"
187 #:opts (append warning-options
188 (optimization-options relative)))))))
189 (with-mutex progress-lock
190 (set! completed (+ 1 completed))))
192 (with-augmented-search-path %load-path source-directory
193 (with-augmented-search-path %load-compiled-path build-directory
194 (with-fluids ((*current-warning-prefix* ""))
196 ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all
198 (load-files source-directory files
199 #:report-load report-load
200 #:debug-port debug-port)
202 ;; Make sure compilation related modules are loaded before starting to
203 ;; compile files in parallel.
206 ;; XXX: Don't use too many workers to work around the insane memory
207 ;; requirements of the compiler in Guile 2.2.2:
208 ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
209 (n-par-for-each (min workers 8) build files)
211 (unless (zero? total)
212 (report-compilation #f total total))))))
214 (eval-when (eval load)
215 (when (and (string=? "2" (major-version))
216 (or (string=? "0" (minor-version))
217 (and (string=? (minor-version) "2")
218 (< (string->number (micro-version)) 4))))
219 ;; Work around <https://bugs.gnu.org/31878> on Guile < 2.2.4.
220 ;; Serialize 'try-module-autoload' calls.
221 (set! (@ (guile) try-module-autoload)
222 (let ((mutex (make-mutex 'recursive))
223 (real (@ (guile) try-module-autoload)))
224 (lambda* (module #:optional version)
226 (real module version)))))))
229 ;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2)
230 ;;; eval: (put 'with-target 'scheme-indent-function 1)