unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [DRAFT] Improve reporting of exception locations
@ 2022-10-12  6:35 Andrew Whatson
  2022-10-12  6:42 ` Andrew Whatson
  2022-10-12 19:16 ` Maxime Devos
  0 siblings, 2 replies; 3+ messages in thread
From: Andrew Whatson @ 2022-10-12  6:35 UTC (permalink / raw)
  To: guile-devel

Hello guile-dev!

I'm working on a revised patch to improve the reporting of exception
locations, after last month's initial flawed attempt.

The new patch takes the more radical approach of capturing the stack
when an exception is created, including it as part of the compound
exception object.  This should ensure that we capture a correctly
trimmed stack, while avoiding the complexities of pre-unwind handlers.
This is similar to other dynamic languages where it's common to bundle
stack info with exception objects.

This approach will probably have a negative impact on code which is
sensitive to the performance of exception creation; capturing the
stack is more expensive than NOT capturing it.  Is this something that
we need to be concerned about?

I'm still working on integrating these changes into Guile, but thought
it's worth getting early feedback on this one.

Patch to follow!

Cheers,
Andrew



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

* [DRAFT] Improve reporting of exception locations
  2022-10-12  6:35 [DRAFT] Improve reporting of exception locations Andrew Whatson
@ 2022-10-12  6:42 ` Andrew Whatson
  2022-10-12 19:16 ` Maxime Devos
  1 sibling, 0 replies; 3+ messages in thread
From: Andrew Whatson @ 2022-10-12  6:42 UTC (permalink / raw)
  To: guile-devel; +Cc: Andrew Whatson

TODO: use exception-stack in other error handlers
TODO: print-exception variant for exception objects
TODO: test cases for other kinds of errors

* module/ice-9/exceptions.scm (&stack): New exception type.
(convert-guile-exception): Capture the stack when creating an exception.
* module/system/repl/error-handling.scm (call-with-error-handling): Use
the exception stack if available.
* test-suite/Makefile.am (SCM_TESTS): Add sample code.
* test-suite/tests/exceptions.test ("exception location"): New tests.
* test-suite/tests/exceptions/error.scm:
* test-suite/tests/exceptions/error-with-throw-handler-1.scm:
* test-suite/tests/exceptions/error-with-throw-handler-2.scm:
* test-suite/tests/exceptions/error-with-throw-handler-3.scm:
Sample code for exception location tests.
---
 module/ice-9/exceptions.scm                   |   8 +-
 module/system/repl/error-handling.scm         | 153 ++++++++++--------
 test-suite/Makefile.am                        |   5 +
 test-suite/tests/exceptions.test              |  48 +++++-
 .../exceptions/error-with-throw-handler-1.scm |   6 +
 .../exceptions/error-with-throw-handler-2.scm |  11 ++
 .../exceptions/error-with-throw-handler-3.scm |  16 ++
 test-suite/tests/exceptions/error.scm         |   1 +
 8 files changed, 183 insertions(+), 65 deletions(-)
 create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-1.scm
 create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-2.scm
 create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-3.scm
 create mode 100644 test-suite/tests/exceptions/error.scm

diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm
index 143e7aa3e..207c79e2a 100644
--- a/module/ice-9/exceptions.scm
+++ b/module/ice-9/exceptions.scm
@@ -48,6 +48,7 @@
             make-exception-with-message
             exception-with-message?
             exception-message
+            exception-stack
 
             &warning
             make-warning
@@ -154,6 +155,10 @@
   make-exception-with-origin exception-with-origin?
   (origin exception-origin))
 
+(define-exception-type &stack &exception
+  make-exception-with-stack exception-with-stack?
+  (stack exception-stack))
+
 (define-exception-type-procedures &non-continuable &programming-error
   make-non-continuable-error
   non-continuable-error?)
@@ -198,7 +203,8 @@
   (let ((converter (assv-ref guile-exception-converters key)))
     (make-exception (or (and converter (converter key args))
                         (default-guile-exception-converter key args))
-                    (make-exception-with-kind-and-args key args))))
+                    (make-exception-with-kind-and-args key args)
+                    (make-exception-with-stack (make-stack #t 4)))))
 
 (define (raise-continuable obj)
   (raise-exception obj #:continuable? #t))
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index 8d5a8a5f0..e2a2458c0 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -23,6 +23,7 @@
   #:use-module (system base pmatch)
   #:use-module (system vm trap-state)
   #:use-module (system repl debug)
+  #:use-module (ice-9 exceptions)
   #:use-module (ice-9 format)
   #:export (call-with-error-handling
             with-error-handling))
@@ -101,83 +102,109 @@
          (run-hook after-error-hook)
          (force-output err))))
 
-    (catch #t
-      (lambda () 
-        (with-default-trap-handler le-trap-handler
-          (lambda () (%start-stack #t thunk))))
-
+    (define post-error-handler
       (case post-error
         ((report)
-         (lambda (key . args)
-           (if (memq key pass-keys)
-               (apply throw key args)
-               (begin
-                 (report-error key args)
-                 (if #f #f)))))
+         (lambda (exn)
+           (let ((key (exception-kind exn))
+                 (args (exception-args exn)))
+             (when (memq key pass-keys)
+               (raise-exception exn))
+             (report-error key args)
+             (if #f #f))))
         ((catch)
-         (lambda (key . args)
-           (when (memq key pass-keys)
-             (apply throw key args))
-           (when (memq key report-keys)
-             (report-error key args))
-           (if #f #f)))
+         (lambda (exn)
+           (let ((key (exception-kind exn))
+                 (args (exception-args exn)))
+             (when (memq key pass-keys)
+               (raise-exception exn))
+             (when (memq key report-keys)
+               (report-error key args))
+             (if #f #f))))
         (else
          (if (procedure? post-error)
-             (lambda (k . args)
-               (apply (if (memq k pass-keys) throw post-error) k args))
-             (error "Unknown post-error strategy" post-error))))
-
+             (lambda (exn)
+               (let ((key (exception-kind exn))
+                     (args (exception-args exn)))
+                 (when (memq key pass-keys)
+                   (raise-exception exn))
+                 (apply post-error key args)))
+             (error "Unknown post-error strategy" post-error)))))
+
+    (define on-error-handler
       (case on-error
         ((debug)
-         (lambda (key . args)
-           (if (not (memq key pass-keys))
-               (let* ((tag (and (pair? (fluid-ref %stacks))
-                                (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
-                              ;; Narrow the end of the stack to the most recent
-                              ;; start-stack.
-                              tag
-                              ;; And one more frame, because %start-stack invoking
-                              ;; the start-stack thunk has its own frame too.
-                              0 (and tag 1)))
-                      (error-msg (error-string stack key args))
-                      (debug (make-debug stack 0 error-msg)))
-                 (with-saved-ports
-                  (lambda ()
-                    (format #t "~a~%" error-msg)
-                    (format #t "Entering a new prompt.  ")
-                    (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
-                    ((@ (system repl repl) start-repl) #:debug debug)))))))
+         (lambda (exn)
+           (let ((key (exception-kind exn))
+                 (args (exception-args exn)))
+             (if (not (memq key pass-keys))
+                 (let* ((tag (and (pair? (fluid-ref %stacks))
+                                  (cdr (fluid-ref %stacks))))
+                        (stack (or (exception-stack exn)
+                                   ;; Cut three frames from the top of the stack:
+                                   ;; make-stack, this one, and the throw handler.
+                                   (make-stack #t 3)))
+                        (stack (narrow-stack->vector
+                                stack
+                                ;; Narrow the end of the stack to the most recent
+                                ;; start-stack.
+                                0 tag
+                                ;; And one more frame, because %start-stack invoking
+                                ;; the start-stack thunk has its own frame too.
+                                0 (and tag 1)))
+                        (error-msg (error-string stack key args))
+                        (debug (make-debug stack 0 error-msg)))
+                   (with-saved-ports
+                    (lambda ()
+                      (format #t "~a~%" error-msg)
+                      (format #t "Entering a new prompt.  ")
+                      (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+                      ((@ (system repl repl) start-repl) #:debug debug))))))))
         ((report)
-         (lambda (key . args)
-           (unless (memq key pass-keys)
-             (report-error key args))
-           (if #f #f)))
+         (lambda (exn)
+           (let ((key (exception-kind exn))
+                 (args (exception-args exn)))
+             (unless (memq key pass-keys)
+               (report-error key args))
+             (if #f #f))))
         ((backtrace)
-         (lambda (key . args)
-           (if (not (memq key pass-keys))
-               (let* ((tag (and (pair? (fluid-ref %stacks))
-                                (cdr (fluid-ref %stacks))))
-                      (frames (narrow-stack->vector
-                               (make-stack #t)
-                               ;; Narrow as above, for the debugging case.
-                               3 tag 0 (and tag 1))))
-                 (with-saved-ports (lambda () (print-frames frames)))
-                 (report-error key args)
-                 (if #f #f)))))
+         (lambda (exn)
+           (let ((key (exception-kind exn))
+                 (args (exception-args exn)))
+             (if (not (memq key pass-keys))
+                 (let* ((tag (and (pair? (fluid-ref %stacks))
+                                  (cdr (fluid-ref %stacks))))
+                        (frames (narrow-stack->vector
+                                 (make-stack #t)
+                                 ;; Narrow as above, for the debugging case.
+                                 3 tag 0 (and tag 1))))
+                   (with-saved-ports (lambda () (print-frames frames)))
+                   (report-error key args)
+                   (if #f #f))))))
         ((pass)
-         (lambda (key . args)
+         (lambda (exn)
            ;; fall through to rethrow
            #t))
         (else
          (if (procedure? on-error)
-             (lambda (k . args)
-               (apply (if (memq k pass-keys) throw on-error) k args))
-             (error "Unknown on-error strategy" on-error)))))))
+             (lambda (exn)
+               (let ((key (exception-kind exn))
+                     (args (exception-args exn)))
+                 (when (memq k pass-keys)
+                   (raise-exception exn))
+                 (apply on-error key args)))
+             (error "Unknown on-error strategy" on-error)))))
+
+    (with-exception-handler post-error-handler
+      (lambda ()
+        (with-exception-handler
+            (lambda (exn)
+              (on-error-handler exn)
+              (raise-exception exn))
+          (lambda ()
+            (with-default-trap-handler le-trap-handler
+              (lambda () (%start-stack #t thunk))))))
+      #:unwind? #t)))
 
 (define-syntax-rule (with-error-handling form)
   (call-with-error-handling (lambda () form)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 35f264195..fb44e2841 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -54,6 +54,11 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/eval.test			\
 	    tests/eval-string.test		\
 	    tests/exceptions.test		\
+	    tests/exceptions.test		\
+	    tests/exceptions/error.scm          \
+	    tests/exceptions/error-with-throw-handler-1.scm \
+	    tests/exceptions/error-with-throw-handler-2.scm \
+	    tests/exceptions/error-with-throw-handler-3.scm \
 	    tests/fdes-finalizers.test		\
 	    tests/filesys.test			\
 	    tests/fluids.test			\
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index 291e10e26..66b7cfbdb 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -17,7 +17,8 @@
 
 
 (define-module (test-suite exceptions)
-  #:use-module (test-suite lib))
+  #:use-module (test-suite lib)
+  #:use-module (ice-9 exceptions))
 
 (define-syntax-parameter push
   (lambda (stx)
@@ -392,3 +393,48 @@
       (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar))))
              (thunk2 (catch* 'bar (lambda () (thunk1)))))
         (thunk2))))
+
+(with-test-prefix "exception location"
+  (define (test-file filename)
+    (string-append
+     (dirname (current-filename)) "/" filename))
+
+  (define (try-load filename)
+    (with-exception-handler values
+      (lambda ()
+        (load filename)
+        #f) ;; success is failure
+      #:unwind? #t))
+
+  (define (check-location expected)
+    (lambda (exn)
+      (pk exn)
+      (let* ((key (exception-kind exn))
+             (args (exception-args exn))
+             (stack (exception-stack exn))
+             (frame (and stack (stack-ref stack 0)))
+             (message (call-with-output-string
+                        (lambda (port)
+                          (print-exception port frame key args)))))
+        ;; (when stack
+        ;;   (display-backtrace stack (current-warning-port)))
+        ;; (format (current-warning-port)
+        ;;         "\n;;; message: ~s\n;;; expected: ~s\n\n"
+        ;;         message expected)
+        (number? (string-contains message expected)))))
+
+  (pass-if "error"
+    (and=> (try-load (test-file "exceptions/error.scm"))
+           (check-location "exceptions/error.scm:1")))
+
+  (pass-if "error with one throw handler"
+    (and=> (try-load (test-file "exceptions/error-with-throw-handler-1.scm"))
+           (check-location "exceptions/error-with-throw-handler-1.scm:3")))
+
+  (pass-if "error with two throw handlers"
+    (and=> (try-load (test-file "exceptions/error-with-throw-handler-2.scm"))
+           (check-location "exceptions/error-with-throw-handler-2.scm:5")))
+
+  (pass-if "error with three throw handlers"
+    (and=> (try-load (test-file "exceptions/error-with-throw-handler-3.scm"))
+           (check-location "exceptions/error-with-throw-handler-3.scm:7"))))
diff --git a/test-suite/tests/exceptions/error-with-throw-handler-1.scm b/test-suite/tests/exceptions/error-with-throw-handler-1.scm
new file mode 100644
index 000000000..4acaa7256
--- /dev/null
+++ b/test-suite/tests/exceptions/error-with-throw-handler-1.scm
@@ -0,0 +1,6 @@
+(with-throw-handler 'foo
+  (lambda ()
+    (error "whoops!"))
+  (lambda ()
+    ;; unused
+    (values)))
diff --git a/test-suite/tests/exceptions/error-with-throw-handler-2.scm b/test-suite/tests/exceptions/error-with-throw-handler-2.scm
new file mode 100644
index 000000000..8dc04c081
--- /dev/null
+++ b/test-suite/tests/exceptions/error-with-throw-handler-2.scm
@@ -0,0 +1,11 @@
+(with-throw-handler 'bar
+  (lambda ()
+    (with-throw-handler 'foo
+      (lambda ()
+        (error "whoops!"))
+      (lambda ()
+        ;; unused
+        (values))))
+  (lambda ()
+    ;; unused
+    (values)))
diff --git a/test-suite/tests/exceptions/error-with-throw-handler-3.scm b/test-suite/tests/exceptions/error-with-throw-handler-3.scm
new file mode 100644
index 000000000..62c8b033b
--- /dev/null
+++ b/test-suite/tests/exceptions/error-with-throw-handler-3.scm
@@ -0,0 +1,16 @@
+(with-throw-handler 'baz
+  (lambda ()
+    (with-throw-handler 'bar
+      (lambda ()
+        (with-throw-handler 'foo
+          (lambda ()
+            (error "whoops!"))
+          (lambda ()
+            ;; unused
+            (values))))
+      (lambda ()
+        ;; unused
+        (values))))
+  (lambda ()
+    ;; unused
+    (values)))
diff --git a/test-suite/tests/exceptions/error.scm b/test-suite/tests/exceptions/error.scm
new file mode 100644
index 000000000..7ba405341
--- /dev/null
+++ b/test-suite/tests/exceptions/error.scm
@@ -0,0 +1 @@
+(error "whoops!")
-- 
2.38.0




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

* Re: [DRAFT] Improve reporting of exception locations
  2022-10-12  6:35 [DRAFT] Improve reporting of exception locations Andrew Whatson
  2022-10-12  6:42 ` Andrew Whatson
@ 2022-10-12 19:16 ` Maxime Devos
  1 sibling, 0 replies; 3+ messages in thread
From: Maxime Devos @ 2022-10-12 19:16 UTC (permalink / raw)
  To: Andrew Whatson, guile-devel


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



On 12-10-2022 08:35, Andrew Whatson wrote:
> Hello guile-dev!
> 
> I'm working on a revised patch to improve the reporting of exception
> locations, after last month's initial flawed attempt.
> 
> The new patch takes the more radical approach of capturing the stack
> when an exception is created,

AFAICT, it only does for 'throw', not for things like
(raise-exception (condition ...)) even though IMHO the latter is 
recommended.

> including it as part of the compound
> exception object.  This should ensure that we capture a correctly
> trimmed stack, while avoiding the complexities of pre-unwind handlers.
> This is similar to other dynamic languages where it's common to bundle
> stack info with exception objects.
> 
> This approach will probably have a negative impact on code which is
> sensitive to the performance of exception creation; capturing the
> stack is more expensive than NOT capturing it.  Is this something that
> we need to be concerned about?

I'd say, yes, though the only way to be sure is to have some software 
doing lots of raise-exception and comparing performance before and 
after.  If raise-exception + guard or equivalent is slow, this prevents 
raise-exception from being used in contexts where lots of 
raise-exception can happen.

For example, I am writing a Guile library GNUnet-Scheme that handles 
messages coming from the network.  For that, raise-exception + guard is 
potentially useful (*).

These messages are expected to be usually valid, but some malicious or 
otherwise broken entity could send malformed messages.  Catching the 
stack is, as I understand it, slow, so this could aid a (intentional or 
unintentional) DOS attack.

Even worse, when processing recursive data structures, the length of the 
stack can be linear in the depth of the data structure (e.g. when using 
procedures like 'map'), potentially making things worse than in other 
languages' implementations.

(*) I actually seemed to have (mostly accidentally) avoided 
raise-exception so far because lots of code is a little CPS-y or using 
code like (if (valid? ...) (begin (foo ...) (continue (decode ...))) 
(stop), but I could easily have chosen for exceptions instead as they 
are supposed to be reasonably fast (due to being based on continuations 
and because they don't capture the stack (except when actually being 
printed)).

On the tests: according to the documentation, stacks have a limited 
lifetime, could you verify it works correctly (maybe do some 
'call-with-prompt' around the exception handler that prints the message 
and 'abort-to-prompt' inside?) . If it isn't done already, could you 
verify that 'start-stack' still works?

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] 3+ messages in thread

end of thread, other threads:[~2022-10-12 19:16 UTC | newest]

Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-10-12  6:35 [DRAFT] Improve reporting of exception locations Andrew Whatson
2022-10-12  6:42 ` Andrew Whatson
2022-10-12 19:16 ` Maxime Devos

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).