Rework the backtrace handling

Try and improve the print-backtrace-and-exception/knots output, be
selective about the stack frames which are shown to try and produce
some useful output which reflects user code and hide the
&knots-exceptions.

This commit also introduces a bunch of tests scripts that produce
output from print-backtrace-and-exception/knots, to help test this
code in different situations.

Makefile.am

@@ -2,18 +2,20 @@ include guile.am
 
 SOURCES =			\
   knots.scm			\
+  knots/backtraces.scm		\
   knots/non-blocking.scm	\
   knots/parallelism.scm	\
   knots/promise.scm		\
-  knots/web.scm		\
   knots/queue.scm		\
   knots/resource-pool.scm	\
   knots/sort.scm		\
   knots/thread-pool.scm	\
   knots/timeout.scm		\
-  knots/web-server.scm
+  knots/web-server.scm		\
+  knots/web.scm
 
 SCM_TESTS =			\
+  tests/backtraces.scm		\
   tests/non-blocking.scm	\
   tests/non-blocking.scm	\
   tests/parallelism.scm	\

knots.scm

@@ -1,5 +1,25 @@
+;;; Guile Knots
+;;; Copyright © 2026 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of Guile Knots.
+;;;
+;;; The Guile Knots is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; The Guile Knots is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
 (define-module (knots)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 binary-ports)
@@ -8,7 +28,14 @@
   #:use-module (fibers)
   #:use-module (fibers channels)
   #:use-module (fibers conditions)
-  #:use-module (system repl debug)
+  #:use-module (ice-9 format)
+  #:use-module (knots backtraces)
+  #:re-export (&knots-exception
+               make-knots-exception
+               knots-exception?
+               knots-exception-stack
+
+               print-backtrace-and-exception/knots)
   #:export (call-with-default-io-waiters
 
             wait-when-system-clock-behind
@@ -19,13 +46,6 @@
             simple-format/knots
             format/knots
 
-            &knots-exception
-            make-knots-exception
-            knots-exception?
-            knots-exception-stack
-
-            print-backtrace-and-exception/knots
-
             call-with-temporary-thread
 
             spawn-fiber/knots))
@@ -157,114 +177,6 @@ without buffering."
              (current-output-port)
              port)))))
 
-(define &knots-exception
-  (make-exception-type '&knots-exception
-                       &exception
-                       '(stack)))
-
-(define make-knots-exception
-  (record-constructor &knots-exception))
-
-(define knots-exception?
-  (exception-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)))
-  (define (get-string port stack)
-    (define stack-len
-      (stack-length stack))
-
-    (let ((knots-stacks
-           (map knots-exception-stack
-                (filter knots-exception?
-                        (simple-exceptions exn)))))
-
-      (let* ((stack-vec
-              (stack->vector stack))
-             (stack-vec-length
-              (vector-length stack-vec)))
-        (print-frames (list->vector
-                       (drop
-                        (vector->list stack-vec)
-                        (if (< stack-vec-length 5)
-                            0
-                            4)))
-                      port
-                      #:count (stack-length stack)))
-      (for-each
-       (lambda (stack)
-         (let* ((stack-vec
-                 (stack->vector stack))
-                (stack-vec-length
-                 (vector-length stack-vec)))
-           (print-frames (list->vector
-                          (drop
-                           (vector->list stack-vec)
-                           (if (< stack-vec-length 4)
-                               0
-                               3)))
-                         port
-                         #:count (stack-length stack))))
-       knots-stacks)
-      (print-exception
-       port
-       (if (null? knots-stacks)
-           (stack-ref stack
-                      (if (< stack-len 4)
-                          stack-len
-                          4))
-           (let* ((stack (last knots-stacks))
-                  (stack-len (stack-length stack)))
-             (stack-ref stack
-                        (if (< stack-len 3)
-                            stack-len
-                            3))))
-       '%exception
-       (list exn))))
-
-  (let* ((stack
-          (match (fluid-ref %stacks)
-            ((stack-tag . prompt-tag)
-             (make-stack #t
-                         0 prompt-tag
-                         0 (and prompt-tag 1)))
-            (_
-             (make-stack #t))))
-         (string-port
-          (open-output-string))
-         (error-string
-          (with-exception-handler
-              (lambda (exn)
-                (display/knots (get-output-string string-port)
-                               port)
-                (close-output-port string-port)
-                (display/knots "\n\n" port)
-
-                (let* ((stack (make-stack #t))
-                       (backtrace
-                        (call-with-output-string
-                          (lambda (port)
-                            (display-backtrace stack port)
-                            (newline port)))))
-                  (display/knots backtrace))
-                (simple-format/knots
-                 port
-                 "\nexception in print-backtrace-and-exception/knots: ~A\n"
-                 exn)
-                (raise-exception exn))
-            (lambda ()
-              (get-string string-port stack)
-              (let ((str (get-output-string string-port)))
-                (close-output-port string-port)
-                str)))))
-    (display/knots error-string port)))
-
 (define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?)
   "Spawn a fiber to run THUNK, with knots exception handling.
 

knots/backtraces.scm

@@ -0,0 +1,318 @@
+;;; Guile Knots
+;;; Copyright © 2026 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of Guile Knots.
+;;;
+;;; The Guile Knots is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; The Guile Knots is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (knots backtraces)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (system repl debug)
+  #:use-module (system vm frame)
+  #:use-module ((knots) #:select (display/knots
+                                  simple-format/knots
+                                  format/knots))
+  #:export (&knots-exception
+            make-knots-exception
+            knots-exception?
+            knots-exception-stack
+
+            print-backtrace-and-exception/knots
+
+            classify-stack-situation))
+
+(define &knots-exception
+  (make-exception-type '&knots-exception
+                       &exception
+                       '(stack)))
+
+(define make-knots-exception
+  (record-constructor &knots-exception))
+
+(define knots-exception?
+  (exception-predicate &knots-exception))
+
+(define knots-exception-stack
+  (exception-accessor
+   &knots-exception
+   (record-accessor &knots-exception 'stack)))
+
+(define (backtrace-debug-mode?)
+  (let ((val (getenv "KNOTS_BACKTRACE_DEBUG")))
+    (and val
+         (not (string=? val ""))
+         (not (string=? val "0")))))
+
+(define (debug-print-stack port label full-vec included-vec)
+  (simple-format/knots port "[KNOTS DEBUG] ~A\n" label)
+  (if (vector-empty? full-vec)
+      (simple-format/knots port "  (empty)\n")
+      (vector-fold-right
+       (lambda (i _ frame)
+         (let ((marker
+                (if (vector-index
+                     (lambda (f) (eq? f frame))
+                     included-vec)
+                    ">" " "))
+               (name
+                (symbol->string
+                 (or (frame-procedure-name frame)
+                     '_))))
+           (match (frame-source frame)
+             (#f
+              (format/knots port "  ~a ~3d  unknown  ~a~%"
+                            marker i name))
+             ((_ file line . col)
+              (format/knots port "  ~a ~3d  ~a:~a:~a  ~a~%"
+                            marker i file (1+ line) col name)))))
+       #f
+       full-vec))
+  (force-output port))
+
+(define (internal-file? file)
+  (or (string-prefix? "ice-9/" file)
+      (string-prefix? "system/" file)
+      (string-prefix? "srfi/" file)
+      (string=? file "knots.scm")
+      (string-prefix? "knots/" file)
+      (string=? file "fibers.scm")
+      (string-prefix? "fibers/" file)))
+
+(define (frame-file frame)
+  (let ((src (frame-source frame)))
+    (and src (cadr src))))
+
+(define (user-frame? frame)
+  (let ((file (frame-file frame)))
+    (and (string? file)
+         (not (internal-file? file)))))
+
+(define (raise-machinery-frame? frame)
+  ;; Return #t for frames that are part of the raise/unwind machinery
+  ;; and should be skipped when looking for the raise site.
+  ;; Specifically: C/unknown frames (no source file) and
+  ;; ice-9/boot-9.scm frames.  Other internal frames such as
+  ;; ice-9/vlist.scm are part of the actual call path and should be
+  ;; preserved.
+  (let ((file (frame-file frame)))
+    (or (not file)
+        (string=? file "ice-9/boot-9.scm"))))
+
+(define (fibers-frame? frame)
+  ;; Return #t if FRAME belongs to the fibers library.
+  (let ((file (frame-file frame)))
+    (and (string? file)
+         (or (string=? file "fibers.scm")
+             (string-prefix? "fibers/" file)))))
+
+;; The number of frames in Guile's eval-machinery tail appended to every
+;; top-level script stack:
+;;
+;;   [n-6]  ice-9/boot-9.scm       _
+;;   [n-5]  ice-9/boot-9.scm       save-module-excursion
+;;   [n-4]  ice-9/eval.scm         _
+;;   [n-3]  ice-9/boot-9.scm       call-with-prompt
+;;   [n-2]  C/unknown              apply-smob/0
+;;   [n-1]  ice-9/boot-9.scm       with-exception-handler
+(define script-eval-tail-length 6)
+
+(define (classify-stack-situation stack-vector)
+  (cond
+   ((vector-any fibers-frame? stack-vector)
+    'run-fibers)
+   ((let ((len (vector-length stack-vector)))
+      (and (>= len script-eval-tail-length)
+           (equal? (frame-file (vector-ref stack-vector (- len 1)))
+                   "ice-9/boot-9.scm")
+           (eq? (frame-procedure-name (vector-ref stack-vector (- len 3)))
+                'call-with-prompt)
+           (not (vector-any (lambda (frame)
+                              (eq? (frame-procedure-name frame)
+                                   '%start-stack))
+                            stack-vector))))
+    'script)
+   (else
+    'unknown)))
+
+(define (filter-knots-stack-vector vector)
+  ;; Extract user frames from a pre-captured knots stack.  The bottom 3 frames
+  ;; are always fixed overhead: make-stack (C), the handler body frame at the
+  ;; make-stack call site (exactly 1 Scheme frame), and raise-exception
+  ;; (boot-9).  User frames start at index 3.
+  (let ((last-user (vector-index-right user-frame? vector)))
+    (if (or (not last-user) (< last-user 3))
+        #()
+        (vector-copy vector 3 (+ last-user 1)))))
+
+(define (filter-stack-vector vector)
+  ;; Return the slice of VECTOR containing the frames relevant for
+  ;; display.  Skips the fixed 2-frame overhead (make-stack + call
+  ;; site) and any raise machinery to find after-raise, then bounds at
+  ;; the eval-machinery tail (script) or the first fibers scheduler
+  ;; frame (run-fibers/unknown).
+
+  (define (skip-handler-and-raise vector start)
+    ;; Scan forward from START in VECTOR, first past any user frames
+    ;; (the handler body), then past raise-machinery frames (C/unknown
+    ;; and ice-9/boot-9.scm).  Returns the index of the first
+    ;; remaining frame — the raise site or context.  Other internal
+    ;; frames such as ice-9/vlist.scm are preserved because they are
+    ;; part of the actual call path.
+    (let* ((len (vector-length vector))
+           (after-handler
+            (let loop ((i start))
+              (if (or (>= i len) (not (user-frame? (vector-ref vector i))))
+                  i
+                  (loop (+ i 1))))))
+      (let loop ((i after-handler))
+        (cond
+         ((>= i len) i)
+         ((raise-machinery-frame? (vector-ref vector i)) (loop (+ i 1)))
+         (else i)))))
+
+  (let* ((len         (vector-length vector))
+         (situation   (classify-stack-situation vector))
+         (after-raise (skip-handler-and-raise vector (min 2 len)))
+         (end         (if (and (eq? situation 'script)
+                               (> (- len script-eval-tail-length) after-raise))
+                          (- len script-eval-tail-length)
+                          (let loop ((i after-raise))
+                            (cond ((>= i len) i)
+                                  ((fibers-frame? (vector-ref vector i)) i)
+                                  (else (loop (+ i 1))))))))
+    (if (>= after-raise end)
+        #()
+        (vector-copy vector after-raise end))))
+
+;; Based on print-frame from (system repl debug), but without the
+;; frame indexes
+(define* (print-frame/no-index frame
+                               #:optional (port (current-output-port))
+                               #:key (width (terminal-width))
+                               (last-source #f) (innermost? #f))
+  (define (source-file src)
+    (match src
+      (#f "unknown file")
+      ((_ #f . _) "current input")
+      ((_ file . _) file)))
+  (let* ((source (frame-source frame))
+         (file   (source-file source)))
+    (when (not (equal? file (source-file last-source)))
+      (format port "~&In ~a:~&" file))
+    (format port "~9@a    ~v:@y~%"
+            (match source
+              (#f "")
+              ((_ _ line . col) (simple-format #f "~A:~A" (1+ line) col)))
+            width
+            (frame-call-representation frame #:top-frame? innermost?))))
+
+(define* (print-backtrace-and-exception/knots
+          exn
+          #:key (port (current-error-port)))
+  (define (get-string out stack)
+    (let* ((stack-vector (stack->vector stack))
+           (knots-stack-vectors
+            (map (lambda (exn)
+                   (stack->vector
+                    (knots-exception-stack exn)))
+                 (reverse
+                  (filter knots-exception?
+                          (simple-exceptions exn)))))
+           (filtered-stack-vector
+            (filter-stack-vector stack-vector))
+           (filtered-knots-stack-vectors
+            (map filter-knots-stack-vector knots-stack-vectors)))
+      (when (backtrace-debug-mode?)
+        (let ((debug-port (current-error-port))
+              (situation (classify-stack-situation stack-vector)))
+          (simple-format/knots
+           debug-port
+           "[KNOTS DEBUG] situation: ~A\n" situation)
+          (debug-print-stack debug-port "stack"
+                             stack-vector filtered-stack-vector)
+          (let ((stack-count (length knots-stack-vectors)))
+            (for-each
+             (lambda (knots-vec user-vec index)
+               (debug-print-stack
+                debug-port
+                (format #f "knots stack ~a/~a" index stack-count)
+                knots-vec user-vec))
+             knots-stack-vectors
+             filtered-knots-stack-vectors
+             (iota stack-count 1)))
+          (display/knots "\n" debug-port)
+          (force-output debug-port)))
+
+      (for-each (lambda (vec)
+                  (vector-fold-right
+                   (lambda (i last-source frame)
+                     (print-frame/no-index frame out
+                                           #:innermost? (= i 0)
+                                           #:last-source last-source)
+                     (frame-source frame))
+                   #f
+                   vec))
+                (cons filtered-stack-vector
+                      filtered-knots-stack-vectors))
+
+      (print-exception
+       out
+       #f
+       '%exception
+       (list (if (backtrace-debug-mode?)
+                 exn
+                 (apply make-exception
+                        (remove knots-exception?
+                                (simple-exceptions exn))))))))
+
+  (let* ((stack
+          (match (fluid-ref %stacks)
+            ((stack-tag . prompt-tag)
+             (make-stack #t
+                         0 prompt-tag
+                         0 (and prompt-tag 1)))
+            (_
+             (make-stack #t))))
+         (string-port
+          (open-output-string))
+         (output
+          (with-exception-handler
+              (lambda (output-exn)
+                (display/knots (get-output-string string-port)
+                               port)
+                (close-output-port string-port)
+                (display/knots "\n\n" port)
+
+                (let* ((stack (make-stack #t))
+                       (backtrace
+                        (call-with-output-string
+                          (lambda (port)
+                            (display-backtrace stack port)
+                            (newline port)))))
+                  (display/knots backtrace port))
+                (simple-format/knots
+                 port
+                 "\nexception in print-backtrace-and-exception/knots: ~A\n"
+                 output-exn)
+                (raise-exception output-exn))
+            (lambda ()
+              (get-string string-port stack)
+              (let ((str (get-output-string string-port)))
+                (close-output-port string-port)
+                str)))))
+    (display/knots output port)))

knots/web-server.scm

@@ -317,36 +317,19 @@ on the procedure being called at any particular time."
   ;; Close the client port
   #f)
 
-(define (exception-handler exn request)
-  (let* ((error-string
-          (call-with-output-string
-            (lambda (port)
-              (simple-format
-               port
-               "exception when processing: ~A ~A\n"
-               (request-method request)
-               (uri-path (request-uri request)))
-              (print-backtrace-and-exception/knots
-               exn
-               #:port port)))))
-    (display/knots error-string
-                   (current-error-port)))
-
-  (values (build-response #:code 500)
-          ;; TODO Make this configurable
-          (string->utf8
-           "internal server error")))
-
-(define* (handle-request handler client
+(define* (handle-request handler client sockaddr
                          read-request-exception-handler
                          write-response-exception-handler
                          buffer-size
                          #:key post-request-hook)
+  (define meta
+    `((sockaddr . ,sockaddr)))
+
   (let ((request
          (with-exception-handler
              read-request-exception-handler
            (lambda ()
-             (read-request client))
+             (read-request client meta))
            #:unwind? #t))
         (read-request-time
          (get-internal-real-time)))
@@ -362,36 +345,47 @@ on the procedure being called at any particular time."
                                   (connection . (close))))
                      #vu8()))
             (else
-             (call-with-escape-continuation
-              (lambda (return)
-                (with-exception-handler
-                    (lambda (exn)
+             (with-exception-handler
+                 (lambda (exn)
+                   (sanitize-response
+                    request
+                    (build-response #:code 500)
+                    (string->utf8
+                     "internal server error")))
+               (lambda ()
+                 (with-exception-handler
+                     (lambda (exn)
+                       (let* ((error-string
+                               (call-with-output-string
+                                 (lambda (port)
+                                   (simple-format
+                                    port
+                                    "exception when processing: ~A ~A\n"
+                                    (request-method request)
+                                    (uri-path (request-uri request)))
+                                   (print-backtrace-and-exception/knots
+                                    exn
+                                    #:port port)))))
+                         (display/knots error-string
+                                        (current-error-port))))
+                   (lambda ()
+                     (start-stack
+                      #t
                       (call-with-values
                           (lambda ()
-                            (exception-handler exn request))
-                        (lambda (response body)
-                          (call-with-values
-                              (lambda ()
-                                (sanitize-response request response body))
-                            return))))
-                  (lambda ()
-                    (start-stack
-                     #t
-                     (call-with-values
-                         (lambda ()
-                           (handler request))
-                       (match-lambda*
-                         ((response body)
-                          (sanitize-response request response body))
-                         (other
-                          (raise-exception
-                           (make-exception-with-irritants
-                            (list (make-exception-with-message
-                                   (simple-format
-                                    #f
-                                    "wrong number of values returned from handler, expecting 2, got ~A"
-                                    (length other)))
-                                  handler)))))))))))))))
+                            (handler request))
+                        (match-lambda*
+                          ((response body)
+                           (sanitize-response request response body))
+                          (other
+                           (raise-exception
+                            (make-exception-with-irritants
+                             (list (make-exception-with-message
+                                    (simple-format
+                                     #f
+                                     "wrong number of values returned from handler, expecting 2, got ~A"
+                                     (length other)))
+                                   handler)))))))))))))))
       (with-exception-handler
           (lambda (exn)
             (write-response-exception-handler exn request))
@@ -458,7 +452,7 @@ on the procedure being called at any particular time."
                 #f)))
         #:unwind? #t))))
 
-(define* (client-loop client handler
+(define* (client-loop client handler sockaddr
                       read-request-exception-handler
                       write-response-exception-handler
                       connection-idle-timeout
@@ -503,7 +497,7 @@ on the procedure being called at any particular time."
         #:unwind? #t)
       (close-port client))
      (else
-      (let ((keep-alive? (handle-request handler client
+      (let ((keep-alive? (handle-request handler client sockaddr
                                          read-request-exception-handler
                                          write-response-exception-handler
                                          buffer-size
@@ -576,19 +570,28 @@ before sending back to the client."
 
   (spawn-fiber
    (lambda ()
-     (let loop ()
-       (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
-         ((client . sockaddr)
-          (spawn-fiber (lambda ()
-                         (client-loop client handler
-                                      read-request-exception-handler
-                                      write-response-exception-handler
-                                      connection-idle-timeout
-                                      connection-buffer-size
-                                      (post-request-hook/safe
-                                       post-request-hook)))
-                       #:parallel? #t)
-          (loop))))))
+     (while #t
+       (with-exception-handler
+           (const #t)
+         (lambda ()
+           (with-exception-handler
+               (lambda (exn)
+                 (print-backtrace-and-exception/knots exn))
+             (lambda ()
+               (let loop ()
+                 (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
+                   ((client . sockaddr)
+                    (spawn-fiber (lambda ()
+                                   (client-loop client handler sockaddr
+                                                read-request-exception-handler
+                                                write-response-exception-handler
+                                                connection-idle-timeout
+                                                connection-buffer-size
+                                                (post-request-hook/safe
+                                                 post-request-hook)))
+                                 #:parallel? #t)
+                    (loop)))))))
+         #:unwind? #t))))
 
   (make-web-server socket
                    (vector-ref (getsockname socket)

tests/backtraces.scm

@@ -0,0 +1,319 @@
+(use-modules (srfi srfi-1)
+             (srfi srfi-13)
+             (ice-9 popen)
+             (ice-9 rdelim)
+             (ice-9 match))
+
+(define (run-backtrace-script file)
+  (let* ((pipe (open-pipe* OPEN_READ
+                            "/bin/sh" "-c"
+                            (string-append "./test-env guile " file " 2>&1")))
+         (output (read-string pipe)))
+    (close-pipe pipe)
+    output))
+
+(define (read-backtrace-entry-annotation script keyword)
+  ;; Scan SCRIPT line by line and return the annotation for the expected
+  ;; backtrace entry matching KEYWORD (e.g. "FIRST" or "LAST"), or #f if
+  ;; none is found.
+  ;;
+  ;; Two forms are recognised:
+  ;;
+  ;;   ; KEYWORD BACKTRACE ENTRY HERE
+  ;;     — placed inline on a code line.  Returns ('here LINE COL) where LINE
+  ;;       is the 1-based line number and COL is the 0-based column of the
+  ;;       first non-space character on that line.
+  ;;
+  ;;   ; KEYWORD BACKTRACE ENTRY: STRING
+  ;;     — STRING is a literal substring expected to appear in the output.
+  ;;       Returns ('string STRING).
+  (let ((here-marker (string-append keyword " BACKTRACE ENTRY HERE"))
+        (string-marker (string-append keyword " BACKTRACE ENTRY: ")))
+    (call-with-input-file script
+      (lambda (port)
+        (let loop ((line (read-line port)) (line-num 1))
+          (cond
+            ((eof-object? line) #f)
+            ((string-contains line here-marker)
+             (let ((col (string-index line (lambda (c) (not (char=? c #\space))))))
+               (list 'here line-num col)))
+            ((string-contains line string-marker)
+             (let* ((idx (+ (string-contains line string-marker)
+                            (string-length string-marker)))
+                    (content (string-trim-right (substring line idx))))
+               (list 'string content)))
+            (else (loop (read-line port) (+ line-num 1)))))))))
+
+(define (frame-line? line)
+  ;; Return #t if LINE looks like a backtrace frame line: leading whitespace
+  ;; followed by digits:digits (LINE:COL).
+  (and (> (string-length line) 0)
+       (let* ((stripped (string-trim line))
+              (colon    (string-index stripped #\:)))
+         (and colon
+              (> colon 0)
+              (string-every char-set:digit stripped 0 colon)))))
+
+(define (extract-frame-lines output)
+  ;; Return all backtrace frame lines before "ERROR:" in OUTPUT.
+  (let* ((error-pos (string-contains output "\nERROR:"))
+         (before-error (if error-pos
+                           (substring output 0 error-pos)
+                           output)))
+    (filter frame-line? (string-split before-error #\newline))))
+
+(define (innermost-frame-line output)
+  ;; Return the last backtrace frame line before "ERROR:" in OUTPUT, or #f.
+  (let ((frame-lines (extract-frame-lines output)))
+    (if (null? frame-lines) #f (last frame-lines))))
+
+(define (outermost-frame-line output)
+  ;; Return the first backtrace frame line before "ERROR:" in OUTPUT, or #f.
+  (let ((frame-lines (extract-frame-lines output)))
+    (if (null? frame-lines) #f (car frame-lines))))
+
+;;; Assertions
+
+(define current-test-fail-count 0)
+
+(define (expect! label ok? detail)
+  ;; Print one expectation line; record a failure if not ok.
+  (if ok?
+      (format #t "  PASS  ~a~%" label)
+      (begin
+        (set! current-test-fail-count (+ current-test-fail-count 1))
+        (format #t "  FAIL  ~a~%        ~a~%" label detail))))
+
+(define (assert-output-contains output expected)
+  (expect! (format #f "output contains ~s" expected)
+           (string-contains output expected)
+           "not found in output"))
+
+(define (assert-output-excludes output unexpected)
+  (expect! (format #f "output excludes ~s" unexpected)
+           (not (string-contains output unexpected))
+           "unexpectedly found in output"))
+
+(define (assert-backtrace-entry output script keyword frame-line-proc)
+  (let ((annotation (read-backtrace-entry-annotation script keyword))
+        (frame (frame-line-proc output)))
+    (when annotation
+      (match annotation
+        (('here line col)
+         (let ((expected (string-append (number->string line) ":"
+                                        (number->string col))))
+           (expect! (format #f "~a backtrace entry ~a" keyword expected)
+                    (and frame (string-contains frame expected))
+                    (format #f "got ~s" (or frame "(none)")))))
+        (('string content)
+         (expect! (format #f "~a backtrace entry ~s" keyword content)
+                  (string-contains output content)
+                  "not found in output"))))))
+
+(define (assert-first-backtrace-entry output script)
+  (assert-backtrace-entry output script "FIRST" outermost-frame-line))
+
+(define (assert-last-backtrace-entry output script)
+  (assert-backtrace-entry output script "LAST" innermost-frame-line))
+
+;;; Test runner
+
+(define pass-count 0)
+(define fail-count 0)
+
+(define (run-test name thunk)
+  (set! current-test-fail-count 0)
+  (format #t "~%~a~%" name)
+  (catch #t
+    thunk
+    (lambda (key . args)
+      (set! current-test-fail-count (+ current-test-fail-count 1))
+      (format #t "  ERROR  unexpected exception: ~s~%" (cons key args))))
+  (if (zero? current-test-fail-count)
+      (set! pass-count (+ pass-count 1))
+      (set! fail-count (+ fail-count 1))))
+
+;;; Tests
+
+(run-test "plain-exception"
+  (lambda ()
+    (let* ((script "tests/backtraces/plain-exception.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"plain error message\""))))
+
+(run-test "triple-with-exception-handler"
+  (lambda ()
+    (let* ((script "tests/backtraces/triple-with-exception-handler.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"plain error message\""))))
+
+(run-test "wrapped-exception"
+  (lambda ()
+    (let* ((script "tests/backtraces/wrapped-exception.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"wrapped error message\""))))
+
+(run-test "temporary-thread"
+  (lambda ()
+    (let* ((script "tests/backtraces/temporary-thread.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"error from temporary thread\""))))
+
+(run-test "fibers-map"
+  (lambda ()
+    (let* ((script "tests/backtraces/fibers-map.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"error from fibers-map\""))))
+
+(run-test "call-with-resource-from-pool"
+  (lambda ()
+    (let* ((script "tests/backtraces/call-with-resource-from-pool.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"error from call-with-resource-from-pool\""))))
+
+;; Two knots stacks are printed (one per fiber boundary); ERROR: appears
+;; once at the end after both frame blocks.
+(run-test "call-with-cached-connection"
+  (lambda ()
+    (let* ((script "tests/backtraces/call-with-cached-connection.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"error from call-with-cached-connection\""))))
+
+(run-test "fibers-force"
+  (lambda ()
+    (let* ((script "tests/backtraces/fibers-force.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"error from fibers-force\""))))
+
+(run-test "call-with-thread"
+  (lambda ()
+    (let* ((script "tests/backtraces/call-with-thread.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"error from call-with-thread\""))))
+
+;; Nested fibers-map: user frames that survive fiber boundaries appear;
+;; intermediate functions (one-deep, two-deep, three-deep) are lost at
+;; their respective boundaries because fibers-map yields before the
+;; exception propagates back.  knots/parallelism.scm and srfi frames
+;; appear as call-path context between the surviving user frames.
+(run-test "nested-parallelism"
+  (lambda ()
+    (let* ((script "tests/backtraces/nested-parallelism.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &error\n  2. &origin: #f\n  3. &message: \"deeply nested error ~S\"")
+      (assert-output-contains output "(run-work)")
+      (assert-output-contains output "(process-batch _)")
+      (assert-output-contains output "(deeply-nested _)")
+      (assert-output-excludes output "In fibers"))))
+
+(run-test "guile-error-in-thread"
+  (lambda ()
+    (let* ((script "tests/backtraces/guile-error-in-thread.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &assertion-failure\n  2. &origin: \"+\"\n  3. &message: \"Wrong type argument in position ~A: ~S\"\n  4. &irritants: (1 a)"))))
+
+;; sort is a C function and appears as "In unknown file:" between the user frames.
+(run-test "guile-error-deep-in-thread"
+  (lambda ()
+    (let* ((script "tests/backtraces/guile-error-deep-in-thread.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &assertion-failure\n  2. &origin: \"+\"")
+      (assert-output-contains output "(do-sort)")
+      (assert-output-contains output "In unknown file:")
+      (assert-output-contains output "(sort (1 2 3)")
+      (assert-output-excludes output "In knots/")
+      (assert-output-excludes output "In srfi/"))))
+
+;; The error fires inside ice-9/vlist.scm (vlist-fold passed a non-vlist),
+;; so vlist-fold appears as the innermost frame and ice-9/vlist.scm frames
+;; appear between the user frames.
+(run-test "vhash-fold"
+  (lambda ()
+    (let* ((script "tests/backtraces/vhash-fold.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &assertion-failure\n  2. &origin: #f")
+      (assert-output-contains output "(do-fold)")
+      (assert-output-contains output "In ice-9/vlist.scm:")
+      (assert-output-contains output "(vlist-fold"))))
+
+;; do-fold calls vhash-fold in non-tail position so its frame is preserved.
+;; ice-9/vlist.scm frames appear between the user frames, as in vhash-fold.
+(run-test "vhash-fold-in-thread"
+  (lambda ()
+    (let* ((script "tests/backtraces/vhash-fold-in-thread.scm")
+           (output (run-backtrace-script script)))
+      (assert-first-backtrace-entry output script)
+      (assert-last-backtrace-entry output script)
+      (assert-output-contains output
+        "ERROR:\n  1. &assertion-failure\n  2. &origin: #f")
+      (assert-output-contains output "(do-fold)")
+      (assert-output-contains output "In ice-9/vlist.scm:")
+      (assert-output-contains output "(vlist-fold")
+      (assert-output-excludes output "In knots/"))))
+
+(run-test "stack-situation-script"
+  (lambda ()
+    (let* ((script "tests/backtraces/stack-situation-script.scm")
+           (output (run-backtrace-script script)))
+      (assert-output-contains output "situation: script"))))
+
+(run-test "stack-situation-fibers"
+  (lambda ()
+    (let* ((script "tests/backtraces/stack-situation-fibers.scm")
+           (output (run-backtrace-script script)))
+      (assert-output-contains output "situation: run-fibers"))))
+
+(run-test "stack-situation-unknown"
+  (lambda ()
+    (let* ((script "tests/backtraces/stack-situation-unknown.scm")
+           (output (run-backtrace-script script)))
+      (assert-output-contains output "situation: unknown"))))
+
+;;; Summary
+
+(newline)
+(if (zero? fail-count)
+    (format #t "All ~a scripts passed.~%" pass-count)
+    (format #t "~a of ~a scripts had failures.~%" fail-count (+ pass-count fail-count)))
+
+(when (> fail-count 0)
+  (primitive-exit 1))

tests/backtraces/call-with-cached-connection.scm

@@ -0,0 +1,18 @@
+(use-modules (knots) (fibers) (knots resource-pool) (knots web))
+
+(run-fibers
+ (lambda ()
+   (let ((cache (make-fixed-size-resource-pool
+                 (list (open-input-string "fake")))))
+     ;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+     (with-exception-handler
+         (lambda (e)
+           (print-backtrace-and-exception/knots e)
+           (primitive-exit 1))
+       (lambda ()
+         (call-with-cached-connection cache
+                                      (lambda (port)
+                                        (error "error from call-with-cached-connection"))  ; LAST BACKTRACE ENTRY HERE
+                                      #:close-connection-on-exception? #f)))))
+ #:hz 0 #:parallelism 1)
+

tests/backtraces/call-with-resource-from-pool.scm

@@ -0,0 +1,16 @@
+(use-modules (knots) (fibers) (knots resource-pool))
+
+(run-fibers
+ (lambda ()
+   (let ((pool (make-resource-pool (const 'resource) 1)))
+     ;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+     (with-exception-handler
+         (lambda (e)
+           (print-backtrace-and-exception/knots e)
+           (primitive-exit 1))
+       (lambda ()
+         (call-with-resource-from-pool pool
+                                       (lambda (resource)
+                                         (error "error from call-with-resource-from-pool")))))))  ; LAST BACKTRACE ENTRY HERE
+ #:hz 0 #:parallelism 1)
+

tests/backtraces/call-with-thread.scm

@@ -0,0 +1,14 @@
+(use-modules (knots) (knots thread-pool))
+
+(define thread-pool (make-fixed-size-thread-pool 1))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+(with-exception-handler
+    (lambda (exn)
+      (print-backtrace-and-exception/knots exn)
+      (primitive-exit 1))
+  (lambda ()
+    (call-with-thread
+     thread-pool
+     (lambda ()
+       (error "error from call-with-thread")))))  ; LAST BACKTRACE ENTRY HERE

tests/backtraces/fibers-force.scm

@@ -0,0 +1,15 @@
+(use-modules (knots) (fibers) (knots promise))
+
+(run-fibers
+ (lambda ()
+   ;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+   (with-exception-handler
+       (lambda (e)
+         (print-backtrace-and-exception/knots e)
+         (primitive-exit 1))
+     (lambda ()
+       (fibers-force
+        (fibers-delay
+         (lambda ()
+           (error "error from fibers-force"))))))) ; LAST BACKTRACE ENTRY HERE
+ #:hz 0 #:parallelism 1)

tests/backtraces/fibers-map.scm

@@ -0,0 +1,20 @@
+(use-modules (knots) (fibers) (knots parallelism))
+
+(run-fibers
+ (lambda ()
+   (with-exception-handler
+       (lambda _
+         ;; To avoid the test hanging if there's an exception
+         (primitive-exit 1))
+     (lambda ()
+       ;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+       (with-exception-handler
+           (lambda (e)
+             (print-backtrace-and-exception/knots e)
+             (primitive-exit 1))
+         (lambda ()
+           (fibers-map
+            (lambda (x)
+              (error "error from fibers-map"))  ; LAST BACKTRACE ENTRY HERE
+            '(1)))))))
+ #:hz 0 #:parallelism 1)

tests/backtraces/guile-error-deep-in-thread.scm

@@ -0,0 +1,19 @@
+(use-modules (knots))
+
+(define (do-sort)
+  (begin
+    (sort '(1 2 3)
+          (lambda _
+            (+ 1 'a)))         ; LAST BACKTRACE ENTRY HERE
+    'unreachable))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+(with-exception-handler
+    (lambda (exn)
+      (print-backtrace-and-exception/knots exn)
+      (primitive-exit 1))
+  (lambda ()
+    (call-with-temporary-thread
+     (lambda ()
+       (do-sort)
+       'done))))

tests/backtraces/guile-error-in-thread.scm

@@ -0,0 +1,11 @@
+(use-modules (knots))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+(with-exception-handler
+    (lambda (exn)
+      (print-backtrace-and-exception/knots exn)
+      (primitive-exit 1))
+  (lambda ()
+    (call-with-temporary-thread
+     (lambda ()
+       (+ 1 'a)))))           ; LAST BACKTRACE ENTRY HERE

tests/backtraces/nested-parallelism.scm

@@ -0,0 +1,40 @@
+(use-modules (knots) (fibers) (knots parallelism))
+
+;; Deep call chain within the innermost fiber.  Each function calls the next
+;; via `begin', placing the call in non-tail position so Guile's TCO does not
+;; collapse the frames; all four frames survive and appear in the backtrace.
+(define (deeply-nested x)
+  (error "deeply nested error" x))  ; LAST BACKTRACE ENTRY HERE
+
+(define (three-deep x)
+  (fibers-map deeply-nested (list x)))
+
+(define (two-deep x)
+  (fibers-map three-deep (list x)))
+
+(define (one-deep x)
+  (fibers-map two-deep (list x)))
+
+;; process-batch runs inside one fiber and dispatches the deep call chain into
+;; a nested fiber via a second fibers-map, creating two fiber boundaries.
+(define (process-batch items)
+  (begin
+    (fibers-map one-deep (list items))
+    'unreachable))
+
+(define (run-work)
+  (begin
+    (fibers-map process-batch '(1))
+    'unreachable))
+
+(define result
+  (run-fibers
+   (lambda ()
+     ;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+     (with-exception-handler
+         (lambda (e)
+           (print-backtrace-and-exception/knots e)
+           (primitive-exit 1))
+       run-work))
+   #:hz 0 #:parallelism 1))
+

tests/backtraces/plain-exception.scm

@@ -0,0 +1,10 @@
+(use-modules (knots))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+
+(with-exception-handler
+    (lambda (exn)
+      (print-backtrace-and-exception/knots exn)
+      (primitive-exit 1))
+  (lambda ()
+    (error "plain error message")))     ; LAST BACKTRACE ENTRY HERE

tests/backtraces/stack-situation-fibers.scm

@@ -0,0 +1,19 @@
+(use-modules (knots)
+             (knots backtraces)
+             (fibers)
+             (system repl debug))
+
+(run-fibers
+ (lambda ()
+   (with-exception-handler
+       (lambda (exn)
+         (let ((stack (make-stack #t)))
+           (print-backtrace-and-exception/knots exn)
+           (simple-format/knots #t
+                                "situation: ~A\n"
+                                (classify-stack-situation
+                                 (stack->vector stack))))
+         (primitive-exit 0))
+     (lambda ()
+       (error "test"))))
+ #:hz 0 #:parallelism 1)

tests/backtraces/stack-situation-script.scm

@@ -0,0 +1,15 @@
+(use-modules (knots)
+             (knots backtraces)
+             (system repl debug))
+
+(with-exception-handler
+    (lambda (exn)
+      (let ((stack (make-stack #t)))
+        (print-backtrace-and-exception/knots exn)
+        (simple-format/knots #t
+                             "situation: ~A\n"
+                             (classify-stack-situation
+                              (stack->vector stack))))
+      (primitive-exit 0))
+  (lambda ()
+    (error "test")))

tests/backtraces/stack-situation-unknown.scm

@@ -0,0 +1,17 @@
+(use-modules (knots)
+             (knots backtraces)
+             (fibers)
+             (system repl debug))
+
+(start-stack
+ #t
+ (with-exception-handler
+     (lambda (exn)
+       (let* ((stack (make-stack #t))
+              (stack-classification
+               (classify-stack-situation (stack->vector stack))))
+         (print-backtrace-and-exception/knots exn)
+         (simple-format/knots #t "situation: ~A\n" stack-classification)
+         (primitive-exit 0)))
+   (lambda ()
+     (error "test"))))

tests/backtraces/temporary-thread.scm

@@ -0,0 +1,11 @@
+(use-modules (knots))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+(with-exception-handler
+    (lambda (exn)
+      (print-backtrace-and-exception/knots exn)
+      (primitive-exit 1))
+  (lambda ()
+    (call-with-temporary-thread
+     (lambda ()
+       (error "error from temporary thread")))))  ; LAST BACKTRACE ENTRY HERE

tests/backtraces/triple-with-exception-handler.scm

@@ -0,0 +1,16 @@
+(use-modules (knots))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+
+(with-exception-handler
+    (lambda _ #f)
+  (lambda ()
+    (with-exception-handler
+        (lambda _ #f)
+      (lambda ()
+        (with-exception-handler
+            (lambda (exn)
+              (print-backtrace-and-exception/knots exn)
+              (primitive-exit 1))
+          (lambda ()
+            (error "plain error message"))))))) ; LAST BACKTRACE ENTRY HERE

tests/backtraces/vhash-fold-in-thread.scm

@@ -0,0 +1,26 @@
+(use-modules (knots) (ice-9 vlist))
+
+;; LAST BACKTRACE ENTRY: 257:2
+
+(define (do-fold)
+  (begin
+    (vhash-fold
+     (lambda (key value result)
+       ;; Shouldn't be reached
+       #f)
+     0
+     ;; The aim here is to pass in #f for the vlist, and cause an
+     ;; exception within the (ice-9 vlist) module
+     #f)
+    'done))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+(with-exception-handler
+    (lambda (exn)
+      (print-backtrace-and-exception/knots exn)
+      (primitive-exit 1))
+  (lambda ()
+    (call-with-temporary-thread
+     (lambda ()
+       (do-fold)
+       'done))))

tests/backtraces/vhash-fold.scm

@@ -0,0 +1,24 @@
+(use-modules (knots) (ice-9 vlist))
+
+;; LAST BACKTRACE ENTRY: 257:2
+
+(define (do-fold)
+  (begin
+    (vhash-fold
+     (lambda (key value result)
+       ;; Shouldn't be reached
+       #f)
+     0
+     ;; The aim here is to pass in #f for the vlist, and cause an
+     ;; exception within the (ice-9 vlist) module
+     #f)
+    'done))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+(with-exception-handler
+    (lambda (exn)
+      (print-backtrace-and-exception/knots exn)
+      (primitive-exit 1))
+  (lambda ()
+    (do-fold)
+    'done))

tests/backtraces/wrapped-exception.scm

@@ -0,0 +1,16 @@
+(use-modules (knots))
+
+;; FIRST BACKTRACE ENTRY: 1762:12    (with-exception-handler
+(with-exception-handler
+    (lambda (exn)
+      (print-backtrace-and-exception/knots exn)
+      (primitive-exit 1))
+  (lambda ()
+    (with-exception-handler
+        (lambda (exn)
+          (raise-exception
+           (make-exception
+            exn
+            (make-knots-exception (make-stack #t)))))
+      (lambda ()
+        (error "wrapped error message"))))) ; LAST BACKTRACE ENTRY HERE