diff --git a/Makefile.am b/Makefile.am index 7942955..3429a15 100644 --- a/Makefile.am +++ b/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 \ diff --git a/knots.scm b/knots.scm index 089f986..e8e9690 100644 --- a/knots.scm +++ b/knots.scm @@ -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. diff --git a/knots/backtraces.scm b/knots/backtraces.scm new file mode 100644 index 0000000..a12ecb6 --- /dev/null +++ b/knots/backtraces.scm @@ -0,0 +1,318 @@ +;;; Guile Knots +;;; Copyright © 2026 Christopher Baines +;;; +;;; 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 +;;; . + +(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))) diff --git a/tests/backtraces.scm b/tests/backtraces.scm new file mode 100644 index 0000000..c5f8e0e --- /dev/null +++ b/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)) diff --git a/tests/backtraces/call-with-cached-connection.scm b/tests/backtraces/call-with-cached-connection.scm new file mode 100644 index 0000000..2e641a2 --- /dev/null +++ b/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) + diff --git a/tests/backtraces/call-with-resource-from-pool.scm b/tests/backtraces/call-with-resource-from-pool.scm new file mode 100644 index 0000000..cdbce9e --- /dev/null +++ b/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) + diff --git a/tests/backtraces/call-with-thread.scm b/tests/backtraces/call-with-thread.scm new file mode 100644 index 0000000..0921a31 --- /dev/null +++ b/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 diff --git a/tests/backtraces/fibers-force.scm b/tests/backtraces/fibers-force.scm new file mode 100644 index 0000000..7abef0c --- /dev/null +++ b/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) diff --git a/tests/backtraces/fibers-map.scm b/tests/backtraces/fibers-map.scm new file mode 100644 index 0000000..24ef36c --- /dev/null +++ b/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) diff --git a/tests/backtraces/guile-error-deep-in-thread.scm b/tests/backtraces/guile-error-deep-in-thread.scm new file mode 100644 index 0000000..405e2b9 --- /dev/null +++ b/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)))) diff --git a/tests/backtraces/guile-error-in-thread.scm b/tests/backtraces/guile-error-in-thread.scm new file mode 100644 index 0000000..3063dec --- /dev/null +++ b/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 diff --git a/tests/backtraces/nested-parallelism.scm b/tests/backtraces/nested-parallelism.scm new file mode 100644 index 0000000..ceb53b9 --- /dev/null +++ b/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)) + diff --git a/tests/backtraces/plain-exception.scm b/tests/backtraces/plain-exception.scm new file mode 100644 index 0000000..f2ab1a2 --- /dev/null +++ b/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 diff --git a/tests/backtraces/stack-situation-fibers.scm b/tests/backtraces/stack-situation-fibers.scm new file mode 100644 index 0000000..c1e9ec8 --- /dev/null +++ b/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) diff --git a/tests/backtraces/stack-situation-script.scm b/tests/backtraces/stack-situation-script.scm new file mode 100644 index 0000000..a21a8bd --- /dev/null +++ b/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"))) diff --git a/tests/backtraces/stack-situation-unknown.scm b/tests/backtraces/stack-situation-unknown.scm new file mode 100644 index 0000000..e95c263 --- /dev/null +++ b/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")))) diff --git a/tests/backtraces/temporary-thread.scm b/tests/backtraces/temporary-thread.scm new file mode 100644 index 0000000..a962a7b --- /dev/null +++ b/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 diff --git a/tests/backtraces/triple-with-exception-handler.scm b/tests/backtraces/triple-with-exception-handler.scm new file mode 100644 index 0000000..421f88e --- /dev/null +++ b/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 diff --git a/tests/backtraces/vhash-fold-in-thread.scm b/tests/backtraces/vhash-fold-in-thread.scm new file mode 100644 index 0000000..e0a37c3 --- /dev/null +++ b/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)))) diff --git a/tests/backtraces/vhash-fold.scm b/tests/backtraces/vhash-fold.scm new file mode 100644 index 0000000..56da6f6 --- /dev/null +++ b/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)) diff --git a/tests/backtraces/wrapped-exception.scm b/tests/backtraces/wrapped-exception.scm new file mode 100644 index 0000000..79d3843 --- /dev/null +++ b/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