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

6
Makefile.am
View file

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

125
knots.scm
View file

@ -19,6 +19,7 @@
(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)
@ -27,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
@ -38,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))
@ -176,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.

318
knots/backtraces.scm Normal file
View file

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

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