diff --git a/Makefile.am b/Makefile.am index 3429a15..7942955 100644 --- a/Makefile.am +++ b/Makefile.am @@ -2,20 +2,18 @@ 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.scm + knots/web-server.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 e8e9690..ed353f1 100644 --- a/knots.scm +++ b/knots.scm @@ -1,25 +1,5 @@ -;;; 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) #: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) @@ -28,14 +8,7 @@ #:use-module (fibers) #:use-module (fibers channels) #:use-module (fibers conditions) - #: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) + #:use-module (system repl debug) #:export (call-with-default-io-waiters wait-when-system-clock-behind @@ -46,6 +19,13 @@ 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)) @@ -177,6 +157,114 @@ 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 deleted file mode 100644 index a12ecb6..0000000 --- a/knots/backtraces.scm +++ /dev/null @@ -1,318 +0,0 @@ -;;; 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/knots/web-server.scm b/knots/web-server.scm index 60b3f06..adaba13 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -317,19 +317,36 @@ on the procedure being called at any particular time." ;; Close the client port #f) -(define* (handle-request handler client sockaddr +(define (exception-handler exn request) + (let* ((error-string + (call-with-output-string + (lambda (port) + (simple-format + port + "exception when processing: ~A ~A\n" + (request-method request) + (uri-path (request-uri request))) + (print-backtrace-and-exception/knots + exn + #:port port))))) + (display/knots error-string + (current-error-port))) + + (values (build-response #:code 500) + ;; TODO Make this configurable + (string->utf8 + "internal server error"))) + +(define* (handle-request handler client read-request-exception-handler write-response-exception-handler buffer-size #:key post-request-hook) - (define meta - `((sockaddr . ,sockaddr))) - (let ((request (with-exception-handler read-request-exception-handler (lambda () - (read-request client meta)) + (read-request client)) #:unwind? #t)) (read-request-time (get-internal-real-time))) @@ -345,47 +362,36 @@ on the procedure being called at any particular time." (connection . (close)))) #vu8())) (else - (with-exception-handler - (lambda (exn) - (sanitize-response - request - (build-response #:code 500) - (string->utf8 - "internal server error"))) - (lambda () - (with-exception-handler - (lambda (exn) - (let* ((error-string - (call-with-output-string - (lambda (port) - (simple-format - port - "exception when processing: ~A ~A\n" - (request-method request) - (uri-path (request-uri request))) - (print-backtrace-and-exception/knots - exn - #:port port))))) - (display/knots error-string - (current-error-port)))) - (lambda () - (start-stack - #t + (call-with-escape-continuation + (lambda (return) + (with-exception-handler + (lambda (exn) (call-with-values (lambda () - (handler request)) - (match-lambda* - ((response body) - (sanitize-response request response body)) - (other - (raise-exception - (make-exception-with-irritants - (list (make-exception-with-message - (simple-format - #f - "wrong number of values returned from handler, expecting 2, got ~A" - (length other))) - handler))))))))))))))) + (exception-handler exn request)) + (lambda (response body) + (call-with-values + (lambda () + (sanitize-response request response body)) + return)))) + (lambda () + (start-stack + #t + (call-with-values + (lambda () + (handler request)) + (match-lambda* + ((response body) + (sanitize-response request response body)) + (other + (raise-exception + (make-exception-with-irritants + (list (make-exception-with-message + (simple-format + #f + "wrong number of values returned from handler, expecting 2, got ~A" + (length other))) + handler))))))))))))))) (with-exception-handler (lambda (exn) (write-response-exception-handler exn request)) @@ -452,7 +458,7 @@ on the procedure being called at any particular time." #f))) #:unwind? #t)))) -(define* (client-loop client handler sockaddr +(define* (client-loop client handler read-request-exception-handler write-response-exception-handler connection-idle-timeout @@ -497,7 +503,7 @@ on the procedure being called at any particular time." #:unwind? #t) (close-port client)) (else - (let ((keep-alive? (handle-request handler client sockaddr + (let ((keep-alive? (handle-request handler client read-request-exception-handler write-response-exception-handler buffer-size @@ -570,28 +576,19 @@ before sending back to the client." (spawn-fiber (lambda () - (while #t - (with-exception-handler - (const #t) - (lambda () - (with-exception-handler - (lambda (exn) - (print-backtrace-and-exception/knots exn)) - (lambda () - (let loop () - (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC)) - ((client . sockaddr) - (spawn-fiber (lambda () - (client-loop client handler sockaddr - read-request-exception-handler - write-response-exception-handler - connection-idle-timeout - connection-buffer-size - (post-request-hook/safe - post-request-hook))) - #:parallel? #t) - (loop))))))) - #:unwind? #t)))) + (let loop () + (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC)) + ((client . sockaddr) + (spawn-fiber (lambda () + (client-loop client handler + read-request-exception-handler + write-response-exception-handler + connection-idle-timeout + connection-buffer-size + (post-request-hook/safe + post-request-hook))) + #:parallel? #t) + (loop)))))) (make-web-server socket (vector-ref (getsockname socket) diff --git a/tests/backtraces.scm b/tests/backtraces.scm deleted file mode 100644 index c5f8e0e..0000000 --- a/tests/backtraces.scm +++ /dev/null @@ -1,319 +0,0 @@ -(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 deleted file mode 100644 index 2e641a2..0000000 --- a/tests/backtraces/call-with-cached-connection.scm +++ /dev/null @@ -1,18 +0,0 @@ -(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 deleted file mode 100644 index cdbce9e..0000000 --- a/tests/backtraces/call-with-resource-from-pool.scm +++ /dev/null @@ -1,16 +0,0 @@ -(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 deleted file mode 100644 index 0921a31..0000000 --- a/tests/backtraces/call-with-thread.scm +++ /dev/null @@ -1,14 +0,0 @@ -(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 deleted file mode 100644 index 7abef0c..0000000 --- a/tests/backtraces/fibers-force.scm +++ /dev/null @@ -1,15 +0,0 @@ -(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 deleted file mode 100644 index 24ef36c..0000000 --- a/tests/backtraces/fibers-map.scm +++ /dev/null @@ -1,20 +0,0 @@ -(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 deleted file mode 100644 index 405e2b9..0000000 --- a/tests/backtraces/guile-error-deep-in-thread.scm +++ /dev/null @@ -1,19 +0,0 @@ -(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 deleted file mode 100644 index 3063dec..0000000 --- a/tests/backtraces/guile-error-in-thread.scm +++ /dev/null @@ -1,11 +0,0 @@ -(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 deleted file mode 100644 index ceb53b9..0000000 --- a/tests/backtraces/nested-parallelism.scm +++ /dev/null @@ -1,40 +0,0 @@ -(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 deleted file mode 100644 index f2ab1a2..0000000 --- a/tests/backtraces/plain-exception.scm +++ /dev/null @@ -1,10 +0,0 @@ -(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 deleted file mode 100644 index c1e9ec8..0000000 --- a/tests/backtraces/stack-situation-fibers.scm +++ /dev/null @@ -1,19 +0,0 @@ -(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 deleted file mode 100644 index a21a8bd..0000000 --- a/tests/backtraces/stack-situation-script.scm +++ /dev/null @@ -1,15 +0,0 @@ -(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 deleted file mode 100644 index e95c263..0000000 --- a/tests/backtraces/stack-situation-unknown.scm +++ /dev/null @@ -1,17 +0,0 @@ -(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 deleted file mode 100644 index a962a7b..0000000 --- a/tests/backtraces/temporary-thread.scm +++ /dev/null @@ -1,11 +0,0 @@ -(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 deleted file mode 100644 index 421f88e..0000000 --- a/tests/backtraces/triple-with-exception-handler.scm +++ /dev/null @@ -1,16 +0,0 @@ -(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 deleted file mode 100644 index e0a37c3..0000000 --- a/tests/backtraces/vhash-fold-in-thread.scm +++ /dev/null @@ -1,26 +0,0 @@ -(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 deleted file mode 100644 index 56da6f6..0000000 --- a/tests/backtraces/vhash-fold.scm +++ /dev/null @@ -1,24 +0,0 @@ -(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 deleted file mode 100644 index 79d3843..0000000 --- a/tests/backtraces/wrapped-exception.scm +++ /dev/null @@ -1,16 +0,0 @@ -(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