Changeset 8973


Ignore:
Timestamp:
Mar 31, 2008, 2:09:44 PM (12 years ago)
Author:
gz
Message:

Add support for a different backtrace formats with new variable
*BACKTRACE-FORMAT*, which can be :DIRECT or :TRADITIONAL.
:TRADITIONAL is the default. If *BACKTRACE-FORMAT* is :DIRECT,
backtrace shows non-toplevel functions being called directly (not
using FUNCALL), and also has assorted other tweaks, including not
showing frame address values, and explicitly labelling the arg and
locals sections and the pc offset.

Extend ccl:print-call-history with new keyword arguments:

:stream - default *debug-io*
:show-internal-frames - default *backtrace-show-internal-frames*
:print-level - default *backtrace-print-level*
:print-length - default *backtrace-print-length*
:format - default *backtrace-format*

Add CCL::BACKTRACE-AS-LIST, so can at least keep an eye on it. Make
it return the actual lfun when that's not a closure.

Location:
trunk/source/lib
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/backtrace.lisp

    r8942 r8973  
    2828(defparameter *backtrace-print-length* 5)
    2929
     30(defparameter *backtrace-format* :traditional
     31  "If :TRADITIONAL, shows calls to non-toplevel functions using FUNCALL, and shows frame address values.
     32   If :DIRECT, uses a more streamlined format.")
     33
     34(defun backtrace-as-list (&key
     35                          context
     36                          (origin (%get-frame-ptr))
     37                          (count most-positive-fixnum)
     38                          (start-frame-number 0)
     39                          (stream *debug-io*)
     40                          (print-level *backtrace-print-level*)
     41                          (print-length *backtrace-print-length*)
     42                          (show-internal-frames *backtrace-show-internal-frames*))
     43  "Returns a list representing the backtrace.
     44Each element in the list is a list that describes the call in one stack frame:
     45   (function arg1 arg2 ...)
     46The arguments are represented by strings, the function is a symbol or a function
     47object."
     48  (when (null count) (setq count most-positive-fixnum))
     49  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
     50         (*debug-io* stream)
     51         (*backtrace-print-level* print-level)
     52         (*backtrace-print-length* print-length)
     53         (*backtrace-show-internal-frames* show-internal-frames)
     54         (*backtrace-format* :list))
     55    (if (eq tcr (%current-tcr))
     56      (%backtrace-as-list-internal context origin count start-frame-number)
     57      (unwind-protect
     58           (progn
     59             (%suspend-tcr tcr)
     60             (%backtrace-as-list-internal context origin count start-frame-number))
     61        (%resume-tcr tcr)))))
     62
     63
    3064;;; This PRINTS the call history on *DEBUG-IO*.  It's more dangerous
    3165;;; (because of stack consing) to actually return it.
     
    3569                                (detailed-p t)
    3670                                (count most-positive-fixnum)
    37                                 (start-frame-number 0))
    38   (let* ((tcr (if context (bt.tcr context) (%current-tcr))))         
     71                                (start-frame-number 0)
     72                                (stream *debug-io*)
     73                                (print-level *backtrace-print-level*)
     74                                (print-length *backtrace-print-length*)
     75                                (show-internal-frames *backtrace-show-internal-frames*)
     76                                (format *backtrace-format*))
     77  (when (null count) (setq count most-positive-fixnum))
     78  (let* ((tcr (if context (bt.tcr context) (%current-tcr)))
     79         (*debug-io* stream)
     80         (*backtrace-print-level* print-level)
     81         (*backtrace-print-length* print-length)
     82         (*backtrace-show-internal-frames* show-internal-frames)
     83         (*backtrace-format* format))
    3984    (if (eq tcr (%current-tcr))
    40       (%print-call-history-internal context origin detailed-p (or count most-positive-fixnum) start-frame-number)
     85      (%print-call-history-internal context origin detailed-p count start-frame-number)
    4186      (unwind-protect
    4287           (progn
    4388             (%suspend-tcr tcr )
    44              (%print-call-history-internal context origin  detailed-p
    45                                            count start-frame-number))
     89             (%print-call-history-internal context origin detailed-p count start-frame-number))
    4690        (%resume-tcr tcr)))
    4791    (values)))
     
    82126      (let* ((unavailable (cons nil nil)))
    83127        (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable)
    84           (format t "~&  ~s" (arglist-from-map lfun))
     128          (case *backtrace-format*
     129            (:direct
     130               (format t "~&     Arguments: ~:s" (arglist-from-map lfun)))
     131            (t (format t "~&  ~s" (arglist-from-map lfun))))
    85132          (let* ((*print-length* *backtrace-print-length*)
    86133                 (*print-level* *backtrace-print-level*))
     
    91138                         (format t "#<Unavailable>")
    92139                         (format t "~s" val)))))
    93               (dolist (arg args)
    94                 (show-pair arg "   "))
    95               (terpri)
    96               (terpri)
    97               (dolist (loc locals)
    98                 (show-pair loc "  "))))))
     140              (case *backtrace-format*
     141                (:direct
     142                   (when args
     143                     (dolist (arg args)
     144                       (show-pair arg "       ")))
     145                   (when locals
     146                     ;; This shows all bindings (including specials), but help on debugger
     147                     ;; commands refers to "locals", so say both words...
     148                     (format t "~&     Local bindings:")
     149                     (dolist (loc locals)
     150                       (show-pair loc "       "))))
     151                (t
     152                   (dolist (arg args)
     153                     (show-pair arg "   "))
     154                   (terpri)
     155                   (terpri)
     156                   (dolist (loc locals)
     157                     (show-pair loc "  "))))))))
    99158    (error () (format t "#<error printing args and locals>")))
    100159  (terpri)
     
    103162
    104163(defun backtrace-call-arguments (context cfp lfun pc)
    105   (collect ((call))
    106     (let* ((name (function-name lfun)))
    107       (if (function-is-current-definition? lfun)
    108         (call name)
    109         (progn
    110           (call 'funcall)
    111           (call `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">")))))
    112       (if (and pc (<= pc target::arg-check-trap-pc-limit))
    113         (append (call) (arg-check-call-arguments cfp lfun))
    114         (multiple-value-bind (req opt restp keys)
    115             (function-args lfun)
    116           (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys)
    117             (let* ((arglist (arglist-from-map lfun)))
    118               (if (or (null arglist) (null pc))
    119                 (call "???")
    120                 (progn
    121                   (dotimes (i req)
    122                     (let* ((val (argument-value context cfp lfun pc (pop arglist))))
    123                       (if (eq val (%unbound-marker))
    124                         (call "?")
    125                         (call (let* ((*print-length* *backtrace-print-length*)
    126                                      (*print-level* *backtrace-print-level*))
    127                                 (format nil "~s" val))))))
    128                   (if (or restp keys (not (eql opt 0)))
    129                     (call "[...]"))))))
    130           (call))))))
    131 
     164  (nconc (let* ((name (function-name lfun)))
     165           (if (function-is-current-definition? lfun)
     166             (list name)
     167             (case *backtrace-format*
     168               (:direct
     169                  (list (format nil "~s" lfun)))
     170               (:list
     171                  (if (lfun-closure-p lfun) ;; could be stack consed
     172                    (list 'funcall (format nil "~s" lfun))
     173                    (list lfun)))
     174               (t (list 'funcall `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">")))))))
     175         (if (and pc (<= pc target::arg-check-trap-pc-limit))
     176           (arg-check-call-arguments cfp lfun)
     177           (collect ((call))
     178             (multiple-value-bind (req opt restp keys)
     179                 (function-args lfun)
     180               (when (or (not (eql 0 req)) (not (eql 0 opt)) restp keys)
     181                 (let* ((arglist (arglist-from-map lfun)))
     182                   (if (or (null arglist) (null pc))
     183                     (call "???")
     184                     (progn
     185                       (dotimes (i req)
     186                         (let* ((val (argument-value context cfp lfun pc (pop arglist))))
     187                           (if (eq val (%unbound-marker))
     188                             (call "?")
     189                             (call (let* ((*print-length* *backtrace-print-length*)
     190                                          (*print-level* *backtrace-print-level*))
     191                                     (format nil "~s" val))))))
     192                       (case *backtrace-format*
     193                         (:direct
     194                            (when (not (eql opt 0)) (call "[&optional ...]"))
     195                            (if keys
     196                              (call "[&key ...]")
     197                              (when restp (call "[&rest ...]"))))
     198                         (t (if (or restp keys (not (eql opt 0)))
     199                              (call "[...]"))))))))
     200               (call))))))
    132201
    133202;;; Return a list of "interesting" frame addresses in context, most
     
    157226        (funcall fn p)))))
    158227
     228(defun %backtrace-as-list-internal (context origin count skip-initial)
     229  (let ((*print-catch-errors* t)
     230        (p origin)
     231        (q (last-frame-ptr context)))
     232    (dotimes (i skip-initial)
     233      (setq p (parent-frame p context))
     234      (when (or (null p) (eq p q) (%stack< q p context))
     235        (return (setq p nil))))
     236    (do* ((frame-number (or skip-initial 0) (1+ frame-number))
     237          (i 0 (1+ i))
     238          (p p (parent-frame p context))
     239          (r '()))
     240        ((or (null p) (eq p q) (%stack< q p context)
     241             (>= i count))
     242         (nreverse r))
     243      (declare (fixnum frame-number i))
     244      (when (or (not (catch-csp-p p context))
     245                *backtrace-show-internal-frames*)
     246        (multiple-value-bind (lfun pc) (cfp-lfun p)
     247          (when (or lfun *backtrace-show-internal-frames*)
     248            (push
     249             (if lfun
     250               (backtrace-call-arguments context p lfun pc)
     251               "?????")
     252             r)))))))
     253
     254 
    159255(defun %print-call-history-internal (context origin detailed-p
    160256                                             &optional (count most-positive-fixnum) (skip-initial 0))
     
    181277            (unless (and (typep detailed-p 'fixnum)
    182278                         (not (= (the fixnum detailed-p) frame-number)))
    183               (format t "~&~c(~x) : ~D ~a ~d"
    184                       (if (exception-frame-p p)  #\* #\space)
    185                       (index->address p) frame-number
    186                       (if lfun (backtrace-call-arguments context p lfun pc))
    187                       pc)
     279              (%show-stack-frame-label frame-number p context lfun pc detailed-p)
    188280              (when detailed-p
    189281                (if (eq detailed-p :raw)
    190282                  (%show-stack-frame p context lfun pc)
    191283                  (%show-args-and-locals p context lfun pc))))))))))
     284
     285(defun %show-stack-frame-label (frame-number p context lfun pc detailed-p)
     286  (case *backtrace-format*
     287    (:direct
     288       (let ((call (backtrace-call-arguments context p lfun pc)))
     289         (format t "~&~3D: ~a ~a~@d~:[~; [Exception]~]"
     290                 frame-number
     291                 (if lfun
     292                   (if detailed-p (car call) call)
     293                   "<non-function frame>")
     294                 "at pc "
     295                 pc
     296                 (exception-frame-p p))))
     297    (t (format t "~&~c(~x) : ~D ~a ~d"
     298                      (if (exception-frame-p p)  #\* #\space)
     299                      (index->address p) frame-number
     300                      (if lfun (backtrace-call-arguments context p lfun pc))
     301                      pc))))
    192302
    193303
  • trunk/source/lib/ccl-export-syms.lisp

    r8775 r8973  
    5454     *backtrace-print-length*
    5555     *backtrace-show-internal-frames*
     56     *backtrace-format*
    5657     *quit-on-eof*
    5758     compiler-macroexpand
Note: See TracChangeset for help on using the changeset viewer.