me/guix
Archived
1
0
Fork 0
Code Activity

compile: Exit when an exception is thrown.

Browse source 
Previously we could end up with only a subset of the modules built.
Fixes <https://bugs.gnu.org/31329>.

* guix/build/compile.scm (call/exit-on-exception): New procedure.
(exit-on-exception): New macro.
(compile-files): Use it.
This commit is contained in:
Ludovic Courtès 2018-05-01 15:26:16 +02:00
parent 3dafde0d67
commit 27e810c3e8
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 35 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
guix/build/compile.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -120,6 +120,28 @@ front."
(lambda () (lambda ()
(set! path initial-value))))) (set! path initial-value)))))
(define (call/exit-on-exception thunk)
"Evaluate THUNK and exit right away if an exception is thrown."
(catch #t
thunk
(const #f)
(lambda (key . args)
(false-if-exception
;; Duplicate stderr to avoid thread-safety issues.
(let* ((port (duplicate-port (current-error-port) "w0"))
(stack (make-stack #t))
(depth (stack-length stack))
(frame (and (> depth 1) (stack-ref stack 1))))
(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* (compile-files source-directory build-directory files (define* (compile-files source-directory build-directory files
#:key #:key
(host %host-type) (host %host-type)
@ -139,6 +161,9 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
(define (build file) (define (build file)
(with-mutex progress-lock (with-mutex progress-lock
(report-compilation file total completed)) (report-compilation file total completed))
;; Exit as soon as something goes wrong.
(exit-on-exception
(with-fluids ((*current-warning-prefix* "")) (with-fluids ((*current-warning-prefix* ""))
(with-target host (with-target host
(lambda () (lambda ()
@ -147,7 +172,7 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
#:output-file (string-append build-directory "/" #:output-file (string-append build-directory "/"
(scm->go relative)) (scm->go relative))
#:opts (append warning-options #:opts (append warning-options
(optimization-options relative))))))) (optimization-options relative))))))))
(with-mutex progress-lock (with-mutex progress-lock
(set! completed (+ 1 completed)))) (set! completed (+ 1 completed))))