TakeV/guix
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki 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

45
guix/build/compile.scm
View file

@ -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 @@ (define-syntax-rule (with-augmented-search-path path item body ...)
(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 @@ (define completed 0)
(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))))