[bug#40077] [PATCH 0/4] Inferior provide stack traces along with exceptions

[bug#40077] [PATCH 0/4] Inferior provide stack traces along with exceptions

[Ludovic Courtès]

Hello!

This patch series allows inferiors to provide stack traces when
an exception is thrown.

The wire format needed to be changed to provide that info, and thus
the protocol had to be adjusted to support both forward and backward
compatibility: a new client must be able to talk to an old ‘guix repl’,
and an old client must be able to talk to a new ‘guix repl’.  To that
end, clients now send the protocol version they support.

Note that, with these patches, stack traces are available but inferior
exceptions are not reported more nicely than before:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> (open-inferior "/home/ludo/src/guix" #:command "scripts/guix")
$1 = #<<inferior> pid: pipe socket: #<input-output: file 7f08f4404a80> close: #<procedure close-pipe (p)> version: (0 1 1) packages: #<promise #<procedure 7f08f6813040 at guix/inferior.scm:161:32 ()>> table: #<promise #<procedure 7f08f43c6240 at guix/inferior.scm:162:32 ()>>>
scheme@(guile-user)> (inferior-eval '(throw 'x 'y 'z) $1)
ice-9/boot-9.scm:1669:16: In procedure raise-exception:
ERROR:
  1. &inferior-exception:
      arguments: (x y z)
      inferior: #<<inferior> pid: pipe socket: #<input-output: string 7f08f4404a80> close: #<procedure close-pipe (p)> version: (0 1 1) packages: #<promise #<procedure 7f08f6813040 at guix/inferior.scm:161:32 ()>> table: #<promise #<procedure 7f08f43c6240 at guix/inferior.scm:162:32 ()>>>
      stack: ((#f ("ice-9/boot-9.scm" 1763 13)) (raise-exception ("ice-9/boot-9.scm" 1668 16)) (#f (#f #f #f)) (#f ("guix/repl.scm" 92 21)) (with-exception-handler ("ice-9/boot-9.scm" 1735 10)) (with-exception-handler ("ice-9/boot-9.scm" 1730 15)) (#f ("guix/repl.scm" 119 7)))

Entering a new prompt.  Type `,bt' for a backtrace or `,q' to continue.
--8<---------------cut here---------------end--------------->8---

This is left as an exercise to the reader.

Feedback welcome!

Ludo’.

Ludovic Courtès (4):
  repl: Allow clients to send their protocol version.
  inferior: Adjust to protocol (0 1).
  repl: Return stack traces along with exceptions.
  inferior: '&inferior-exception' includes a stack trace.

 guix/inferior.scm  | 24 +++++++++++--
 guix/repl.scm      | 86 ++++++++++++++++++++++++++++++++++++++--------
 tests/inferior.scm |  3 ++
 3 files changed, 97 insertions(+), 16 deletions(-)

-- 
2.25.1

[bug#40077] [PATCH 1/4] repl: Allow clients to send their protocol version.

[Ludovic Courtès]

* guix/repl.scm (send-repl-response): Add #:version.
(machine-repl): Make 'loop' an internal define with a
'version' parameter.  Pass VERSION to 'send-repl-response'.
Send (0 1) as the protocol version.
If the first element read from INPUT matches (() repl-version _ ...),
interpret it as the client's protocol version.
---
 guix/repl.scm | 36 +++++++++++++++++++++++++-----------
 1 file changed, 25 insertions(+), 11 deletions(-)

diff --git a/guix/repl.scm b/guix/repl.scm
index 0f75f9cd0b..a141003812 100644
--- a/guix/repl.scm
+++ b/guix/repl.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,9 +39,10 @@
     (one-of symbol? string? keyword? pair? null? array?
             number? boolean? char?)))
 
-(define (send-repl-response exp output)
+(define* (send-repl-response exp output
+                             #:key (version '(0 0)))
   "Write the response corresponding to the evaluation of EXP to PORT, an
-output port."
+output port.  VERSION is the client's protocol version we are targeting."
   (define (value->sexp value)
     (if (self-quoting? value)
         `(value ,value)
@@ -72,13 +73,26 @@ The protocol of this REPL is meant to be machine-readable and provides proper
 support to represent multiple-value returns, exceptions, objects that lack a
 read syntax, and so on.  As such it is more convenient and robust than parsing
 Guile's REPL prompt."
-  (write `(repl-version 0 0) output)
-  (newline output)
-  (force-output output)
-
-  (let loop ()
-    (match (read input)
+  (define (loop exp version)
+    (match exp
       ((? eof-object?) #t)
       (exp
-       (send-repl-response exp output)
-       (loop)))))
+       (send-repl-response exp output
+                           #:version version)
+       (loop (read input) version))))
+
+  (write `(repl-version 0 1) output)
+  (newline output)
+  (force-output output)
+
+  ;; In protocol version (0 0), clients would not send their supported
+  ;; protocol version.  Thus, the code below checks for two case: (1) a (0 0)
+  ;; client that directly sends an expression to evaluate, and (2) a more
+  ;; recent client that sends (() repl-version ...).  This form is chosen to
+  ;; be unambiguously distinguishable from a regular Scheme expression.
+
+  (match (read input)
+    ((() 'repl-version version ...)
+     (loop (read input) version))
+    (exp
+     (loop exp '(0 0)))))
-- 
2.25.1

[bug#40077] [PATCH 2/4] inferior: Adjust to protocol (0 1).

[Ludovic Courtès]

* guix/inferior.scm (port->inferior): For protocol (0 x ...), where x >= 1,
send the (() repl-version ...) form.
---
 guix/inferior.scm | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/guix/inferior.scm b/guix/inferior.scm
index 6b685ece30..ec8ff8ddbe 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -159,6 +159,15 @@ inferior."
      (letrec ((result (inferior 'pipe pipe close (cons 0 rest)
                                 (delay (%inferior-packages result))
                                 (delay (%inferior-package-table result)))))
+
+       ;; For protocol (0 1) and later, send the protocol version we support.
+       (match rest
+         ((n _ ...)
+          (when (>= n 1)
+            (send-inferior-request '(() repl-version 0 1) result)))
+         (_
+          #t))
+
        (inferior-eval '(use-modules (guix)) result)
        (inferior-eval '(use-modules (gnu)) result)
        (inferior-eval '(use-modules (ice-9 match)) result)
-- 
2.25.1

[bug#40077] [PATCH 3/4] repl: Return stack traces along with exceptions.

[Ludovic Courtès]

* guix/repl.scm (repl-prompt): New variable.
(stack->frames): New procedure.
(send-repl-response)[frame->sexp, handle-exception]: New procedure.
Pass HANDLE-EXCEPTION as a pre-unwind handler.
(machine-repl): Define 'tag'.  Bump protocol version to (0 1 1).
Wrap 'loop' call in 'call-with-prompt'.
---
 guix/repl.scm | 64 +++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 54 insertions(+), 10 deletions(-)

diff --git a/guix/repl.scm b/guix/repl.scm
index a141003812..0ace5976cf 100644
--- a/guix/repl.scm
+++ b/guix/repl.scm
@@ -17,6 +17,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix repl)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (send-repl-response
             machine-repl))
@@ -39,6 +41,17 @@
     (one-of symbol? string? keyword? pair? null? array?
             number? boolean? char?)))
 
+(define repl-prompt
+  ;; Current REPL prompt or #f.
+  (make-parameter #f))
+
+(define (stack->frames stack)
+  "Return STACK's frames as a list."
+  (unfold (cute >= <> (stack-length stack))
+          (cut stack-ref stack <>)
+          1+
+          0))
+
 (define* (send-repl-response exp output
                              #:key (version '(0 0)))
   "Write the response corresponding to the evaluation of EXP to PORT, an
@@ -49,6 +62,32 @@ output port.  VERSION is the client's protocol version we are targeting."
         `(non-self-quoting ,(object-address value)
                            ,(object->string value))))
 
+  (define (frame->sexp frame)
+    `(,(frame-procedure-name frame)
+      ,(match (frame-source frame)
+         ((_ (? string? file) (? integer? line) . (? integer? column))
+          (list file line column))
+         (_
+          '(#f #f #f)))))
+
+  (define (handle-exception key . args)
+    (define reply
+      (match version
+        ((0 1 (? positive?) _ ...)
+         ;; Protocol (0 1 1) and later.
+         (let ((stack (if (repl-prompt)
+                          (make-stack #t handle-exception (repl-prompt))
+                          (make-stack #t))))
+           `(exception (arguments ,key ,@(map value->sexp args))
+                       (stack ,@(map frame->sexp (stack->frames stack))))))
+        (_
+         ;; Protocol (0 0).
+         `(exception ,key ,@(map value->sexp args)))))
+
+    (write reply output)
+    (newline output)
+    (force-output output))
+
   (catch #t
     (lambda ()
       (let ((results (call-with-values
@@ -59,10 +98,8 @@ output port.  VERSION is the client's protocol version we are targeting."
                output)
         (newline output)
         (force-output output)))
-    (lambda (key . args)
-      (write `(exception ,key ,@(map value->sexp args)))
-      (newline output)
-      (force-output output))))
+    (const #t)
+    handle-exception))
 
 (define* (machine-repl #:optional
                        (input (current-input-port))
@@ -73,6 +110,9 @@ The protocol of this REPL is meant to be machine-readable and provides proper
 support to represent multiple-value returns, exceptions, objects that lack a
 read syntax, and so on.  As such it is more convenient and robust than parsing
 Guile's REPL prompt."
+  (define tag
+    (make-prompt-tag "repl-prompt"))
+
   (define (loop exp version)
     (match exp
       ((? eof-object?) #t)
@@ -81,7 +121,7 @@ Guile's REPL prompt."
                            #:version version)
        (loop (read input) version))))
 
-  (write `(repl-version 0 1) output)
+  (write `(repl-version 0 1 1) output)
   (newline output)
   (force-output output)
 
@@ -91,8 +131,12 @@ Guile's REPL prompt."
   ;; recent client that sends (() repl-version ...).  This form is chosen to
   ;; be unambiguously distinguishable from a regular Scheme expression.
 
-  (match (read input)
-    ((() 'repl-version version ...)
-     (loop (read input) version))
-    (exp
-     (loop exp '(0 0)))))
+  (call-with-prompt tag
+    (lambda ()
+      (parameterize ((repl-prompt tag))
+        (match (read input)
+          ((() 'repl-version version ...)
+           (loop (read input) version))
+          (exp
+           (loop exp '(0 0))))))
+    (const #f)))
-- 
2.25.1

[bug#40077] [PATCH 4/4] inferior: '&inferior-exception' includes a stack trace.

[Ludovic Courtès]

* guix/inferior.scm (port->inferior): Bump protocol to (0 1 1).
(&inferior-exception)[stack]: New field.
(read-repl-response): Recognize 'exception' form for protocol (0 1 1).
* tests/inferior.scm ("&inferior-exception"): Check the value returned
by 'inferior-exception-stack'.
---
 guix/inferior.scm  | 17 ++++++++++++++---
 tests/inferior.scm |  3 +++
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/guix/inferior.scm b/guix/inferior.scm
index ec8ff8ddbe..c9a5ee5129 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -66,6 +66,7 @@
             inferior-exception?
             inferior-exception-arguments
             inferior-exception-inferior
+            inferior-exception-stack
             read-repl-response
 
             inferior-packages
@@ -164,7 +165,7 @@ inferior."
        (match rest
          ((n _ ...)
           (when (>= n 1)
-            (send-inferior-request '(() repl-version 0 1) result)))
+            (send-inferior-request '(() repl-version 0 1 1) result)))
          (_
           #t))
 
@@ -211,7 +212,8 @@ equivalent.  Return #f if the inferior could not be launched."
 (define-condition-type &inferior-exception &error
   inferior-exception?
   (arguments  inferior-exception-arguments)       ;key + arguments
-  (inferior   inferior-exception-inferior))       ;<inferior> | #f
+  (inferior   inferior-exception-inferior)        ;<inferior> | #f
+  (stack      inferior-exception-stack))          ;list of (FILE COLUMN LINE)
 
 (define* (read-repl-response port #:optional inferior)
   "Read a (guix repl) response from PORT and return it as a Scheme object.
@@ -226,10 +228,19 @@ Raise '&inferior-exception' when an exception is read from PORT."
   (match (read port)
     (('values objects ...)
      (apply values (map sexp->object objects)))
+    (('exception ('arguments key objects ...)
+                 ('stack frames ...))
+     ;; Protocol (0 1 1) and later.
+     (raise (condition (&inferior-exception
+                        (arguments (cons key (map sexp->object objects)))
+                        (inferior inferior)
+                        (stack frames)))))
     (('exception key objects ...)
+     ;; Protocol (0 0).
      (raise (condition (&inferior-exception
                         (arguments (cons key (map sexp->object objects)))
-                        (inferior inferior)))))))
+                        (inferior inferior)
+                        (stack '())))))))
 
 (define (read-inferior-response inferior)
   (read-repl-response (inferior-socket inferior)
diff --git a/tests/inferior.scm b/tests/inferior.scm
index b4417d8629..2f5215920b 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -68,6 +68,9 @@
     (guard (c ((inferior-exception? c)
                (close-inferior inferior)
                (and (eq? inferior (inferior-exception-inferior c))
+                    (match (inferior-exception-stack c)
+                      (((_ (files lines columns)) ..1)
+                       (member "guix/repl.scm" files)))
                     (inferior-exception-arguments c))))
       (inferior-eval '(throw 'a 'b 'c 'd) inferior)
       'badness)))
-- 
2.25.1

bug#40077: [PATCH 0/4] Inferior provide stack traces along with exceptions

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

>   repl: Allow clients to send their protocol version.
>   inferior: Adjust to protocol (0 1).
>   repl: Return stack traces along with exceptions.
>   inferior: '&inferior-exception' includes a stack trace.

Pushed as 1dca6aaafa9f842565deab1fe7e6929f25544551.

Ludo’.