Changeset 8974


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

Propagate r8973 here from the trunk, except in this branch, make :DIRECT the default *backtrace-format*.

Location:
branches/working-0711/ccl/lib
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/backtrace.lisp

    r8940 r8974  
    2828(defparameter *backtrace-print-length* 5)
    2929
     30(defparameter *backtrace-format* :direct
     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
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r8936 r8974  
    5656     *backtrace-print-length*
    5757     *backtrace-show-internal-frames*
     58     *backtrace-format*
    5859     *quit-on-eof*
    5960     macroexpand-all
Note: See TracChangeset for help on using the changeset viewer.