cbaines/guile-knots
1
Fork 0
Code Issues 1 Pull requests Activity Actions

Rework the backtrace handling
All checks were successful
/ test (push) Successful in 6s
Details

Browse source 
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.
This commit is contained in:
Christopher Baines 2026-03-20 19:11:03 +00:00
parent 92c2fe46e7
commit b3fa4d069b
21 changed files with 957 additions and 118 deletions
Download patch file Download diff file Expand all files Collapse all files

319
tests/backtraces.scm Normal file
View file

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

18
tests/backtraces/call-with-cached-connection.scm Normal file
View file

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

16
tests/backtraces/call-with-resource-from-pool.scm Normal file
View file

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

14
tests/backtraces/call-with-thread.scm Normal file
View file

@ -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

15
tests/backtraces/fibers-force.scm Normal file
View file

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

20
tests/backtraces/fibers-map.scm Normal file
View file

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

19
tests/backtraces/guile-error-deep-in-thread.scm Normal file
View file

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

11
tests/backtraces/guile-error-in-thread.scm Normal file
View file

@ -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

40
tests/backtraces/nested-parallelism.scm Normal file
View file

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

10
tests/backtraces/plain-exception.scm Normal file
View file

@ -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

19
tests/backtraces/stack-situation-fibers.scm Normal file
View file

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

15
tests/backtraces/stack-situation-script.scm Normal file
View file

@ -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")))

17
tests/backtraces/stack-situation-unknown.scm Normal file
View file

@ -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"))))

11
tests/backtraces/temporary-thread.scm Normal file
View file

@ -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

16
tests/backtraces/triple-with-exception-handler.scm Normal file
View file

@ -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

26
tests/backtraces/vhash-fold-in-thread.scm Normal file
View file

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

24
tests/backtraces/vhash-fold.scm Normal file
View file

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

16
tests/backtraces/wrapped-exception.scm Normal file
View file

@ -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