Commit | Line | Data |
---|---|---|
2890ad33 | 1 | ;;; GNU Guix --- Functional package management for GNU |
4d52e0f6 | 2 | ;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
2890ad33 LC |
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) | |
e429566f | 21 | #:use-module (srfi srfi-1) |
2890ad33 LC |
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) | |
7a51c78c | 28 | #:use-module (guix modules) |
2890ad33 | 29 | #:use-module (guix build utils) |
a65177a6 LC |
30 | #:use-module (language tree-il optimize) |
31 | #:use-module (language cps optimize) | |
4d52e0f6 | 32 | #:export (compile-files)) |
2890ad33 LC |
33 | |
34 | ;;; Commentary: | |
35 | ;;; | |
a65177a6 | 36 | ;;; Support code to compile Guile code as efficiently as possible (with 2.2). |
2890ad33 LC |
37 | ;;; |
38 | ;;; Code: | |
39 | ||
fed36328 LC |
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))) | |
2890ad33 | 50 | |
fed36328 LC |
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))))) | |
2890ad33 | 66 | |
e429566f LC |
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 | ||
2890ad33 LC |
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. | |
e429566f LC |
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 | |
2890ad33 LC |
84 | |
85 | (define (optimization-options file) | |
86 | "Return the default set of optimizations options for FILE." | |
a4d76a51 LC |
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 | ||
49143297 LC |
101 | (cond ((or (string-contains file "gnu/packages/") |
102 | (string-contains file "gnu/tests/")) | |
a0d419e6 LC |
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)) | |
a4d76a51 LC |
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)))) | |
2890ad33 LC |
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 | ||
c9405c46 LC |
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 | ||
2890ad33 LC |
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 ...) | |
c9405c46 LC |
140 | (let ((file (relative-file directory file))) |
141 | (report-load file total completed) | |
142 | (format debug-port "~%loading '~a'...~%" file) | |
2890ad33 | 143 | |
c498aaaf | 144 | (resolve-interface (file-name->module-name file)) |
2890ad33 | 145 | |
c9405c46 | 146 | (loop files (+ 1 completed))))))) |
2890ad33 LC |
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 | ||
38302bd9 LC |
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." | |
27e810c3 LC |
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)))) | |
38302bd9 LC |
173 | (newline port) |
174 | (format port "error: failed to compile '~a':~%~%" file) | |
27e810c3 LC |
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 | ||
38302bd9 LC |
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 ...))) | |
27e810c3 | 185 | |
2890ad33 LC |
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)) | |
21391f8c | 200 | (define progress 0) |
2890ad33 LC |
201 | |
202 | (define (build file) | |
203 | (with-mutex progress-lock | |
21391f8c EB |
204 | (report-compilation file total progress) |
205 | (set! progress (+ 1 progress))) | |
27e810c3 LC |
206 | |
207 | ;; Exit as soon as something goes wrong. | |
208 | (exit-on-exception | |
38302bd9 | 209 | file |
041c3c22 LC |
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)))))) | |
2890ad33 LC |
216 | |
217 | (with-augmented-search-path %load-path source-directory | |
218 | (with-augmented-search-path %load-compiled-path build-directory | |
c498aaaf | 219 | (with-fluids ((*current-warning-prefix* "")) |
12da5162 LC |
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 | ||
041c3c22 LC |
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 | ||
041c3c22 LC |
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)))))))) | |
2890ad33 | 240 | |
870677cb LC |
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 | ||
2890ad33 LC |
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: |