ui: 'with-error-handling' does not unwind the stack.
Since a07d5e558b, we've been getting
useless backtraces upon unhandled errors, like this:
Backtrace:
1 (primitive-load "/home/…/bin/guix")
In guix/ui.scm:
1953:12 0 (run-guix-command _ . _)
guix/ui.scm:1953:12: In procedure run-guix-command:
In procedure struct-vtable: Wrong type argument in position 1 (expecting struct): #f
This change finally gives us real backtraces back.
* guix/ui.scm (guard*): New macro.
(call-with-error-handling): Use it instead of 'guard'.
This commit is contained in:
Ludovic Courtès
parent
8003a5adaf
commit
a168c3e4f8
1 changed files with 154 additions and 129 deletions
283
guix/ui.scm
283
guix/ui.scm
|
|
@ -652,6 +652,23 @@ or variants of @code{~a} in the same profile.")
|
||||||
or remove one of them from the profile.")
|
or remove one of them from the profile.")
|
||||||
name1 name2)))))
|
name1 name2)))))
|
||||||
|
|
||||||
|
(cond-expand
|
||||||
|
(guile-3
|
||||||
|
;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise. To
|
||||||
|
;; preserve useful backtraces in case of unhandled errors, we want that to
|
||||||
|
;; happen before the stack has been unwound, hence 'guard*'.
|
||||||
|
(define-syntax-rule (guard* (var clauses ...) exp ...)
|
||||||
|
"This variant of SRFI-34 'guard' does not unwind the stack before
|
||||||
|
evaluating the tests and bodies of CLAUSES."
|
||||||
|
(with-exception-handler
|
||||||
|
(lambda (var)
|
||||||
|
(cond clauses ... (else (raise var))))
|
||||||
|
(lambda () exp ...)
|
||||||
|
#:unwind? #f)))
|
||||||
|
(else
|
||||||
|
(define-syntax-rule (guard* (var clauses ...) exp ...)
|
||||||
|
(guard (var clauses ...) exp ...))))
|
||||||
|
|
||||||
(define (call-with-error-handling thunk)
|
(define (call-with-error-handling thunk)
|
||||||
"Call THUNK within a user-friendly error handler."
|
"Call THUNK within a user-friendly error handler."
|
||||||
(define (port-filename* port)
|
(define (port-filename* port)
|
||||||
|
|
@ -660,143 +677,147 @@ or remove one of them from the profile.")
|
||||||
(and (not (port-closed? port))
|
(and (not (port-closed? port))
|
||||||
(port-filename port)))
|
(port-filename port)))
|
||||||
|
|
||||||
(guard (c ((package-input-error? c)
|
(guard* (c ((package-input-error? c)
|
||||||
(let* ((package (package-error-package c))
|
(let* ((package (package-error-package c))
|
||||||
(input (package-error-invalid-input c))
|
(input (package-error-invalid-input c))
|
||||||
(location (package-location package))
|
(location (package-location package))
|
||||||
(file (location-file location))
|
(file (location-file location))
|
||||||
(line (location-line location))
|
(line (location-line location))
|
||||||
(column (location-column location)))
|
(column (location-column location)))
|
||||||
(leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
|
(leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
|
||||||
file line column
|
file line column
|
||||||
(package-full-name package) input)))
|
(package-full-name package) input)))
|
||||||
((package-cross-build-system-error? c)
|
((package-cross-build-system-error? c)
|
||||||
(let* ((package (package-error-package c))
|
(let* ((package (package-error-package c))
|
||||||
(loc (package-location package))
|
(loc (package-location package))
|
||||||
(system (package-build-system package)))
|
(system (package-build-system package)))
|
||||||
(leave (G_ "~a: ~a: build system `~a' does not support cross builds~%")
|
(leave (G_ "~a: ~a: build system `~a' does not support cross builds~%")
|
||||||
(location->string loc)
|
(location->string loc)
|
||||||
(package-full-name package)
|
(package-full-name package)
|
||||||
(build-system-name system))))
|
(build-system-name system))))
|
||||||
((gexp-input-error? c)
|
((gexp-input-error? c)
|
||||||
(let ((input (package-error-invalid-input c)))
|
(let ((input (package-error-invalid-input c)))
|
||||||
(leave (G_ "~s: invalid G-expression input~%")
|
(leave (G_ "~s: invalid G-expression input~%")
|
||||||
(gexp-error-invalid-input c))))
|
(gexp-error-invalid-input c))))
|
||||||
((profile-not-found-error? c)
|
((profile-not-found-error? c)
|
||||||
(leave (G_ "profile '~a' does not exist~%")
|
(leave (G_ "profile '~a' does not exist~%")
|
||||||
(profile-error-profile c)))
|
(profile-error-profile c)))
|
||||||
((missing-generation-error? c)
|
((missing-generation-error? c)
|
||||||
(leave (G_ "generation ~a of profile '~a' does not exist~%")
|
(leave (G_ "generation ~a of profile '~a' does not exist~%")
|
||||||
(missing-generation-error-generation c)
|
(missing-generation-error-generation c)
|
||||||
(profile-error-profile c)))
|
(profile-error-profile c)))
|
||||||
((unmatched-pattern-error? c)
|
((unmatched-pattern-error? c)
|
||||||
(let ((pattern (unmatched-pattern-error-pattern c)))
|
(let ((pattern (unmatched-pattern-error-pattern c)))
|
||||||
(leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%")
|
(leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%")
|
||||||
(manifest-pattern-name pattern)
|
(manifest-pattern-name pattern)
|
||||||
(manifest-pattern-version pattern)
|
(manifest-pattern-version pattern)
|
||||||
(match (manifest-pattern-output pattern)
|
(match (manifest-pattern-output pattern)
|
||||||
("out" #f)
|
("out" #f)
|
||||||
(output output)))))
|
(output output)))))
|
||||||
((profile-collision-error? c)
|
((profile-collision-error? c)
|
||||||
(let ((entry (profile-collision-error-entry c))
|
(let ((entry (profile-collision-error-entry c))
|
||||||
(conflict (profile-collision-error-conflict c)))
|
(conflict (profile-collision-error-conflict c)))
|
||||||
(define (report-parent-entries entry)
|
(define (report-parent-entries entry)
|
||||||
(let ((parent (force (manifest-entry-parent entry))))
|
(let ((parent (force (manifest-entry-parent entry))))
|
||||||
(when (manifest-entry? parent)
|
(when (manifest-entry? parent)
|
||||||
(report-error (G_ " ... propagated from ~a@~a~%")
|
(report-error (G_ " ... propagated from ~a@~a~%")
|
||||||
(manifest-entry-name parent)
|
(manifest-entry-name parent)
|
||||||
(manifest-entry-version parent))
|
(manifest-entry-version parent))
|
||||||
(report-parent-entries parent))))
|
(report-parent-entries parent))))
|
||||||
|
|
||||||
(define (manifest-entry-output* entry)
|
(define (manifest-entry-output* entry)
|
||||||
(match (manifest-entry-output entry)
|
(match (manifest-entry-output entry)
|
||||||
("out" "")
|
("out" "")
|
||||||
(output (string-append ":" output))))
|
(output (string-append ":" output))))
|
||||||
|
|
||||||
(report-error (G_ "profile contains conflicting entries for ~a~a~%")
|
(report-error (G_ "profile contains conflicting entries for ~a~a~%")
|
||||||
(manifest-entry-name entry)
|
(manifest-entry-name entry)
|
||||||
(manifest-entry-output* entry))
|
(manifest-entry-output* entry))
|
||||||
(report-error (G_ " first entry: ~a@~a~a ~a~%")
|
(report-error (G_ " first entry: ~a@~a~a ~a~%")
|
||||||
(manifest-entry-name entry)
|
(manifest-entry-name entry)
|
||||||
(manifest-entry-version entry)
|
(manifest-entry-version entry)
|
||||||
(manifest-entry-output* entry)
|
(manifest-entry-output* entry)
|
||||||
(manifest-entry-item entry))
|
(manifest-entry-item entry))
|
||||||
(report-parent-entries entry)
|
(report-parent-entries entry)
|
||||||
(report-error (G_ " second entry: ~a@~a~a ~a~%")
|
(report-error (G_ " second entry: ~a@~a~a ~a~%")
|
||||||
(manifest-entry-name conflict)
|
(manifest-entry-name conflict)
|
||||||
(manifest-entry-version conflict)
|
(manifest-entry-version conflict)
|
||||||
(manifest-entry-output* conflict)
|
(manifest-entry-output* conflict)
|
||||||
(manifest-entry-item conflict))
|
(manifest-entry-item conflict))
|
||||||
(report-parent-entries conflict)
|
(report-parent-entries conflict)
|
||||||
(display-collision-resolution-hint c)
|
(display-collision-resolution-hint c)
|
||||||
(exit 1)))
|
(exit 1)))
|
||||||
((nar-error? c)
|
((nar-error? c)
|
||||||
(let ((file (nar-error-file c))
|
(let ((file (nar-error-file c))
|
||||||
(port (nar-error-port c)))
|
(port (nar-error-port c)))
|
||||||
(if file
|
(if file
|
||||||
(leave (G_ "corrupt input while restoring '~a' from ~s~%")
|
(leave (G_ "corrupt input while restoring '~a' from ~s~%")
|
||||||
file (or (port-filename* port) port))
|
file (or (port-filename* port) port))
|
||||||
(leave (G_ "corrupt input while restoring archive from ~s~%")
|
(leave (G_ "corrupt input while restoring archive from ~s~%")
|
||||||
(or (port-filename* port) port)))))
|
(or (port-filename* port) port)))))
|
||||||
((store-connection-error? c)
|
((store-connection-error? c)
|
||||||
(leave (G_ "failed to connect to `~a': ~a~%")
|
(leave (G_ "failed to connect to `~a': ~a~%")
|
||||||
(store-connection-error-file c)
|
(store-connection-error-file c)
|
||||||
(strerror (store-connection-error-code c))))
|
(strerror (store-connection-error-code c))))
|
||||||
((store-protocol-error? c)
|
((store-protocol-error? c)
|
||||||
;; FIXME: Server-provided error messages aren't i18n'd.
|
;; FIXME: Server-provided error messages aren't i18n'd.
|
||||||
(leave (G_ "~a~%")
|
(leave (G_ "~a~%")
|
||||||
(store-protocol-error-message c)))
|
(store-protocol-error-message c)))
|
||||||
((derivation-missing-output-error? c)
|
((derivation-missing-output-error? c)
|
||||||
(leave (G_ "reference to invalid output '~a' of derivation '~a'~%")
|
(leave (G_ "reference to invalid output '~a' of derivation '~a'~%")
|
||||||
(derivation-missing-output c)
|
(derivation-missing-output c)
|
||||||
(derivation-file-name (derivation-error-derivation c))))
|
(derivation-file-name (derivation-error-derivation c))))
|
||||||
((file-search-error? c)
|
((file-search-error? c)
|
||||||
(leave (G_ "file '~a' could not be found in these \
|
(leave (G_ "file '~a' could not be found in these \
|
||||||
directories:~{ ~a~}~%")
|
directories:~{ ~a~}~%")
|
||||||
(file-search-error-file-name c)
|
(file-search-error-file-name c)
|
||||||
(file-search-error-search-path c)))
|
(file-search-error-search-path c)))
|
||||||
((invoke-error? c)
|
((invoke-error? c)
|
||||||
(leave (G_ "program exited\
|
(leave (G_ "program exited\
|
||||||
~@[ with non-zero exit status ~a~]\
|
~@[ with non-zero exit status ~a~]\
|
||||||
~@[ terminated by signal ~a~]\
|
~@[ terminated by signal ~a~]\
|
||||||
~@[ stopped by signal ~a~]: ~s~%")
|
~@[ stopped by signal ~a~]: ~s~%")
|
||||||
(invoke-error-exit-status c)
|
(invoke-error-exit-status c)
|
||||||
(invoke-error-term-signal c)
|
(invoke-error-term-signal c)
|
||||||
(invoke-error-stop-signal c)
|
(invoke-error-stop-signal c)
|
||||||
(cons (invoke-error-program c)
|
(cons (invoke-error-program c)
|
||||||
(invoke-error-arguments c))))
|
(invoke-error-arguments c))))
|
||||||
((and (error-location? c) (message-condition? c))
|
((and (error-location? c) (message-condition? c))
|
||||||
(report-error (error-location c) (G_ "~a~%")
|
(report-error (error-location c) (G_ "~a~%")
|
||||||
(gettext (condition-message c) %gettext-domain))
|
(gettext (condition-message c) %gettext-domain))
|
||||||
(when (fix-hint? c)
|
(when (fix-hint? c)
|
||||||
(display-hint (condition-fix-hint c)))
|
(display-hint (condition-fix-hint c)))
|
||||||
(exit 1))
|
(exit 1))
|
||||||
((and (message-condition? c) (fix-hint? c))
|
((and (message-condition? c) (fix-hint? c))
|
||||||
(report-error (G_ "~a~%")
|
(report-error (G_ "~a~%")
|
||||||
(gettext (condition-message c) %gettext-domain))
|
(gettext (condition-message c) %gettext-domain))
|
||||||
(display-hint (condition-fix-hint c))
|
(display-hint (condition-fix-hint c))
|
||||||
(exit 1))
|
(exit 1))
|
||||||
|
|
||||||
;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
|
;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
|
||||||
;; compound and include a '&message'. However, that message only
|
;; compound and include a '&message'. However, that message only
|
||||||
;; contains the format string. Thus, special-case it here to
|
;; contains the format string. Thus, special-case it here to
|
||||||
;; avoid displaying a bare format string.
|
;; avoid displaying a bare format string.
|
||||||
((cond-expand
|
;;
|
||||||
(guile-3
|
;; Furthermore, use of 'guard*' ensures that the stack has not
|
||||||
((exception-predicate &exception-with-kind-and-args) c))
|
;; been unwound when we re-raise, since that would otherwise show
|
||||||
(else #f))
|
;; useless backtraces.
|
||||||
(raise c))
|
((cond-expand
|
||||||
|
(guile-3
|
||||||
|
((exception-predicate &exception-with-kind-and-args) c))
|
||||||
|
(else #f))
|
||||||
|
(raise c))
|
||||||
|
|
||||||
((message-condition? c)
|
((message-condition? c)
|
||||||
;; Normally '&message' error conditions have an i18n'd message.
|
;; Normally '&message' error conditions have an i18n'd message.
|
||||||
(leave (G_ "~a~%")
|
(leave (G_ "~a~%")
|
||||||
(gettext (condition-message c) %gettext-domain))))
|
(gettext (condition-message c) %gettext-domain))))
|
||||||
;; Catch EPIPE and the likes.
|
;; Catch EPIPE and the likes.
|
||||||
(catch 'system-error
|
(catch 'system-error
|
||||||
thunk
|
thunk
|
||||||
(lambda (key proc format-string format-args . rest)
|
(lambda (key proc format-string format-args . rest)
|
||||||
(leave (G_ "~a: ~a~%") proc
|
(leave (G_ "~a: ~a~%") proc
|
||||||
(apply format #f format-string format-args))))))
|
(apply format #f format-string format-args))))))
|
||||||
|
|
||||||
(define-syntax-rule (leave-on-EPIPE exp ...)
|
(define-syntax-rule (leave-on-EPIPE exp ...)
|
||||||
"Run EXP... in a context where EPIPE errors are caught and lead to 'exit'
|
"Run EXP... in a context where EPIPE errors are caught and lead to 'exit'
|
||||||
|
|
@ -1993,4 +2014,8 @@ and signal handling have already been set up."
|
||||||
(initialize-guix)
|
(initialize-guix)
|
||||||
(apply run-guix args))
|
(apply run-guix args))
|
||||||
|
|
||||||
|
;;; Local Variables:
|
||||||
|
;;; eval: (put 'guard* 'scheme-indent-function 2)
|
||||||
|
;;; End:
|
||||||
|
|
||||||
;;; ui.scm ends here
|
;;; ui.scm ends here
|
||||||
|
|
|
||||||
Reference in a new issue