Changeset 12652
- Timestamp:
- Aug 23, 2009, 5:07:19 PM (11 years ago)
- Location:
- trunk/source/cocoa-ide
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/cocoa-ide/cocoa-backtrace.lisp
r12526 r12652 5 5 (in-package "GUI") 6 6 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 7 155 (defclass ns-lisp-string (ns:ns-string) 8 ( (lisp-string :initarg :string :reader ns-lisp-string-string))156 () 9 157 (:metaclass ns:+ns-object)) 158 159 (defgeneric ns-lisp-string-string (ns-lisp-string)) 10 160 11 161 (objc:defmethod (#/length :<NSUI>nteger) ((self ns-lisp-string)) … … 13 163 14 164 (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))) 21 166 22 167 (defclass frame-label (ns-lisp-string) 23 168 ((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)) 26 170 (: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))) 27 179 28 180 (objc:defmethod #/initWithFrameNumber:controller: ((self frame-label) (frame-number :int) controller) … … 39 191 (:metaclass ns:+ns-object)) 40 192 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 41 197 (objc:defmethod #/initWithFrameLabel:index: ((self item-label) the-frame-label (index :int)) 42 198 (let* ((obj (#/init self))) … … 48 204 (defclass backtrace-window-controller (ns:ns-window-controller) 49 205 ((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) 51 207 (outline-view :foreign-type :id :reader backtrace-controller-outline-view)) 52 208 (: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)))) 53 217 54 218 (objc:defmethod #/windowNibName ((self backtrace-window-controller)) … … 67 231 (def-cocoa-default *backtrace-font-size* :float 9.0f0 "Size of font used in backtrace views") 68 232 69 70 (defun context-process (context)71 (and context (ccl::tcr->process (ccl::bt.tcr context))))72 233 73 234 (objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller)) … … 87 248 (when (eql i 0) 88 249 (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)) 93 252 (break-condition-string 94 253 (let* ((*print-level* 5) … … 102 261 (let* ((window (#/window self))) 103 262 (unless (%null-ptr-p window) 104 (let* ((context (backtrace-controller-context self)) 105 (process (context-process context)) 263 (let* ((process (backtrace-controller-process self)) 106 264 (listener-window (if (typep process 'cocoa-listener-process) 107 265 (cocoa-listener-process-window process)))) … … 118 276 (process-name process) 119 277 (process-serial-number process) 120 ( ccl::bt.break-level context)))))))))278 (backtrace-controller-break-level self))))))))) 121 279 122 280 (objc:defmethod (#/continue: :void) ((self backtrace-window-controller) sender) 123 281 (declare (ignore sender)) 124 (let* ((context (backtrace-controller-context self)) 125 (process (context-process context))) 282 (let ((process (backtrace-controller-process self))) 126 283 (when process (process-interrupt process #'continue)))) 127 284 128 285 (objc:defmethod (#/exitBreak: :void) ((self backtrace-window-controller) sender) 129 286 (declare (ignore sender)) 130 (let* ((context (backtrace-controller-context self)) 131 (process (context-process context))) 287 (let ((process (backtrace-controller-process self))) 132 288 (when process (process-interrupt process #'abort-break)))) 133 289 … … 137 293 (#/showWindow: (restarts-controller-for-context context) sender)))) 138 294 139 140 141 295 (objc:defmethod (#/backtraceDoubleClick: :void) 142 296 ((self backtrace-window-controller) sender) 143 297 (let* ((row (#/clickedRow sender))) 144 298 (if (>= row 0) 145 (let* ((item (#/itemAtRow: sender row)) 146 (val-p nil) 147 (value nil)) 299 (let* ((item (#/itemAtRow: sender row))) 148 300 (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))) 153 303 ((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)))))))) 166 307 167 308 (objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>) … … 174 315 ((self backtrace-window-controller) view item) 175 316 (declare (ignore view)) 176 (let* (( inspector (backtrace-controller-inspector self)))317 (let* ((sd (backtrace-controller-stack-descriptor self))) 177 318 (cond ((%null-ptr-p item) 178 ( inspector::inspector-line-count inspector))319 (stack-descriptor-frame-count sd)) 179 320 ((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))) 189 323 (t -1)))) 190 324 … … 192 326 ((self backtrace-window-controller) view (index :<NSI>nteger) item) 193 327 (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?")))) 233 337 234 338 (objc:defmethod #/outlineView:objectValueForTableColumn:byItem: … … 241 345 (defmethod initialize-instance :after ((self backtrace-window-controller) 242 346 &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)))) 245 349 246 350 (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))))) 252 359 253 360 #+debug … … 255 362 (#_NSLog #@"will load %@" :address (#/windowNibName self))) 256 363 364 ;; Called when current process is about to enter a breakloop 257 365 (defmethod ui-object-enter-backtrace-context ((app ns:ns-application) 258 366 context) -
trunk/source/cocoa-ide/cocoa-listener.lisp
r12629 r12652 545 545 (vsp-range (inspector::make-vsp-stack-range tcr context)) 546 546 (csp-range (inspector::make-csp-stack-range tcr context)) 547 (process (c ontext-process context)))547 (process (ccl::tcr->process tcr))) 548 548 (make-instance 'sequence-window-controller 549 549 :sequence (cdr (ccl::bt.restarts context))
Note: See TracChangeset
for help on using the changeset viewer.