summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-05-01 15:26:16 +0200
committerLudovic Courtès <ludo@gnu.org>2018-05-01 16:01:39 +0200
commit27e810c3e8707216c8b1b44e3d012cb0547b13d3 (patch)
tree0ceb7c9f68cb929ad4206b901e2ed5aed8ffa7fc /guix/build
parent3dafde0d67bfce072279714d8a50ac358b6cb70f (diff)
compile: Exit when an exception is thrown.
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.
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/compile.scm45
1 files changed, 35 insertions, 10 deletions
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index 1bd8c60fe5..7b6e31107c 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -1,5 +1,5 @@
;;; 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>
;;;
;;; This file is part of GNU Guix.
@@ -120,6 +120,28 @@ front."
(lambda ()
(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
#:key
(host %host-type)
@@ -139,15 +161,18 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
(define (build file)
(with-mutex progress-lock
(report-compilation file total completed))
- (with-fluids ((*current-warning-prefix* ""))
- (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)))))))
+
+ ;; Exit as soon as something goes wrong.
+ (exit-on-exception
+ (with-fluids ((*current-warning-prefix* ""))
+ (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))))