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