dev/map-backtrace.lisp

   1 (in-package #:trivial-backtrace)
   2
   3 (defstruct frame
   4   func
   5   source-filename
   6   source-pos
   7   vars)
   8
   9 (defstruct var
  10   name
  11   value)
  12
  13 (defstruct pos-form-number
  14   number)
  15
  16 (defmethod print-object ((pos-form-number pos-form-number) stream)
  17   (cond
  18     (*print-readably* (call-next-method))
  19     (t
  20      (format stream "f~A" (pos-form-number-number pos-form-number)))))
  21
  22
  23 (defvar *trivial-backtrace-frame-print-specials*
  24   '((*print-length* . 100)
  25     (*print-level* . 20)
  26     (*print-lines* . 5)
  27     (*print-pretty* . t)
  28     (*print-readably* . nil)))
  29
  30 (defun print-frame (frame stream)
  31   (format stream "~A:~@[~A:~] ~A: ~%"
  32           (or (ignore-errors (translate-logical-pathname (frame-source-filename frame))) (frame-source-filename frame) "<unknown>")
  33           (frame-source-pos frame)
  34           (frame-func frame))
  35   (loop for var in (frame-vars frame)
  36         do
  37         (format stream " ~A = ~A~%" (var-name var)
  38                 (or (ignore-errors
  39                         (progv
  40                             (mapcar #'car *trivial-backtrace-frame-print-specials*)
  41                             (mapcar #'cdr *trivial-backtrace-frame-print-specials*)
  42                           (prin1-to-string
  43                            (var-value var))))
  44                     "<error>"))))
  45
  46 (defun map-backtrace (function)
  47   (impl-map-backtrace function))
  48
  49 (defun print-map-backtrace (&optional (stream *debug-io*) &rest args)
  50   (apply 'map-backtrace
  51          (lambda (frame)
  52            (print-frame frame stream)) args))
  53
  54 (defun backtrace-string (&rest args)
  55   (with-output-to-string (stream)
  56     (apply 'print-map-backtrace stream args)))
  57
  58
  59 #+ccl
  60 (defun impl-map-backtrace (func)
  61   (ccl::map-call-frames (lambda (ptr)
  62                           (multiple-value-bind (lfun pc)
  63                               (ccl::cfp-lfun ptr)
  64                             (let ((source-note (ccl:function-source-note lfun)))
  65                               (funcall func
  66                                        (make-frame :func (ccl::lfun-name lfun)
  67                                                    :source-filename (ccl:source-note-filename source-note)
  68                                                    :source-pos (let ((form-number (ccl:source-note-start-pos source-note)))
  69                                                                  (when form-number (make-pos-form-number :number form-number)))
  70                                                    :vars (loop for (name . value) in (ccl::arguments-and-locals nil ptr lfun pc)
  71                                                                collect (make-var :name name :value value)))))))))
  72
  73 #+sbcl
  74 (defun impl-map-backtrace (func)
  75   (loop for f = (or sb-debug:*stack-top-hint* (sb-di:top-frame)) then (sb-di:frame-down f)
  76         while f
  77         do (funcall func
  78                     (make-frame :func
  79                                 (ignore-errors
  80                                   (sb-di:debug-fun-name
  81                                    (sb-di:frame-debug-fun f)))
  82                                 :source-filename
  83                                 (ignore-errors
  84                                   (sb-di:debug-source-namestring (sb-di:code-location-debug-source (sb-di:frame-code-location f))))
  85                                 :source-pos
  86                                 (ignore-errors ;;; XXX does not work
  87                                   (let ((cloc (sb-di:frame-code-location f)))
  88                                     (unless (sb-di:code-location-unknown-p cloc)
  89                                       (format nil "tlf~Dfn~D"
  90                                               (sb-di:code-location-toplevel-form-offset cloc)
  91                                               (sb-di:code-location-form-number cloc)))))
  92                                 :vars
  93                                 (remove-if 'not
  94                                            (map 'list (lambda(v)
  95                                                         (ignore-errors
  96                                                           (when (eq :valid
  97                                                              (sb-di:debug-var-validity v (sb-di:frame-code-location f)))
  98                                                             (make-var :name (sb-di:debug-var-symbol v)
  99                                                                       :value (sb-di:debug-var-value v f)))))
 100                                                 (ignore-errors (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun f)))))))))
 101
 102 #-(or ccl sbcl)
 103 (defun impl-map-backtrace (func)
 104   (declare (ignore func))
 105   (warn "unable to map backtrace for ~a" (lisp-implementation-type)))