diff options
| -rw-r--r-- | guix/build/compile.scm | 45 |
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)))) |