unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [PATCH] Improve reporting of exception locations
@ 2022-09-20  2:00 Andrew Whatson
  2022-09-21 10:42 ` Maxime Devos
  0 siblings, 1 reply; 4+ messages in thread
From: Andrew Whatson @ 2022-09-20  2:00 UTC (permalink / raw)
  To: guile-devel; +Cc: Andrew Whatson

Most errors were reported as coming from boot-9.scm due to incorrect
hard-coded stack-narrowing offsets.  This patch fixes the offsets and
adds an argument to specify additional frames to skip when calling
raise-exception.

* libguile/stacks.h:
* libguile/stacks.c (scm_skip_stack_frames_fluid): New internal var.
(scm_init_stacks): Define %skip-stack-frames and initialize to 0.
* libguile/continuations.c (print_exception_and_backtrace):
* libguile/throw.c (handler_message): Use scm_skip_stack_frames_fluid to
accurately trim the stack.
* module/ice-9/boot-9.scm (raise-exception): Add #:skip-frames kwarg.
Call handler with %skip-stack-frames set appropriately.
(throw): Call raise-exception with #:skip-frames 1.
* module/ice-9/threads.scm (call-with-new-thread):
* module/system/repl/error-handling.scm (call-with-error-handling): Use
%skip-stack-frames to accurately trim the stack.
---
 libguile/continuations.c              | 12 +++++++-----
 libguile/stacks.c                     |  5 +++++
 libguile/stacks.h                     |  1 +
 libguile/throw.c                      | 15 +++++++--------
 module/ice-9/boot-9.scm               | 19 +++++++++++++++----
 module/ice-9/threads.scm              |  6 +++---
 module/system/repl/error-handling.scm | 10 ++++++----
 7 files changed, 44 insertions(+), 24 deletions(-)

diff --git a/libguile/continuations.c b/libguile/continuations.c
index b8b6e1dca..227be46f9 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -38,6 +38,7 @@
 #include "debug.h"
 #include "dynstack.h"
 #include "eval.h"
+#include "fluids.h"
 #include "gsubr.h"
 #include "init.h"
 #include "instructions.h"
@@ -395,12 +396,13 @@ should_print_backtrace (SCM tag, SCM stack)
 static void
 print_exception_and_backtrace (SCM port, SCM tag, SCM args)
 {
-  SCM stack, frame;
+  SCM skip, stack, frame;
 
-  /* We get here via a throw to a catch-all.  In that case there is the
-     throw frame active, and this catch closure, so narrow by two
-     frames.  */
-  stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+  /* We get here via a throw to a catch-all.  Narrow by the number of
+     frames specified in %skip-stack-frames to get an accurate error
+     location.  */
+  skip = scm_fluid_ref (scm_skip_stack_frames_fluid);
+  stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (skip));
   frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
 
   if (should_print_backtrace (tag, stack))
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 36842920b..5c7d57a06 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -48,6 +48,8 @@
 #include "stacks.h"
 
 
+SCM scm_skip_stack_frames_fluid;
+
 static SCM scm_sys_stacks;
 
 \f
@@ -473,5 +475,8 @@ scm_init_stacks ()
                                     SCM_UNDEFINED);
   scm_set_struct_vtable_name_x (scm_stack_type,
 				scm_from_utf8_symbol ("stack"));
+
+  scm_skip_stack_frames_fluid = scm_make_fluid_with_default (SCM_INUM0);
+  scm_c_define ("%skip-stack-frames", scm_skip_stack_frames_fluid);
 #include "stacks.x"
 }
diff --git a/libguile/stacks.h b/libguile/stacks.h
index 25ece853a..39d0433ac 100644
--- a/libguile/stacks.h
+++ b/libguile/stacks.h
@@ -59,6 +59,7 @@ SCM_API SCM scm_stack_id (SCM stack);
 SCM_API SCM scm_stack_ref (SCM stack, SCM i);
 SCM_API SCM scm_stack_length (SCM stack);
 
+SCM_INTERNAL SCM scm_skip_stack_frames_fluid;
 SCM_INTERNAL void scm_init_stacks (void);
 
 #endif  /* SCM_STACKS_H */
diff --git a/libguile/throw.c b/libguile/throw.c
index e837abe89..468ed0241 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -366,16 +366,15 @@ should_print_backtrace (SCM tag, SCM stack)
 static void
 handler_message (void *handler_data, SCM tag, SCM args)
 {
-  SCM p, stack, frame;
+  SCM p, skip, stack, frame;
 
   p = scm_current_error_port ();
-  /* Usually we get here via a throw to a catch-all.  In that case
-     there is the throw frame active, and the catch closure, so narrow by
-     two frames.  It is possible for a user to invoke
-     scm_handle_by_message directly, though, so it could be this
-     narrows too much.  We'll have to see how this works out in
-     practice.  */
-  stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+  /* Usually we get here via a throw to a catch-all, though it is
+     possible for a user to invoke scm_handle_by_message directly.
+     Narrow by the number of frames specified in %skip-stack-frames to
+     get an accurate error location.  */
+  skip = scm_fluid_ref (scm_skip_stack_frames_fluid);
+  stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (skip));
   frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
 
   if (should_print_backtrace (tag, stack))
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a46145ed5..f5080fe2e 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1628,7 +1628,7 @@ exception that is an instance of @var{rtd}."
                          (exception-kind exn) (exception-args exn))
         (primitive-exit 1))))
 
-    (define* (raise-exception exn #:key (continuable? #f))
+    (define* (raise-exception exn #:key (continuable? #f) (skip-frames 0))
       "Raise an exception by invoking the current exception handler on
 @var{exn}. The handler is called with a continuation whose dynamic
 environment is that of the call to @code{raise}, except that the current
@@ -1638,7 +1638,14 @@ called was installed.
 If @var{continuable?} is true, the handler is invoked in tail position
 relative to the @code{raise-exception} call.  Otherwise if the handler
 returns, a non-continuable exception of type @code{&non-continuable} is
-raised in the same dynamic environment as the handler."
+raised in the same dynamic environment as the handler.
+
+The @var{skip-frames} argument can be used to specify a number of
+additional stack frames to skip when determining the error location.
+This is useful for helper functions which raise an exception but
+shouldn't be reported as the source of the error.  The default value of
+0 will treat the caller of @code{raise-exception} as the source of the
+error."
       (define (capture-current-exception-handlers)
         ;; FIXME: This is quadratic.
         (let lp ((depth 0))
@@ -1677,7 +1684,11 @@ raised in the same dynamic environment as the handler."
                (else
                 (lp handlers)))))
            (else
-            (with-fluids ((%active-exception-handlers handlers))
+            (with-fluids ((%active-exception-handlers handlers)
+                          ;; Calling raise-exception adds 3 frames to
+                          ;; the stack; record this so the handler can
+                          ;; determine the correct error location.
+                          (%skip-stack-frames (+ 3 skip-frames)))
               (cond
                (continuable?
                 (handler exn))
@@ -1761,7 +1772,7 @@ If there is no handler at all, Guile prints an error and then exits."
       (unless (symbol? key)
         (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
                (list 1 key) (list key)))
-      (raise-exception (make-exception-from-throw key args)))
+      (raise-exception (make-exception-from-throw key args) #:skip-frames 1))
 
     (define (with-throw-handler k thunk pre-unwind-handler)
       "Add @var{handler} to the dynamic context as a throw handler
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index c42bd266f..c2fc155c1 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -134,9 +134,9 @@ Once @var{thunk} or @var{handler} returns, the return value is made the
           (lambda () (%start-stack 'thread thunk))
           (lambda _ (values))
           (lambda (key . args)
-            ;; Narrow by three: the dispatch-exception,
-            ;; this thunk, and make-stack.
-            (let ((stack (make-stack #t 3)))
+            ;; Narrow by two extra frames: this thunk, and make-stack.
+            (let* ((skip (+ 2 (fluid-ref %skip-stack-frames)))
+                   (stack (make-stack #t skip)))
               (false-if-exception
                (begin
                  (when stack
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index 8d5a8a5f0..f9f8b1416 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -135,9 +135,9 @@
                                 (cdr (fluid-ref %stacks))))
                       (stack (narrow-stack->vector
                               (make-stack #t)
-                              ;; Cut three frames from the top of the stack:
-                              ;; make-stack, this one, and the throw handler.
-                              3
+                              ;; Cut two extra frames from the top of the stack:
+                              ;; make-stack, and this one.
+                              (+ 2 (fluid-ref %skip-stack-frames))
                               ;; Narrow the end of the stack to the most recent
                               ;; start-stack.
                               tag
@@ -165,7 +165,9 @@
                       (frames (narrow-stack->vector
                                (make-stack #t)
                                ;; Narrow as above, for the debugging case.
-                               3 tag 0 (and tag 1))))
+                               (+ 2 (fluid-ref %skip-stack-frames))
+                               tag
+                               0 (and tag 1))))
                  (with-saved-ports (lambda () (print-frames frames)))
                  (report-error key args)
                  (if #f #f)))))
-- 
2.37.3




^ permalink raw reply related	[flat|nested] 4+ messages in thread

* Re: [PATCH] Improve reporting of exception locations
  2022-09-20  2:00 [PATCH] Improve reporting of exception locations Andrew Whatson
@ 2022-09-21 10:42 ` Maxime Devos
  2022-09-21 10:54   ` Maxime Devos
  2022-09-22 14:06   ` Andrew Whatson
  0 siblings, 2 replies; 4+ messages in thread
From: Maxime Devos @ 2022-09-21 10:42 UTC (permalink / raw)
  To: Andrew Whatson, guile-devel


[-- Attachment #1.1.1: Type: text/plain, Size: 689 bytes --]



On 20-09-2022 04:00, Andrew Whatson wrote:
> Most errors were reported as coming from boot-9.scm due to incorrect
> hard-coded stack-narrowing offsets.  This patch fixes the offsets and
> adds an argument to specify additional frames to skip when calling
> raise-exception.

Do you have some test cases, to

   (1) avoid breaking things again with future changes
   (2) and show that this patch is correct?

There recent-ish was a bug report about exception handling (on IRC), it 
would be a unfortunate if whatever the fix for that turned out to be, 
causes the reporting to be wrong again -- a few test cases for this 
patch could prevent that.

Greetings,
Maxime.

[-- Attachment #1.1.2: OpenPGP public key --]
[-- Type: application/pgp-keys, Size: 929 bytes --]

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 236 bytes --]

^ permalink raw reply	[flat|nested] 4+ messages in thread

* Re: [PATCH] Improve reporting of exception locations
  2022-09-21 10:42 ` Maxime Devos
@ 2022-09-21 10:54   ` Maxime Devos
  2022-09-22 14:06   ` Andrew Whatson
  1 sibling, 0 replies; 4+ messages in thread
From: Maxime Devos @ 2022-09-21 10:54 UTC (permalink / raw)
  To: Andrew Whatson, guile-devel


[-- Attachment #1.1.1: Type: text/plain, Size: 383 bytes --]



On 21-09-2022 12:42, Maxime Devos wrote:
> There recent-ish was a bug report about exception handling (on IRC), it 
> would be a unfortunate if whatever the fix for that turned out to be, 
> causes the reporting to be wrong again -- a few test cases for this 
> patch could prevent that.

Correction: turned -> turns, IIUC it hasn't been fixed yet.

Greetings,
Maxime.

[-- Attachment #1.1.2: OpenPGP public key --]
[-- Type: application/pgp-keys, Size: 929 bytes --]

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 236 bytes --]

^ permalink raw reply	[flat|nested] 4+ messages in thread

* Re: [PATCH] Improve reporting of exception locations
  2022-09-21 10:42 ` Maxime Devos
  2022-09-21 10:54   ` Maxime Devos
@ 2022-09-22 14:06   ` Andrew Whatson
  1 sibling, 0 replies; 4+ messages in thread
From: Andrew Whatson @ 2022-09-22 14:06 UTC (permalink / raw)
  To: Maxime Devos; +Cc: guile-devel

Maxime Devos <maximedevos@telenet.be> wrote:
>
> Do you have some test cases, to
>
>    (1) avoid breaking things again with future changes
>    (2) and show that this patch is correct?
>
> There recent-ish was a bug report about exception handling (on IRC), it
> would be a unfortunate if whatever the fix for that turned out to be,
> causes the reporting to be wrong again -- a few test cases for this
> patch could prevent that.

Yes, very good point, I'll put together some test coverage next week.

Thanks for the review!



^ permalink raw reply	[flat|nested] 4+ messages in thread

end of thread, other threads:[~2022-09-22 14:06 UTC | newest]

Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-09-20  2:00 [PATCH] Improve reporting of exception locations Andrew Whatson
2022-09-21 10:42 ` Maxime Devos
2022-09-21 10:54   ` Maxime Devos
2022-09-22 14:06   ` Andrew Whatson

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).