Try and improve the print-backtrace-and-exception/knots output, be selective about the stack frames which are shown to try and produce some useful output which reflects user code and hide the &knots-exceptions. This commit also introduces a bunch of tests scripts that produce output from print-backtrace-and-exception/knots, to help test this code in different situations.
This commit is contained in:
parent
92c2fe46e7
commit
b3fa4d069b
21 changed files with 957 additions and 118 deletions
318
knots/backtraces.scm
Normal file
318
knots/backtraces.scm
Normal file
|
|
@ -0,0 +1,318 @@
|
|||
;;; Guile Knots
|
||||
;;; Copyright © 2026 Christopher Baines <mail@cbaines.net>
|
||||
;;;
|
||||
;;; This file is part of Guile Knots.
|
||||
;;;
|
||||
;;; The Guile Knots is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU General Public License as
|
||||
;;; published by the Free Software Foundation; either version 3 of the
|
||||
;;; License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; The Guile Knots is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with the guix-data-service. If not, see
|
||||
;;; <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (knots backtraces)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-43)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 format)
|
||||
#:use-module (system repl debug)
|
||||
#:use-module (system vm frame)
|
||||
#:use-module ((knots) #:select (display/knots
|
||||
simple-format/knots
|
||||
format/knots))
|
||||
#:export (&knots-exception
|
||||
make-knots-exception
|
||||
knots-exception?
|
||||
knots-exception-stack
|
||||
|
||||
print-backtrace-and-exception/knots
|
||||
|
||||
classify-stack-situation))
|
||||
|
||||
(define &knots-exception
|
||||
(make-exception-type '&knots-exception
|
||||
&exception
|
||||
'(stack)))
|
||||
|
||||
(define make-knots-exception
|
||||
(record-constructor &knots-exception))
|
||||
|
||||
(define knots-exception?
|
||||
(exception-predicate &knots-exception))
|
||||
|
||||
(define knots-exception-stack
|
||||
(exception-accessor
|
||||
&knots-exception
|
||||
(record-accessor &knots-exception 'stack)))
|
||||
|
||||
(define (backtrace-debug-mode?)
|
||||
(let ((val (getenv "KNOTS_BACKTRACE_DEBUG")))
|
||||
(and val
|
||||
(not (string=? val ""))
|
||||
(not (string=? val "0")))))
|
||||
|
||||
(define (debug-print-stack port label full-vec included-vec)
|
||||
(simple-format/knots port "[KNOTS DEBUG] ~A\n" label)
|
||||
(if (vector-empty? full-vec)
|
||||
(simple-format/knots port " (empty)\n")
|
||||
(vector-fold-right
|
||||
(lambda (i _ frame)
|
||||
(let ((marker
|
||||
(if (vector-index
|
||||
(lambda (f) (eq? f frame))
|
||||
included-vec)
|
||||
">" " "))
|
||||
(name
|
||||
(symbol->string
|
||||
(or (frame-procedure-name frame)
|
||||
'_))))
|
||||
(match (frame-source frame)
|
||||
(#f
|
||||
(format/knots port " ~a ~3d unknown ~a~%"
|
||||
marker i name))
|
||||
((_ file line . col)
|
||||
(format/knots port " ~a ~3d ~a:~a:~a ~a~%"
|
||||
marker i file (1+ line) col name)))))
|
||||
#f
|
||||
full-vec))
|
||||
(force-output port))
|
||||
|
||||
(define (internal-file? file)
|
||||
(or (string-prefix? "ice-9/" file)
|
||||
(string-prefix? "system/" file)
|
||||
(string-prefix? "srfi/" file)
|
||||
(string=? file "knots.scm")
|
||||
(string-prefix? "knots/" file)
|
||||
(string=? file "fibers.scm")
|
||||
(string-prefix? "fibers/" file)))
|
||||
|
||||
(define (frame-file frame)
|
||||
(let ((src (frame-source frame)))
|
||||
(and src (cadr src))))
|
||||
|
||||
(define (user-frame? frame)
|
||||
(let ((file (frame-file frame)))
|
||||
(and (string? file)
|
||||
(not (internal-file? file)))))
|
||||
|
||||
(define (raise-machinery-frame? frame)
|
||||
;; Return #t for frames that are part of the raise/unwind machinery
|
||||
;; and should be skipped when looking for the raise site.
|
||||
;; Specifically: C/unknown frames (no source file) and
|
||||
;; ice-9/boot-9.scm frames. Other internal frames such as
|
||||
;; ice-9/vlist.scm are part of the actual call path and should be
|
||||
;; preserved.
|
||||
(let ((file (frame-file frame)))
|
||||
(or (not file)
|
||||
(string=? file "ice-9/boot-9.scm"))))
|
||||
|
||||
(define (fibers-frame? frame)
|
||||
;; Return #t if FRAME belongs to the fibers library.
|
||||
(let ((file (frame-file frame)))
|
||||
(and (string? file)
|
||||
(or (string=? file "fibers.scm")
|
||||
(string-prefix? "fibers/" file)))))
|
||||
|
||||
;; The number of frames in Guile's eval-machinery tail appended to every
|
||||
;; top-level script stack:
|
||||
;;
|
||||
;; [n-6] ice-9/boot-9.scm _
|
||||
;; [n-5] ice-9/boot-9.scm save-module-excursion
|
||||
;; [n-4] ice-9/eval.scm _
|
||||
;; [n-3] ice-9/boot-9.scm call-with-prompt
|
||||
;; [n-2] C/unknown apply-smob/0
|
||||
;; [n-1] ice-9/boot-9.scm with-exception-handler
|
||||
(define script-eval-tail-length 6)
|
||||
|
||||
(define (classify-stack-situation stack-vector)
|
||||
(cond
|
||||
((vector-any fibers-frame? stack-vector)
|
||||
'run-fibers)
|
||||
((let ((len (vector-length stack-vector)))
|
||||
(and (>= len script-eval-tail-length)
|
||||
(equal? (frame-file (vector-ref stack-vector (- len 1)))
|
||||
"ice-9/boot-9.scm")
|
||||
(eq? (frame-procedure-name (vector-ref stack-vector (- len 3)))
|
||||
'call-with-prompt)
|
||||
(not (vector-any (lambda (frame)
|
||||
(eq? (frame-procedure-name frame)
|
||||
'%start-stack))
|
||||
stack-vector))))
|
||||
'script)
|
||||
(else
|
||||
'unknown)))
|
||||
|
||||
(define (filter-knots-stack-vector vector)
|
||||
;; Extract user frames from a pre-captured knots stack. The bottom 3 frames
|
||||
;; are always fixed overhead: make-stack (C), the handler body frame at the
|
||||
;; make-stack call site (exactly 1 Scheme frame), and raise-exception
|
||||
;; (boot-9). User frames start at index 3.
|
||||
(let ((last-user (vector-index-right user-frame? vector)))
|
||||
(if (or (not last-user) (< last-user 3))
|
||||
#()
|
||||
(vector-copy vector 3 (+ last-user 1)))))
|
||||
|
||||
(define (filter-stack-vector vector)
|
||||
;; Return the slice of VECTOR containing the frames relevant for
|
||||
;; display. Skips the fixed 2-frame overhead (make-stack + call
|
||||
;; site) and any raise machinery to find after-raise, then bounds at
|
||||
;; the eval-machinery tail (script) or the first fibers scheduler
|
||||
;; frame (run-fibers/unknown).
|
||||
|
||||
(define (skip-handler-and-raise vector start)
|
||||
;; Scan forward from START in VECTOR, first past any user frames
|
||||
;; (the handler body), then past raise-machinery frames (C/unknown
|
||||
;; and ice-9/boot-9.scm). Returns the index of the first
|
||||
;; remaining frame — the raise site or context. Other internal
|
||||
;; frames such as ice-9/vlist.scm are preserved because they are
|
||||
;; part of the actual call path.
|
||||
(let* ((len (vector-length vector))
|
||||
(after-handler
|
||||
(let loop ((i start))
|
||||
(if (or (>= i len) (not (user-frame? (vector-ref vector i))))
|
||||
i
|
||||
(loop (+ i 1))))))
|
||||
(let loop ((i after-handler))
|
||||
(cond
|
||||
((>= i len) i)
|
||||
((raise-machinery-frame? (vector-ref vector i)) (loop (+ i 1)))
|
||||
(else i)))))
|
||||
|
||||
(let* ((len (vector-length vector))
|
||||
(situation (classify-stack-situation vector))
|
||||
(after-raise (skip-handler-and-raise vector (min 2 len)))
|
||||
(end (if (and (eq? situation 'script)
|
||||
(> (- len script-eval-tail-length) after-raise))
|
||||
(- len script-eval-tail-length)
|
||||
(let loop ((i after-raise))
|
||||
(cond ((>= i len) i)
|
||||
((fibers-frame? (vector-ref vector i)) i)
|
||||
(else (loop (+ i 1))))))))
|
||||
(if (>= after-raise end)
|
||||
#()
|
||||
(vector-copy vector after-raise end))))
|
||||
|
||||
;; Based on print-frame from (system repl debug), but without the
|
||||
;; frame indexes
|
||||
(define* (print-frame/no-index frame
|
||||
#:optional (port (current-output-port))
|
||||
#:key (width (terminal-width))
|
||||
(last-source #f) (innermost? #f))
|
||||
(define (source-file src)
|
||||
(match src
|
||||
(#f "unknown file")
|
||||
((_ #f . _) "current input")
|
||||
((_ file . _) file)))
|
||||
(let* ((source (frame-source frame))
|
||||
(file (source-file source)))
|
||||
(when (not (equal? file (source-file last-source)))
|
||||
(format port "~&In ~a:~&" file))
|
||||
(format port "~9@a ~v:@y~%"
|
||||
(match source
|
||||
(#f "")
|
||||
((_ _ line . col) (simple-format #f "~A:~A" (1+ line) col)))
|
||||
width
|
||||
(frame-call-representation frame #:top-frame? innermost?))))
|
||||
|
||||
(define* (print-backtrace-and-exception/knots
|
||||
exn
|
||||
#:key (port (current-error-port)))
|
||||
(define (get-string out stack)
|
||||
(let* ((stack-vector (stack->vector stack))
|
||||
(knots-stack-vectors
|
||||
(map (lambda (exn)
|
||||
(stack->vector
|
||||
(knots-exception-stack exn)))
|
||||
(reverse
|
||||
(filter knots-exception?
|
||||
(simple-exceptions exn)))))
|
||||
(filtered-stack-vector
|
||||
(filter-stack-vector stack-vector))
|
||||
(filtered-knots-stack-vectors
|
||||
(map filter-knots-stack-vector knots-stack-vectors)))
|
||||
(when (backtrace-debug-mode?)
|
||||
(let ((debug-port (current-error-port))
|
||||
(situation (classify-stack-situation stack-vector)))
|
||||
(simple-format/knots
|
||||
debug-port
|
||||
"[KNOTS DEBUG] situation: ~A\n" situation)
|
||||
(debug-print-stack debug-port "stack"
|
||||
stack-vector filtered-stack-vector)
|
||||
(let ((stack-count (length knots-stack-vectors)))
|
||||
(for-each
|
||||
(lambda (knots-vec user-vec index)
|
||||
(debug-print-stack
|
||||
debug-port
|
||||
(format #f "knots stack ~a/~a" index stack-count)
|
||||
knots-vec user-vec))
|
||||
knots-stack-vectors
|
||||
filtered-knots-stack-vectors
|
||||
(iota stack-count 1)))
|
||||
(display/knots "\n" debug-port)
|
||||
(force-output debug-port)))
|
||||
|
||||
(for-each (lambda (vec)
|
||||
(vector-fold-right
|
||||
(lambda (i last-source frame)
|
||||
(print-frame/no-index frame out
|
||||
#:innermost? (= i 0)
|
||||
#:last-source last-source)
|
||||
(frame-source frame))
|
||||
#f
|
||||
vec))
|
||||
(cons filtered-stack-vector
|
||||
filtered-knots-stack-vectors))
|
||||
|
||||
(print-exception
|
||||
out
|
||||
#f
|
||||
'%exception
|
||||
(list (if (backtrace-debug-mode?)
|
||||
exn
|
||||
(apply make-exception
|
||||
(remove knots-exception?
|
||||
(simple-exceptions exn))))))))
|
||||
|
||||
(let* ((stack
|
||||
(match (fluid-ref %stacks)
|
||||
((stack-tag . prompt-tag)
|
||||
(make-stack #t
|
||||
0 prompt-tag
|
||||
0 (and prompt-tag 1)))
|
||||
(_
|
||||
(make-stack #t))))
|
||||
(string-port
|
||||
(open-output-string))
|
||||
(output
|
||||
(with-exception-handler
|
||||
(lambda (output-exn)
|
||||
(display/knots (get-output-string string-port)
|
||||
port)
|
||||
(close-output-port string-port)
|
||||
(display/knots "\n\n" port)
|
||||
|
||||
(let* ((stack (make-stack #t))
|
||||
(backtrace
|
||||
(call-with-output-string
|
||||
(lambda (port)
|
||||
(display-backtrace stack port)
|
||||
(newline port)))))
|
||||
(display/knots backtrace port))
|
||||
(simple-format/knots
|
||||
port
|
||||
"\nexception in print-backtrace-and-exception/knots: ~A\n"
|
||||
output-exn)
|
||||
(raise-exception output-exn))
|
||||
(lambda ()
|
||||
(get-string string-port stack)
|
||||
(let ((str (get-output-string string-port)))
|
||||
(close-output-port string-port)
|
||||
str)))))
|
||||
(display/knots output port)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue