Changeset 12652


Ignore:
Timestamp:
Aug 23, 2009, 5:07:19 PM (10 years ago)
Author:
gz
Message:

In cocoa backtrace: change the double-click action on a frame to go to the source location instead of inspecting the frame function. Add a line for the frame function to frame children, so can still inspect the function by clicking on that.

While in there, made the cocoa backtrace use the standard backtrace api, so it shows the same info as command line and Slime, and made the frame labels show the arguments as well as the function name.

Location:
trunk/source/cocoa-ide
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • trunk/source/cocoa-ide/cocoa-backtrace.lisp

    r12526 r12652  
    55(in-package "GUI")
    66
     7(defclass stack-descriptor ()
     8  ((context :initarg :context :reader stack-descriptor-context)
     9   (filter :initform nil :initarg :filter :reader stack-descriptor-filter)
     10   (interruptable-p :initform t :accessor stack-descriptor-interruptable-p)
     11   (segment-size :initform 50 :reader stack-descriptor-segment-size)
     12   (frame-count :initform -1 :reader stack-descriptor-frame-count)
     13   (frame-cache :initform (make-hash-table) :reader stack-descriptor-frame-cache)))
     14
     15(defun make-stack-descriptor (context &rest keys)
     16  (apply #'make-instance 'stack-descriptor
     17         ;; For some reason backtrace context is an anonymous vector
     18         :context (require-type context 'simple-vector)
     19         keys))
     20
     21(defmethod initialize-instance :after ((sd stack-descriptor) &key &allow-other-keys)
     22  (with-slots (frame-count) sd
     23    (setf frame-count (count-stack-descriptor-frames sd))))
     24
     25(defmethod stack-descriptor-refresh ((sd stack-descriptor))
     26  (clrhash (stack-descriptor-frame-cache sd)))
     27
     28(defmethod stack-descriptor-origin ((sd stack-descriptor))
     29  (ccl::bt.youngest (stack-descriptor-context sd)))
     30
     31(defmethod stack-descriptor-process ((sd stack-descriptor))
     32  (ccl::tcr->process (ccl::bt.tcr (stack-descriptor-context sd))))
     33
     34(defmethod stack-descriptor-condition ((sd stack-descriptor))
     35  (ccl::bt.break-condition (stack-descriptor-context sd)))
     36
     37(defmethod map-stack-frames (sd function &optional start end)
     38  (ccl:map-call-frames function
     39                       :origin (stack-descriptor-origin sd)
     40                       :process (stack-descriptor-process sd)
     41                       :test (stack-descriptor-filter sd)
     42                       :start-frame-number (or start 0)
     43                       :count (- (or end most-positive-fixnum)
     44                                 (or start 0))))
     45
     46(defmethod count-stack-descriptor-frames ((sd stack-descriptor))
     47  (let ((count 0))
     48    (map-stack-frames sd (lambda (fp context)
     49                           (declare (ignore fp context))
     50                           (incf count)))
     51    count))
     52
     53;; Function must be side-effect free, it may be restarted or aborted.
     54(defun collect-stack-frames (sd function &optional start end)
     55  (let ((process (stack-descriptor-process sd)))
     56    ;; In general, it's best to run backtrace printing in the error process, since
     57    ;; printing often depends on the dynamic state (e.g. bound vars) at the point of
     58    ;; error.  However, if the erring process is wedged in some way, getting at it
     59    ;; from outside may be better than nothing.
     60    (if (or (not (stack-descriptor-interruptable-p sd))
     61            (eq process *current-process*))
     62      (let* ((results nil)
     63             (*print-level* *backtrace-print-level*)
     64             (*print-length* *backtrace-print-length*)
     65             (*print-circle* (null *print-level*)))
     66        (map-stack-frames sd (lambda (fp context)
     67                               (push (funcall function fp context) results))
     68                          start end)
     69        (nreverse results))
     70      (let ((s (make-semaphore))
     71            (res :none))
     72        (process-interrupt process
     73                           (lambda ()
     74                             (ignore-errors (setq res (collect-stack-frames sd function start end)))
     75                             (signal-semaphore s)))
     76        (timed-wait-on-semaphore s 2) ;; give it 2 seconds before going to plan B...
     77        (if (eq res :none)
     78          (progn
     79            (setf (stack-descriptor-interruptable-p sd) nil)
     80            (collect-stack-frames sd function start end))
     81          res)))))
     82
     83(defclass frame-descriptor ()
     84  ((data :initarg :data :reader frame-descriptor-data)
     85   (label :initarg :label :reader frame-descriptor-label)
     86   (values :initarg :values :reader frame-descriptor-values)))
     87
     88(defun make-frame-descriptor (fp context)
     89  (let* ((args (ccl:frame-supplied-arguments fp context))
     90         (vars (ccl:frame-named-variables fp context))
     91         (lfun (ccl:frame-function fp context)))
     92    (make-instance 'frame-descriptor
     93      :data (cons fp context)
     94      :label (with-output-to-string (stream)
     95               (format stream "(~S" (or (ccl:function-name lfun) lfun))
     96               (if (eq args (ccl::%unbound-marker))
     97                 (format stream " #<Unknown Arguments>")
     98                 (loop for arg in args
     99                   do (if (eq arg (ccl::%unbound-marker))
     100                        (format stream " #<Unavailable>")
     101                        (format stream " ~:['~;~]~s" (ccl::self-evaluating-p arg) arg))))
     102               (format stream ")"))
     103      :values (map 'vector
     104                   (lambda (var.val)
     105                     (destructuring-bind (var . val) var.val
     106                       (let ((label (format nil "~:[~s~;~a~]: ~s"
     107                                            (stringp var) var val)))
     108                         (cons label var.val))))
     109                   (cons `("Function" . ,lfun) vars)))))
     110
     111(defmethod stack-descriptor-frame ((sd stack-descriptor) index)
     112  (let ((cache (stack-descriptor-frame-cache sd)))
     113    (or (gethash index cache)
     114        ;; get a bunch at once.
     115        (let* ((segment-size (stack-descriptor-segment-size sd))
     116               (start (- index (rem index segment-size)))
     117               (end (+ start segment-size))
     118               (frames (collect-stack-frames sd #'make-frame-descriptor start end)))
     119          (loop for n upfrom start as frame in frames do (setf (gethash n cache) frame))
     120          (gethash index cache)))))
     121
     122(defun frame-descriptor-function (frame)
     123  (destructuring-bind (fp . context) (frame-descriptor-data frame)
     124    (ccl:frame-function fp context)))
     125
     126;; Don't bother making first-class frame value descriptors = frame + index
     127
     128(defun frame-descriptor-value-count (frame)
     129  (length (frame-descriptor-values frame)))
     130
     131(defun frame-descriptor-value-label (frame index)
     132  (car (svref (frame-descriptor-values frame) index)))
     133
     134(defun frame-descriptor-value (frame index)
     135  (destructuring-bind (var . val)
     136                      (cdr (svref (frame-descriptor-values frame) index))
     137    (values val var)))
     138
     139(defun backtrace-frame-default-action (frame &optional index)
     140  (if index
     141    (inspect (frame-descriptor-value frame index))
     142    (multiple-value-bind (lfun pc) (frame-descriptor-function frame)
     143      (when lfun
     144        (let ((source (or (and pc (ccl:find-source-note-at-pc lfun pc))
     145                          (ccl:function-source-note lfun))))
     146          (if (source-note-p source)
     147            (hemlock-ext:execute-in-file-view
     148             (ccl:source-note-filename source)
     149             (lambda  ()
     150               (hemlock::move-to-source-note source)))
     151            (hemlock::edit-definition lfun)))))))
     152
     153;; Cocoa layer
     154
    7155(defclass ns-lisp-string (ns:ns-string)
    8     ((lisp-string :initarg :string :reader ns-lisp-string-string))
     156    ()
    9157  (:metaclass ns:+ns-object))
     158
     159(defgeneric ns-lisp-string-string (ns-lisp-string))
    10160
    11161(objc:defmethod (#/length :<NSUI>nteger) ((self ns-lisp-string))
    … …  
    13163
    14164(objc:defmethod (#/characterAtIndex: :unichar) ((self ns-lisp-string) (index :<NSUI>nteger))
    15   (char-code (schar (ns-lisp-string-string self) index)))
    16 
    17 (objc:defmethod (#/dealloc :void) ((self ns-lisp-string))
    18   (ccl::%remove-lisp-slot-vector self)
    19   (call-next-method))
    20 
     165  (char-code (char (ns-lisp-string-string self) index)))
    21166
    22167(defclass frame-label (ns-lisp-string)
    23168    ((frame-number  :foreign-type :int :accessor frame-label-number)
    24      (controller :foreign-type :id :reader frame-label-controller)
    25      (frame-inspector :initform nil :accessor frame-label-frame-inspector))
     169     (controller :foreign-type :id :reader frame-label-controller))
    26170  (:metaclass ns:+ns-object))
     171
     172(defmethod frame-label-descriptor ((self frame-label))
     173  (stack-descriptor-frame
     174    (backtrace-controller-stack-descriptor (frame-label-controller self))
     175    (frame-label-number self)))
     176 
     177(defmethod ns-lisp-string-string ((self frame-label))
     178  (frame-descriptor-label (frame-label-descriptor self)))
    27179
    28180(objc:defmethod #/initWithFrameNumber:controller: ((self frame-label) (frame-number :int) controller)
    … …  
    39191  (:metaclass ns:+ns-object))
    40192
     193(defmethod ns-lisp-string-string ((self item-label))
     194  (frame-descriptor-value-label (frame-label-descriptor (item-label-label self))
     195                                (item-label-index self)))
     196
    41197(objc:defmethod #/initWithFrameLabel:index: ((self item-label) the-frame-label (index :int))
    42198  (let* ((obj (#/init self)))
    … …  
    48204(defclass backtrace-window-controller (ns:ns-window-controller)
    49205    ((context :initarg :context :reader backtrace-controller-context)
    50      (inspector :initform nil :reader backtrace-controller-inspector)
     206     (stack-descriptor :initform nil :reader backtrace-controller-stack-descriptor)
    51207     (outline-view :foreign-type :id :reader backtrace-controller-outline-view))
    52208  (:metaclass ns:+ns-object))
     209
     210(defmethod backtrace-controller-process ((self backtrace-window-controller))
     211  (let ((context (backtrace-controller-context self)))
     212    (and context (ccl::tcr->process (ccl::bt.tcr context)))))
     213
     214(defmethod backtrace-controller-break-level ((self backtrace-window-controller))
     215  (let ((context (backtrace-controller-context self)))
     216    (and context (ccl::bt.break-level context))))
    53217
    54218(objc:defmethod #/windowNibName ((self backtrace-window-controller))
    … …  
    67231(def-cocoa-default *backtrace-font-size* :float 9.0f0 "Size of font used in backtrace views")
    68232
    69 
    70 (defun context-process (context)
    71   (and context (ccl::tcr->process (ccl::bt.tcr context))))
    72233
    73234(objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller))
    … …  
    87248            (when (eql i 0)
    88249              (let* ((header-cell (#/headerCell column))
    89                      (inspector (backtrace-controller-inspector self))
    90                      (break-condition
    91                       (inspector::break-condition
    92                                  (inspector::inspector-object inspector)))
     250                     (sd (backtrace-controller-stack-descriptor self))
     251                     (break-condition (stack-descriptor-condition sd))
    93252                     (break-condition-string
    94253                      (let* ((*print-level* 5)
    … …  
    102261    (let* ((window (#/window  self)))
    103262      (unless (%null-ptr-p window)
    104         (let* ((context (backtrace-controller-context self))
    105                (process (context-process context))
     263        (let* ((process (backtrace-controller-process self))
    106264               (listener-window (if (typep process 'cocoa-listener-process)
    107265                                  (cocoa-listener-process-window process))))
    … …  
    118276                                        (process-name process)
    119277                                        (process-serial-number process)
    120                                         (ccl::bt.break-level context)))))))))
     278                                        (backtrace-controller-break-level self)))))))))
    121279
    122280(objc:defmethod (#/continue: :void) ((self backtrace-window-controller) sender)
    123281  (declare (ignore sender))
    124   (let* ((context (backtrace-controller-context self))
    125          (process (context-process context)))
     282  (let ((process (backtrace-controller-process self)))
    126283    (when process (process-interrupt process #'continue))))
    127284
    128285(objc:defmethod (#/exitBreak: :void) ((self backtrace-window-controller) sender)
    129286  (declare (ignore sender))
    130   (let* ((context (backtrace-controller-context self))
    131          (process (context-process context)))
     287  (let ((process (backtrace-controller-process self)))
    132288    (when process (process-interrupt process #'abort-break))))
    133289
    … …  
    137293      (#/showWindow: (restarts-controller-for-context context) sender))))
    138294
    139 
    140 
    141295(objc:defmethod (#/backtraceDoubleClick: :void)
    142296    ((self backtrace-window-controller) sender)
    143297  (let* ((row (#/clickedRow sender)))
    144298    (if (>= row 0)
    145       (let* ((item (#/itemAtRow: sender row))
    146              (val-p nil)
    147              (value nil))
     299      (let* ((item (#/itemAtRow: sender row)))
    148300        (cond ((typep item 'frame-label)
    149                (let* ((controller (frame-label-controller item))
    150                       (inspector (backtrace-controller-inspector controller))
    151                       (frame-number (frame-label-number item)))
    152                  (setq val-p t value (inspector::line-n inspector frame-number))))
     301               (let ((frame (frame-label-descriptor item)))
     302                 (backtrace-frame-default-action frame)))
    153303              ((typep item 'item-label)
    154                (let* ((the-frame-label (item-label-label item))
    155                       (frame-inspector (frame-label-frame-inspector the-frame-label))
    156                       (index (item-label-index item))
    157                       (rawval (inspector::line-n frame-inspector index)))
    158                  (if (and (consp rawval)
    159                           (typep (car rawval) 'keyword))
    160                  (setq val-p t value (cddr rawval))))))
    161         (if val-p
    162           (inspect value))))))
    163 
    164 
    165 
     304               (let* ((frame (frame-label-descriptor (item-label-label item)))
     305                      (index (item-label-index item)))
     306                 (backtrace-frame-default-action frame index))))))))
    166307
    167308(objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>)
    … …  
    174315    ((self backtrace-window-controller) view item)
    175316    (declare (ignore view))
    176     (let* ((inspector (backtrace-controller-inspector self)))
     317    (let* ((sd (backtrace-controller-stack-descriptor self)))
    177318      (cond ((%null-ptr-p item)
    178              (inspector::inspector-line-count inspector))
     319             (stack-descriptor-frame-count sd))
    179320            ((our-frame-label-p self item)
    180              (let* ((frame-inspector
    181                      (or (frame-label-frame-inspector item)
    182                          (setf (frame-label-frame-inspector item)
    183                                (make-instance
    184                                 'inspector::stack-frame-inspector
    185                                 :frame-number (frame-label-number item)
    186                                 :object (inspector::inspector-object inspector)
    187                                 :update-line-count t)))))
    188                (inspector::inspector-line-count frame-inspector)))
     321             (let ((frame (stack-descriptor-frame sd (frame-label-number item))))
     322               (frame-descriptor-value-count frame)))
    189323            (t -1))))
    190324
    … …  
    192326    ((self backtrace-window-controller) view (index :<NSI>nteger) item)
    193327  (declare (ignore view))
    194   (let* ((inspector (backtrace-controller-inspector self)))
    195     (cond ((%null-ptr-p item)
    196            (let* ((label
    197                    (make-instance 'frame-label
    198                                   :with-frame-number index
    199                                   :controller self
    200                                   :string
    201                                   (let* ((value
    202                                           (inspector::line-n inspector index)))
    203                                     (if value
    204                                       (ccl::%lfun-name-string value)
    205                                       ":kernel")))))
    206              label))
    207           ((our-frame-label-p self item)
    208            (let* ((frame-inspector
    209                    (or (frame-label-frame-inspector item)
    210                        (setf (frame-label-frame-inspector item)
    211                              (make-instance
    212                               'inspector::stack-frame-inspector
    213                               :frame-number (frame-label-number item)
    214                               :object (inspector::inspector-object inspector)
    215                               :update-line-count t)))))
    216              (make-instance 'item-label
    217                             :with-frame-label item
    218                             :index index
    219                             :string
    220                             (let* ((ccl::*aux-vsp-ranges* (inspector::vsp-range inspector))
    221                                    (ccl::*aux-tsp-ranges* (inspector::tsp-range inspector))
    222                                    (ccl::*aux-csp-ranges* (inspector::csp-range inspector)))
    223                               (with-output-to-string (s)
    224                                                      (let* ((value
    225                                                              (inspector::line-n
    226                                                               frame-inspector
    227                                                               index)))
    228                                                        (inspector::prin1-value
    229                                                         frame-inspector
    230                                                         s
    231                                                         value)))))))
    232           (t (break) (%make-nsstring "Huh?")))))
     328  (cond ((%null-ptr-p item)
     329         (make-instance 'frame-label
     330           :with-frame-number index
     331           :controller self))
     332        ((our-frame-label-p self item)
     333         (make-instance 'item-label
     334           :with-frame-label item
     335           :index index))
     336        (t (break) (%make-nsstring "Huh?"))))
    233337
    234338(objc:defmethod #/outlineView:objectValueForTableColumn:byItem:
    … …  
    241345(defmethod initialize-instance :after ((self backtrace-window-controller)
    242346                                       &key &allow-other-keys)
    243   (setf (slot-value self 'inspector)
    244         (make-instance 'inspector::stack-inspector :context (backtrace-controller-context self) :update-line-count t)))
     347  (setf (slot-value self 'stack-descriptor)
     348        (make-stack-descriptor (backtrace-controller-context self))))
    245349
    246350(defun backtrace-controller-for-context (context)
    247   (or (ccl::bt.dialog context)
    248       (setf (ccl::bt.dialog context)
    249             (make-instance 'backtrace-window-controller
    250                            :with-window-nib-name #@"backtrace"
    251                            :context context))))
     351  (let ((bt (ccl::bt.dialog context)))
     352    (when bt
     353      (stack-descriptor-refresh (backtrace-controller-stack-descriptor bt)))
     354    (or bt
     355        (setf (ccl::bt.dialog context)
     356              (make-instance 'backtrace-window-controller
     357                :with-window-nib-name #@"backtrace"
     358                :context context)))))
    252359
    253360#+debug
    … …  
    255362  (#_NSLog #@"will load %@" :address  (#/windowNibName self)))
    256363
     364;; Called when current process is about to enter a breakloop
    257365(defmethod ui-object-enter-backtrace-context ((app ns:ns-application)
    258366                                              context)

  • trunk/source/cocoa-ide/cocoa-listener.lisp

    r12629 r12652  
    545545                   (vsp-range (inspector::make-vsp-stack-range tcr context))
    546546                   (csp-range (inspector::make-csp-stack-range tcr context))
    547                    (process (context-process context)))
     547                   (process (ccl::tcr->process tcr)))
    548548              (make-instance 'sequence-window-controller
    549549                             :sequence (cdr (ccl::bt.restarts context))
Note: See TracChangeset for help on using the changeset viewer.