guile-knots/knots/backtraces.scm

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

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