Christopher Baines
d0ff89023b
All checks were successful
/ test (push) Successful in 6s
In the Guile Documenta generated documentation.
350 lines
13 KiB
Scheme
350 lines
13 KiB
Scheme
;;; 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))
|
|
|
|
(define &knots-exception
|
|
(make-exception-type '&knots-exception
|
|
&exception
|
|
'(stack)))
|
|
|
|
(define make-knots-exception
|
|
(record-constructor &knots-exception))
|
|
(set-procedure-property! make-knots-exception 'documentation
|
|
"Construct a @code{&knots-exception} with the given stack.")
|
|
|
|
(define knots-exception?
|
|
(exception-predicate &knots-exception))
|
|
(set-procedure-property! knots-exception? 'documentation
|
|
"Return @code{#t} if OBJ is a @code{&knots-exception}.")
|
|
|
|
(define knots-exception-stack
|
|
(exception-accessor
|
|
&knots-exception
|
|
(record-accessor &knots-exception 'stack)))
|
|
(set-procedure-property! knots-exception-stack 'documentation
|
|
"Return the stack from a @code{&knots-exception}.")
|
|
|
|
(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)))
|
|
"Print the backtrace and exception information from EXN to PORT. This
|
|
procedure captures the stack, so should be run before the stack is
|
|
unwound, so using @code{with-exception-handler} without
|
|
@code{#:unwind? #t}, the exception may need to then be re-raised and
|
|
handled in an outer exception handler.
|
|
|
|
@example
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
;; Recover from the exception
|
|
#f)
|
|
(lambda ()
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(print-backtrace-and-exception/knots exn)
|
|
(raise-exception exn))
|
|
(lambda ()
|
|
(do-things))))
|
|
#:unwind? #t)
|
|
@end example
|
|
|
|
It's important to use @code{print-backtrace-and-exception/knots} for
|
|
displaying backtraces involving functionality from Guile Knots, since
|
|
the stack involved is potentially split across several fibers. The
|
|
stacks involved are attached to the exception, and this procedure
|
|
extracts this information out and assembles a backtrace including all
|
|
the code involved.
|
|
"
|
|
(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)))
|