;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build compile)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 threads)
#:use-module (guix build utils)
#:use-module (language tree-il optimize)
#:use-module (language cps optimize)
- #:export (%default-optimizations
- %lightweight-optimizations
- compile-files))
+ #:export (compile-files))
;;; Commentary:
;;;
;;;
;;; Code:
-(define %default-optimizations
- ;; Default optimization options (equivalent to -O2 on Guile 2.2).
- (append (tree-il-default-optimization-options)
- (cps-default-optimization-options)))
-
-(define %lightweight-optimizations
- ;; Lightweight optimizations (like -O0, but with partial evaluation).
- (let loop ((opts %default-optimizations)
- (result '()))
- (match opts
- (() (reverse result))
- ((#:partial-eval? _ rest ...)
- (loop rest `(#t #:partial-eval? ,@result)))
- ((kw _ rest ...)
- (loop rest `(#f ,kw ,@result))))))
+(define optimizations-for-level
+ (or (and=> (false-if-exception
+ (resolve-interface '(system base optimize)))
+ (lambda (iface)
+ (module-ref iface 'optimizations-for-level))) ;Guile 3.0
+ (let () ;Guile 2.2
+ (define %default-optimizations
+ ;; Default optimization options (equivalent to -O2 on Guile 2.2).
+ (append (tree-il-default-optimization-options)
+ (cps-default-optimization-options)))
+
+ (define %lightweight-optimizations
+ ;; Lightweight optimizations (like -O0, but with partial evaluation).
+ (let loop ((opts %default-optimizations)
+ (result '()))
+ (match opts
+ (() (reverse result))
+ ((#:partial-eval? _ rest ...)
+ (loop rest `(#t #:partial-eval? ,@result)))
+ ((kw _ rest ...)
+ (loop rest `(#f ,kw ,@result))))))
+
+ (lambda (level)
+ (if (<= level 1)
+ %lightweight-optimizations
+ %default-optimizations)))))
+
+(define (supported-warning-type? type)
+ "Return true if TYPE, a symbol, denotes a supported warning type."
+ (find (lambda (warning-type)
+ (eq? type (warning-type-name warning-type)))
+ %warning-types))
(define %warnings
;; FIXME: 'format' is missing because it reports "non-literal format
;; strings" due to the fact that we use 'G_' instead of '_'. We'll need
;; help from Guile to solve this.
- '(unsupported-warning unbound-variable arity-mismatch
- macro-use-before-definition)) ;new in 2.2
+ (let ((optional (lambda (type)
+ (if (supported-warning-type? type)
+ (list type)
+ '()))))
+ `(unbound-variable arity-mismatch
+ macro-use-before-definition ;new in 2.2
+ ,@(optional 'shadowed-toplevel)))) ;new in 2.2.5
(define (optimization-options file)
"Return the default set of optimizations options for FILE."
- (if (string-contains file "gnu/packages/")
- %lightweight-optimizations ;build faster
- '()))
+ (define (strip-option option lst)
+ (let loop ((lst lst)
+ (result '()))
+ (match lst
+ (()
+ (reverse result))
+ ((kw value rest ...)
+ (if (eq? kw option)
+ (append (reverse result) rest)
+ (loop rest (cons* value kw result)))))))
+
+ (define (override-option option value lst)
+ `(,option ,value ,@(strip-option option lst)))
+
+ (cond ((or (string-contains file "gnu/packages/")
+ (string-contains file "gnu/tests/"))
+ ;; Use '-O1' to have partial evaluation and primitive inlining so we
+ ;; can honor the "macro writer's bill of rights".
+ (optimizations-for-level 1))
+ ((string-contains file "gnu/services/")
+ ;; '-O2 -Ono-letrectify' compiles about ~20% faster than '-O2' for
+ ;; large files like gnu/services/mail.scm.
+ (override-option #:letrectify? #f
+ (optimizations-for-level 2)))
+ (else
+ (optimizations-for-level 3))))
(define (scm->go file)
"Strip the \".scm\" suffix from FILE, and append \".go\"."
(lambda ()
(set! path initial-value)))))
-(define (call/exit-on-exception thunk)
- "Evaluate THUNK and exit right away if an exception is thrown."
+(define (call/exit-on-exception file thunk)
+ "Evaluate THUNK and exit right away if an exception is thrown. Report FILE
+as the file that was being compiled when the exception was thrown."
(catch #t
thunk
(const #f)
(stack (make-stack #t))
(depth (stack-length stack))
(frame (and (> depth 1) (stack-ref stack 1))))
+ (newline port)
+ (format port "error: failed to compile '~a':~%~%" file)
(false-if-exception (display-backtrace stack port))
(print-exception port frame key args)))
;; Don't go any further.
(primitive-exit 1))))
-(define-syntax-rule (exit-on-exception exp ...)
- "Evaluate EXP and exit if an exception is thrown."
- (call/exit-on-exception (lambda () exp ...)))
+(define-syntax-rule (exit-on-exception file exp ...)
+ "Evaluate EXP and exit if an exception is thrown. Report FILE as the faulty
+file when an exception is thrown."
+ (call/exit-on-exception file (lambda () exp ...)))
(define* (compile-files source-directory build-directory files
#:key
files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
(define progress-lock (make-mutex))
(define total (length files))
- (define completed 0)
+ (define progress 0)
(define (build file)
(with-mutex progress-lock
- (report-compilation file total completed))
+ (report-compilation file total progress)
+ (set! progress (+ 1 progress)))
;; Exit as soon as something goes wrong.
(exit-on-exception
- (with-target host
- (lambda ()
- (let ((relative (relative-file source-directory file)))
- (compile-file file
- #:output-file (string-append build-directory "/"
- (scm->go relative))
- #:opts (append warning-options
- (optimization-options relative)))))))
- (with-mutex progress-lock
- (set! completed (+ 1 completed))))
+ file
+ (let ((relative (relative-file source-directory file)))
+ (compile-file file
+ #:output-file (string-append build-directory "/"
+ (scm->go relative))
+ #:opts (append warning-options
+ (optimization-options relative))))))
(with-augmented-search-path %load-path source-directory
(with-augmented-search-path %load-compiled-path build-directory
(with-fluids ((*current-warning-prefix* ""))
-
- ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all
- ;; of FILES.
- (load-files source-directory files
- #:report-load report-load
- #:debug-port debug-port)
-
- ;; Make sure compilation related modules are loaded before starting to
- ;; compile files in parallel.
+ ;; Make sure the compiler's modules are loaded before 'with-target'
+ ;; (since 'with-target' influences the .go loader), and before
+ ;; starting to compile files in parallel.
(compile #f)
- ;; XXX: Don't use too many workers to work around the insane memory
- ;; requirements of the compiler in Guile 2.2.2:
- ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
- (n-par-for-each (min workers 8) build files)
+ (with-target host
+ (lambda ()
+ ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first
+ ;; load all of FILES.
+ (load-files source-directory files
+ #:report-load report-load
+ #:debug-port debug-port)
+
+ ;; XXX: Don't use too many workers to work around the insane
+ ;; memory requirements of the compiler in Guile 2.2.2:
+ ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
+ (n-par-for-each (min workers 8) build files)
- (unless (zero? total)
- (report-compilation #f total total))))))
+ (unless (zero? total)
+ (report-compilation #f total total))))))))
(eval-when (eval load)
(when (and (string=? "2" (major-version))