Start trying to improve exceptions and backtraces

When using knots utilities.

3 files changed, 125 insertions, 40 deletions

diff --git a/knots.scm b/knots.scm
index 4d1765b..5d152a8 100644
--- a/knots.scm
+++ b/knots.scm
@@ -1,11 +1,21 @@
 (define-module (knots)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 suspendable-ports)
   #:use-module (fibers conditions)
+  #:use-module (system repl debug)
   #:export (call-with-default-io-waiters
 
             wait-when-system-clock-behind
 
-            call-with-sigint))
+            call-with-sigint
+
+            &knots-exception
+            make-knots-exception
+            knots-exception?
+            knots-exception-stack
+
+            print-backtrace-and-exception/knots))
 
 (define (call-with-default-io-waiters thunk)
   (parameterize
@@ -37,3 +47,63 @@
             (sigaction SIGINT (car handler) (cdr handler))
             ;; restore original C handler.
             (sigaction SIGINT #f))))))
+
+(define &knots-exception
+  (make-exception-type '&knots-exception
+                       &exception
+                       '(stack)))
+
+(define make-knots-exception
+  (record-constructor &knots-exception))
+
+(define knots-exception?
+  (record-predicate &knots-exception))
+
+(define knots-exception-stack
+  (exception-accessor
+   &knots-exception
+   (record-accessor &knots-exception 'stack)))
+
+(define* (print-backtrace-and-exception/knots
+          exn
+          #:key (port (current-error-port)))
+  (let* ((stack (match (fluid-ref %stacks)
+                  ((stack-tag . prompt-tag)
+                   (make-stack #t
+                               0 prompt-tag
+                               0 (and prompt-tag 1)))))
+         (error-string
+          (call-with-output-string
+            (lambda (port)
+              (let ((knots-stacks
+                     (map knots-exception-stack
+                          (filter knots-exception?
+                                  (simple-exceptions exn)))))
+
+                (let ((stack-vec
+                       (stack->vector stack)))
+                  (print-frames (list->vector
+                                 (drop
+                                  (vector->list stack-vec)
+                                  6))
+                                port
+                                #:count (stack-length stack)))
+                (for-each
+                 (lambda (stack)
+                   (let ((stack-vec
+                          (stack->vector stack)))
+                     (print-frames (list->vector
+                                    (drop
+                                     (vector->list stack-vec)
+                                     3))
+                                   port
+                                   #:count (stack-length stack))))
+                 knots-stacks)
+                (print-exception
+                 port
+                 (if (null? knots-stacks)
+                     (stack-ref stack 1)
+                     (stack-ref (last knots-stacks) 3))
+                 '%exception
+                 (list exn)))))))
+    (display error-string port)))
diff --git a/knots/parallelism.scm b/knots/parallelism.scm
index c829254..99f41b3 100644
--- a/knots/parallelism.scm
+++ b/knots/parallelism.scm
@@ -21,9 +21,11 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 control)
   #:use-module (fibers)
   #:use-module (fibers channels)
   #:use-module (fibers operations)
+  #:use-module (knots)
   #:export (fibers-batch-map
             fibers-map
 
@@ -41,19 +43,23 @@
   (let ((reply (make-channel)))
     (spawn-fiber
      (lambda ()
-       (with-exception-handler
-           (lambda (exn)
-             (put-message reply (cons 'exception exn)))
-         (lambda ()
-           (call-with-values
-               (lambda ()
-                 (with-throw-handler #t
-                   thunk
-                   (lambda _
-                     (backtrace))))
-             (lambda vals
-               (put-message reply vals))))
-         #:unwind? #t))
+       (call-with-escape-continuation
+        (lambda (return)
+          (with-exception-handler
+              (lambda (exn)
+                (match (fluid-ref %stacks)
+                  ((stack-tag . prompt-tag)
+                   (let ((stack (make-stack #t
+                                            0 prompt-tag
+                                            0 (and prompt-tag 1))))
+                     (put-message reply (list 'exception exn stack)))))
+                (return))
+            (lambda ()
+              (call-with-values
+                  (lambda ()
+                    (start-stack #t (thunk)))
+                (lambda vals
+                  (put-message reply vals))))))))
      #:parallel? #t)
     reply))
 
@@ -62,8 +68,13 @@
                         reply-channels)))
     (map
      (match-lambda
-       (('exception . exn)
-        (raise-exception exn))
+       (('exception exn stack)
+        (let ((knots-exn
+               (make-knots-exception stack)))
+          (raise-exception
+           (make-exception
+            knots-exn
+            exn))))
        (result
         (apply values result)))
      responses)))
@@ -234,21 +245,22 @@
                                        (get-message channel))))
               (put-message
                reply-channel
-               (with-exception-handler
-                   (lambda (exn)
-                     (cons 'exception exn))
-                 (lambda ()
-                   (with-throw-handler #t
-                     (lambda ()
-                       (call-with-values
-                           (lambda ()
-                             (apply proc args))
-                         (lambda vals
-                           (cons 'result vals))))
-                     (lambda args
-                       (when (apply show-backtrace? args)
-                         (backtrace)))))
-                 #:unwind? #t)))))
+               (call-with-escape-continuation
+                (lambda (return)
+                  (with-exception-handler
+                      (lambda (exn)
+                        (match (fluid-ref %stacks)
+                          ((stack-tag . prompt-tag)
+                           (let ((stack (make-stack #t
+                                                    0 prompt-tag
+                                                    0 (and prompt-tag 1))))
+                             (return (list 'exception exn stack))))))
+                    (lambda ()
+                      (call-with-values
+                          (lambda ()
+                            (start-stack #t (apply proc args)))
+                        (lambda vals
+                          (cons 'result vals)))))))))))
         #:parallel? #t))
      (iota parallelism))
 
@@ -257,4 +269,10 @@
         (put-message channel (cons reply-channel args))
         (match (get-message reply-channel)
           (('result . vals) (apply values vals))
-          (('exception . exn) (raise-exception exn)))))))
+          (('exception exn stack)
+           (let ((knots-exn
+                  (make-knots-exception stack)))
+             (raise-exception
+              (make-exception
+               knots-exn
+               exn)))))))))
diff --git a/knots/web-server.scm b/knots/web-server.scm
index 3a5bb5e..a0d2412 100644
--- a/knots/web-server.scm
+++ b/knots/web-server.scm
@@ -35,6 +35,7 @@
   #:use-module (web http)
   #:use-module (web request)
   #:use-module (web response)
+  #:use-module (knots)
   #:use-module (knots timeout)
   #:use-module (knots non-blocking)
   #:export (run-knots-web-server
@@ -203,8 +204,7 @@ on the procedure being called at any particular time."
   #f)
 
 (define (default-exception-handler exn request)
-  (let* ((stack (make-stack #t))
-         (error-string
+  (let* ((error-string
           (call-with-output-string
             (lambda (port)
               (simple-format
@@ -212,12 +212,9 @@ on the procedure being called at any particular time."
                "exception when processing: ~A ~A\n"
                (request-method request)
                (uri-path (request-uri request)))
-              (display-backtrace stack port 4)
-              (print-exception
-               port
-               (stack-ref stack 4)
-               '%exception
-               (list exn))))))
+              (print-backtrace-and-exception/knots
+               exn
+               #:port port)))))
     (display error-string
              (current-error-port)))