Ignore:
Timestamp:
Jul 26, 2009, 1:24:19 PM (10 years ago)
Author:
gz
Message:

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

File:
1 edited

Legend:

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

    r12193 r12463  
    6161The arguments are represented by strings, the function is a symbol or a function
    6262object."
    63   (when (null count) (setq count target::target-most-positive-fixnum))
    64   (when (and context process (neq (bt.tcr context) (process-tcr process)))
    65     (error "Context ~s doesn't correspond to the process ~s" context process))
    66   (let* ((tcr (cond (context (bt.tcr context))
    67                     (process (process-tcr process))
    68                     (t (%current-tcr))))
    69          (*backtrace-print-level* print-level)
     63  (let* ((*backtrace-print-level* print-level)
    7064         (*backtrace-print-length* print-length)
    71          (*backtrace-show-internal-frames* show-internal-frames)
    72          (*backtrace-format* :list))
    73     (if (eq tcr (%current-tcr))
    74       (%backtrace-as-list-internal context (or origin (%get-frame-ptr)) count start-frame-number)
    75       (unwind-protect
    76            (progn
    77              (%suspend-tcr tcr)
    78              (unless context
    79                (setq context (context-for-suspended-tcr tcr)))
    80              (%backtrace-as-list-internal context (or origin (bt.current context)) count start-frame-number))
    81         (%resume-tcr tcr)))))
    82 
    83 
    84 ;;; This PRINTS the call history on *DEBUG-IO*.  It's more dangerous
    85 ;;; (because of stack consing) to actually return it.
    86                                
     65         (*backtrace-format* :list)
     66         (result nil))
     67    (map-call-frames (lambda (p context)
     68                       (multiple-value-bind (lfun pc) (cfp-lfun p)
     69                         (push (if lfun
     70                                 (backtrace-call-arguments context p lfun pc)
     71                                 "?????")
     72                               result)))
     73                     :context context
     74                     :process process
     75                     :origin origin
     76                     :count count
     77                     :start-frame-number start-frame-number
     78                     :test (and (not show-internal-frames) 'function-frame-p))
     79    (nreverse result)))
     80
    8781(defun print-call-history (&key context
    8882                                process
     
    9690                                (show-internal-frames *backtrace-show-internal-frames*)
    9791                                (format *backtrace-format*))
    98   (when (null count) (setq count target::target-most-positive-fixnum))
     92  (let ((*backtrace-print-level* print-level)
     93        (*backtrace-print-length* print-length)
     94        (*backtrace-format* format)
     95        (*standard-output* stream)
     96        (*print-circle* nil)
     97        (frame-number (or start-frame-number 0)))
     98    (map-call-frames (lambda (p context)
     99                       (multiple-value-bind (lfun pc) (cfp-lfun p)
     100                         (unless (and (typep detailed-p 'fixnum)
     101                                      (not (= (the fixnum detailed-p) frame-number)))
     102                           (%show-stack-frame-label frame-number p context lfun pc detailed-p)
     103                           (when detailed-p
     104                             (if (eq detailed-p :raw)
     105                               (%show-stack-frame p context lfun pc)
     106                               (%show-args-and-locals p context lfun pc)))
     107                           (incf frame-number))))
     108                     :context context
     109                     :process process
     110                     :origin origin
     111                     :count count
     112                     :start-frame-number start-frame-number
     113                     :test (and (not show-internal-frames) 'function-frame-p))
     114    (values)))
     115
     116(defun function-frame-p (p context)
     117  (and (not (catch-csp-p p context)) (cfp-lfun p)))
     118
     119(defun map-call-frames (fn &key context
     120                           process
     121                           origin
     122                           (count target::target-most-positive-fixnum)
     123                           (start-frame-number 0)
     124                           test)
    99125  (when (and context process (neq (bt.tcr context) (process-tcr process)))
    100126    (error "Context ~s doesn't correspond to the process ~s" context process))
    101   (let* ((tcr (cond (context (bt.tcr context))
    102                     (process (process-tcr process))
    103                     (t (%current-tcr))))
    104          (*backtrace-print-level* print-level)
    105          (*backtrace-print-length* print-length)
    106          (*backtrace-show-internal-frames* show-internal-frames)
    107          (*backtrace-format* format))
     127  (let ((tcr (cond (context (bt.tcr context))
     128                   (process (process-tcr process))
     129                   (t (%current-tcr))))
     130        (*print-catch-errors* t)
     131        (*signal-printing-errors* nil))
    108132    (if (eq tcr (%current-tcr))
    109       (%print-call-history-internal context (or origin (%get-frame-ptr)) detailed-p count start-frame-number stream)
    110       (unwind-protect
    111            (progn
    112              (%suspend-tcr tcr)
    113              (unless context
    114                (setq context (context-for-suspended-tcr tcr)))
    115              (%print-call-history-internal context (or origin (bt.current context)) detailed-p count start-frame-number stream))
    116         (%resume-tcr tcr)))
    117     (values)))
    118 
    119 (defun map-call-frames (fn &key context
    120                            (origin (%get-frame-ptr))
    121                            (start-frame-number 0)
    122                            (include-internal nil))
    123   (let* ((tcr (if context (bt.tcr context) (%current-tcr))))
    124     (if (eq tcr (%current-tcr))
    125       (%map-call-frames-internal fn context origin include-internal start-frame-number)
     133      (%map-call-frames-internal fn context (or origin (%get-frame-ptr)) count start-frame-number test)
    126134      (unwind-protect
    127135           (progn
    128136             (%suspend-tcr tcr)
    129              (%map-call-frames-internal fn context origin include-internal start-frame-number))
     137             (when (null context)
     138               (setq context (context-for-suspended-tcr tcr)))
     139             (%map-call-frames-internal fn context (or origin (bt.current context))  count start-frame-number test))
    130140        (%resume-tcr tcr))))
    131141  nil)
    132142
     143; RAW case
    133144(defun %show-stack-frame (p context lfun pc)
    134145  (handler-case
     
    200211
    201212(defun backtrace-supplied-args (context frame lfun pc)
    202   (if (and pc (<= pc target::arg-check-trap-pc-limit))
    203     (arg-check-call-arguments frame lfun)
    204     (multiple-value-bind (params valid) (arglist-from-map lfun)
    205       (if (not valid)
    206         '("???")
    207         (let ((args (arguments-and-locals context frame lfun pc)) ;overkill, but will do.
    208               (state :required)
    209               (strings ()))
    210           (flet ((collect (arg)
    211                    (let* ((*print-length* *backtrace-print-length*)
    212                           (*print-level* *backtrace-print-level*))
    213                      (push (format nil "~s" arg) strings))))
    214             (dolist (param params)
    215               (if (or (member param lambda-list-keywords) (eq param '&lexpr))
    216                 (setq state param)
    217                 (let* ((pair (pop args))
    218                        (value (cdr pair)))
    219                   (case state
    220                     (&lexpr
    221                        (with-list-from-lexpr (rest value)
    222                          (dolist (r rest) (collect r)))
    223                        (return))
    224                     (&rest
    225                        (dolist (r value) (collect r))
    226                        (return))
    227                     (&key (collect param)))
    228                   (if (eq value (%unbound-marker))
    229                     (push "?" strings)
    230                     (collect value))))))
    231           (nreverse strings))))))
     213  (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc)
     214    (if (not valid)
     215      '("???")   
     216      (loop for arg in args
     217            collect (if (eq arg (%unbound-marker))
     218                      "?"
     219                      (let* ((*print-length* *backtrace-print-length*)
     220                             (*print-level* *backtrace-print-level*))
     221                        (format nil "~s" arg)))))))
    232222
    233223;;; Return a list of "interesting" frame addresses in context, most
     
    241231        (when (or (cfp-lfun p) include-internal)
    242232          (frames p))))))
    243    
    244 (defun %map-call-frames-internal (fn context origin include-internal skip-initial)
    245   (let ((*standard-output* *debug-io*)
    246         (*print-circle* nil)
    247         (p origin)
    248         (q (last-frame-ptr context)))
    249     (dotimes (i skip-initial)
    250       (setq p (parent-frame p context))
    251       (when (or (null p) (eq p q) (%stack< q p context))
    252         (return (setq p nil))))
    253     (do* ((p p (parent-frame p context)))
    254          ((or (null p) (eq p q) (%stack< q p context)) nil)
    255       (when (or include-internal
    256                 (and (not (catch-csp-p p context)) (cfp-lfun p)))
    257         (funcall fn p)))))
    258 
    259 (defun %backtrace-as-list-internal (context origin count skip-initial)
     233
     234(defun %map-call-frames-internal (fn context origin count skip-initial test)
     235  (when (null skip-initial) (setq skip-initial 0))
     236  (when (null count) (setq count target::target-most-positive-fixnum))
    260237  (unless (eq (last-frame-ptr context origin) (last-frame-ptr context))
    261238    (error "Origin ~s is not in the stack of ~s" origin context))
    262   (let ((*print-catch-errors* t)
    263         (p origin)
    264         (q (last-frame-ptr context)))
    265     (dotimes (i skip-initial)
    266       (setq p (parent-frame p context))
    267       (when (or (null p) (eq p q) (%stack< q p context))
    268         (return (setq p nil))))
    269     (do* ((frame-number (or skip-initial 0) (1+ frame-number))
    270           (i 0 (1+ i))
    271           (p p (parent-frame p context))
    272           (r '()))
    273         ((or (null p) (eq p q) (%stack< q p context)
    274              (>= i count))
    275          (nreverse r))
    276       (declare (fixnum frame-number i))
    277       (when (or (not (catch-csp-p p context))
    278                 *backtrace-show-internal-frames*)
    279         (multiple-value-bind (lfun pc) (cfp-lfun p)
    280           (when (or lfun *backtrace-show-internal-frames*)
    281             (push
    282              (if lfun
    283                (backtrace-call-arguments context p lfun pc)
    284                "?????")
    285              r)))))))
    286 
    287  
    288 (defun %print-call-history-internal (context origin detailed-p
    289                                              &optional (count target::target-most-positive-fixnum)
    290                                                        (skip-initial 0)
    291                                                        (stream *debug-io*))
    292   (unless (eq (last-frame-ptr context origin) (last-frame-ptr context))
    293     (error "Origin ~s is not in the stack of ~s" origin context))
    294   (let ((*standard-output* stream)
    295         (*print-circle* nil)
    296         (*print-catch-errors* t)
    297         (p origin)
    298         (q (last-frame-ptr context)))
    299     (dotimes (i skip-initial)
    300       (setq p (parent-frame p context))
    301       (when (or (null p) (eq p q) (%stack< q p context))
    302         (return (setq p nil))))
    303     (do* ((frame-number (or skip-initial 0) (1+ frame-number))
    304           (i 0 (1+ i))
    305           (p p (parent-frame p context)))
    306          ((or (null p) (eq p q) (%stack< q p context)
    307               (>= i count))
    308           (values))
    309       (declare (fixnum frame-number i))
    310       (when (or (not (catch-csp-p p context))
    311                 *backtrace-show-internal-frames*)
    312         (multiple-value-bind (lfun pc) (cfp-lfun p)
    313           (when (or lfun *backtrace-show-internal-frames*)
    314             (unless (and (typep detailed-p 'fixnum)
    315                          (not (= (the fixnum detailed-p) frame-number)))
    316               (%show-stack-frame-label frame-number p context lfun pc detailed-p)
    317               (when detailed-p
    318                 (if (eq detailed-p :raw)
    319                   (%show-stack-frame p context lfun pc)
    320                   (%show-args-and-locals p context lfun pc))))))))))
     239  (let ((q (last-frame-ptr context))
     240        (frame-number 0))
     241    (do ((p origin (parent-frame p context)))
     242        ((or (null p) (eq p q) (%stack< q p context) (<= count 0)) nil)
     243      (when (or (null test) (funcall test p context))
     244        (when (<= skip-initial frame-number)
     245          (funcall fn p context)
     246          (decf count))
     247        (incf frame-number)))))
    321248
    322249(defun %show-stack-frame-label (frame-number p context lfun pc detailed-p)
     
    686613              (dolist (name local-vars)
    687614                (get-local-value name)))))
    688         (values (args) (locals))))))
    689                    
    690            
     615           (values (args) (locals))))))
     616
     617;; Return list of supplied arguments, as best we can reconstruct it.
     618(defun supplied-argument-list (context frame lfun pc)
     619  (if (null pc)
     620    (values nil nil)
     621    (if (<= pc target::arg-check-trap-pc-limit)
     622      (values (arg-check-call-arguments frame lfun) t)
     623      (multiple-value-bind (params valid) (arglist-from-map lfun)
     624        (if (not valid)
     625          (values nil nil)
     626          (let* ((args (arguments-and-locals context frame lfun pc)) ;overkill, but will do.
     627                 (state :required)
     628                 (result ()))
     629            (dolist (param params)
     630              (if (or (member param lambda-list-keywords) (eq param '&lexpr))
     631                (setq state param)
     632                (let* ((pair (pop args))
     633                       (value (cdr pair)))
     634                  (case state
     635                    (&lexpr
     636                     (with-list-from-lexpr (rest value)
     637                       (dolist (r rest) (push r result)))
     638                     (return))
     639                    (&rest
     640                     (dolist (r value) (push r result))
     641                     (return))
     642                    (&key (push param result)))
     643                  (push value result))))
     644            (values (nreverse result) t)))))))
     645
    691646
    692647(defun safe-cell-value (val)
Note: See TracChangeset for help on using the changeset viewer.