source: trunk/source/cocoa-ide/cocoa-backtrace.lisp @ 12733

Last change on this file since 12733 was 12733, checked in by gz, 11 years ago

Bring back ns-lisp-string

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.5 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2007 Clozure Associates
4
5(in-package "GUI")
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 (if lfun
95               (with-output-to-string (stream)
96                 (format stream "(~S" (or (ccl:function-name lfun) lfun))
97                 (if (eq args (ccl::%unbound-marker))
98                   (format stream " #<Unknown Arguments>")
99                   (loop for arg in args
100                     do (if (eq arg (ccl::%unbound-marker))
101                          (format stream " #<Unavailable>")
102                          (format stream " ~:['~;~]~s" (ccl::self-evaluating-p arg) arg))))
103                 (format stream ")"))
104               ":kernel")
105      :values (if lfun
106                (map 'vector
107                     (lambda (var.val)
108                       (destructuring-bind (var . val) var.val
109                         (let ((label (format nil "~:[~s~;~a~]: ~s"
110                                              (stringp var) var val)))
111                           (cons label var.val))))
112                     (cons `("Function" . ,lfun)
113                           (and (not (eq vars (ccl::%unbound-marker))) vars)))
114                ))))
115
116(defmethod stack-descriptor-frame ((sd stack-descriptor) index)
117  (let ((cache (stack-descriptor-frame-cache sd)))
118    (or (gethash index cache)
119        ;; get a bunch at once.
120        (let* ((segment-size (stack-descriptor-segment-size sd))
121               (start (- index (rem index segment-size)))
122               (end (+ start segment-size))
123               (frames (collect-stack-frames sd #'make-frame-descriptor start end)))
124          (loop for n upfrom start as frame in frames do (setf (gethash n cache) frame))
125          (gethash index cache)))))
126
127(defun frame-descriptor-function (frame)
128  (destructuring-bind (fp . context) (frame-descriptor-data frame)
129    (ccl:frame-function fp context)))
130
131;; Don't bother making first-class frame value descriptors = frame + index
132
133(defun frame-descriptor-value-count (frame)
134  (length (frame-descriptor-values frame)))
135
136(defun frame-descriptor-value-label (frame index)
137  (car (svref (frame-descriptor-values frame) index)))
138
139(defun frame-descriptor-value (frame index)
140  (destructuring-bind (var . val)
141                      (cdr (svref (frame-descriptor-values frame) index))
142    (values val var)))
143
144(defun backtrace-frame-default-action (frame &optional index)
145  (if index
146    (inspect (frame-descriptor-value frame index))
147    (multiple-value-bind (lfun pc) (frame-descriptor-function frame)
148      (when lfun
149        (let ((source (or (and pc (ccl:find-source-note-at-pc lfun pc))
150                          (ccl:function-source-note lfun))))
151          (if (source-note-p source)
152            (hemlock-ext:execute-in-file-view
153             (ccl:source-note-filename source)
154             (lambda  ()
155               (hemlock::move-to-source-note source)))
156            (hemlock::edit-definition lfun)))))))
157
158;; Cocoa layer
159
160;; General utils, should be moved elsewhere
161(defclass abstract-ns-lisp-string (ns:ns-string)
162    ()
163  (:metaclass ns:+ns-object))
164
165(defgeneric ns-lisp-string-string (abstract-ns-lisp-string))
166
167(objc:defmethod (#/length :<NSUI>nteger) ((self abstract-ns-lisp-string))
168    (length (ns-lisp-string-string self)))
169
170(objc:defmethod (#/characterAtIndex: :unichar) ((self abstract-ns-lisp-string) (index :<NSUI>nteger))
171  (char-code (char (ns-lisp-string-string self) index)))
172
173(defclass ns-lisp-string (abstract-ns-lisp-string)
174  ((lisp-string :initarg :string :reader ns-lisp-string-string))
175  (:metaclass ns:+ns-object))
176
177(defclass frame-label (abstract-ns-lisp-string)
178    ((frame-number  :foreign-type :int :accessor frame-label-number)
179     (controller :foreign-type :id :reader frame-label-controller))
180  (:metaclass ns:+ns-object))
181
182(defmethod frame-label-descriptor ((self frame-label))
183  (stack-descriptor-frame
184    (backtrace-controller-stack-descriptor (frame-label-controller self))
185    (frame-label-number self)))
186 
187(defmethod ns-lisp-string-string ((self frame-label))
188  (frame-descriptor-label (frame-label-descriptor self)))
189
190(objc:defmethod #/initWithFrameNumber:controller: ((self frame-label) (frame-number :int) controller)
191  (let* ((obj (#/init self)))
192    (unless (%null-ptr-p obj)
193      (setf (slot-value obj 'frame-number) frame-number
194            (slot-value obj 'controller) controller))
195    obj))
196
197
198(defclass item-label (abstract-ns-lisp-string)
199    ((frame-label :foreign-type :id :accessor item-label-label)
200     (index :foreign-type :int :accessor item-label-index))
201  (:metaclass ns:+ns-object))
202
203(defmethod ns-lisp-string-string ((self item-label))
204  (frame-descriptor-value-label (frame-label-descriptor (item-label-label self))
205                                (item-label-index self)))
206
207(objc:defmethod #/initWithFrameLabel:index: ((self item-label) the-frame-label (index :int))
208  (let* ((obj (#/init self)))
209    (unless (%null-ptr-p obj)
210      (setf (slot-value obj 'frame-label) the-frame-label
211            (slot-value obj 'index) index))
212    obj))
213
214(defclass backtrace-window-controller (ns:ns-window-controller)
215    ((context :initarg :context :reader backtrace-controller-context)
216     (stack-descriptor :initform nil :reader backtrace-controller-stack-descriptor)
217     (outline-view :foreign-type :id :reader backtrace-controller-outline-view))
218  (:metaclass ns:+ns-object))
219
220(defmethod backtrace-controller-process ((self backtrace-window-controller))
221  (let ((context (backtrace-controller-context self)))
222    (and context (ccl::tcr->process (ccl::bt.tcr context)))))
223
224(defmethod backtrace-controller-break-level ((self backtrace-window-controller))
225  (let ((context (backtrace-controller-context self)))
226    (and context (ccl::bt.break-level context))))
227
228(objc:defmethod #/windowNibName ((self backtrace-window-controller))
229  #@"backtrace")
230
231(objc:defmethod (#/close :void) ((self backtrace-window-controller))
232  (setf (slot-value self 'context) nil)
233  (call-next-method))
234
235(defmethod our-frame-label-p ((self backtrace-window-controller) thing)
236  (and (typep thing 'frame-label)
237       (eql self (frame-label-controller thing))))
238
239(def-cocoa-default *backtrace-font-name* :string #+darwin-target "Monaco"
240                   #-darwin-target "Terminal" "Name of font used in backtrace views")
241(def-cocoa-default *backtrace-font-size* :float 9.0f0 "Size of font used in backtrace views")
242
243
244(objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller))
245  (let* ((outline (slot-value self 'outline-view))
246         (font (default-font :name *backtrace-font-name* :size *backtrace-font-size*)))
247    (unless (%null-ptr-p outline)
248      (#/setTarget: outline self)
249      (#/setRowHeight: outline  (size-of-char-in-font font))
250      (#/setDoubleAction: outline (@selector #/backtraceDoubleClick:))
251      (#/setShouldCascadeWindows: self nil)
252      (let* ((columns (#/tableColumns outline)))
253        (dotimes (i (#/count columns))
254          (let* ((column (#/objectAtIndex:  columns i))
255                 (data-cell (#/dataCell column)))
256            (#/setEditable: data-cell nil)
257            (#/setFont: data-cell font)
258            (when (eql i 0)
259              (let* ((header-cell (#/headerCell column))
260                     (sd (backtrace-controller-stack-descriptor self))
261                     (break-condition (stack-descriptor-condition sd))
262                     (break-condition-string
263                      (let* ((*print-level* 5)
264                             (*print-length* 5)
265                             (*print-circle* t))
266                        (format nil "~a: ~a"
267                                (class-name (class-of break-condition))
268                                break-condition))))
269                (#/setFont: header-cell (default-font :name "Courier" :size 10 :attributes '(:bold)))
270                (#/setStringValue: header-cell (%make-nsstring break-condition-string))))))))
271    (let* ((window (#/window  self)))
272      (unless (%null-ptr-p window)
273        (let* ((process (backtrace-controller-process self))
274               (listener-window (if (typep process 'cocoa-listener-process)
275                                  (cocoa-listener-process-window process))))
276          (when listener-window
277            (let* ((listener-frame (#/frame listener-window))
278                   (backtrace-width (ns:ns-rect-width (#/frame window)))
279                   (new-x (- (+ (ns:ns-rect-x listener-frame)
280                                (/ (ns:ns-rect-width listener-frame) 2))
281                             (/ backtrace-width 2))))
282              (ns:with-ns-point (p new-x (+ (ns:ns-rect-y listener-frame) (ns:ns-rect-height listener-frame)))
283                (#/setFrameOrigin: window p))))
284          (#/setTitle:  window (%make-nsstring
285                                (format nil "Backtrace for ~a(~d), break level ~d"
286                                        (process-name process)
287                                        (process-serial-number process)
288                                        (backtrace-controller-break-level self)))))))))
289
290(objc:defmethod (#/continue: :void) ((self backtrace-window-controller) sender)
291  (declare (ignore sender))
292  (let ((process (backtrace-controller-process self)))
293    (when process (process-interrupt process #'continue))))
294
295(objc:defmethod (#/exitBreak: :void) ((self backtrace-window-controller) sender)
296  (declare (ignore sender))
297  (let ((process (backtrace-controller-process self)))
298    (when process (process-interrupt process #'abort-break))))
299
300(objc:defmethod (#/restarts: :void) ((self backtrace-window-controller) sender)
301  (let* ((context (backtrace-controller-context self)))
302    (when context
303      (#/showWindow: (restarts-controller-for-context context) sender))))
304
305(objc:defmethod (#/backtraceDoubleClick: :void)
306    ((self backtrace-window-controller) sender)
307  (let* ((row (#/clickedRow sender)))
308    (if (>= row 0)
309      (let* ((item (#/itemAtRow: sender row)))
310        (cond ((typep item 'frame-label)
311               (let ((frame (frame-label-descriptor item)))
312                 (backtrace-frame-default-action frame)))
313              ((typep item 'item-label)
314               (let* ((frame (frame-label-descriptor (item-label-label item)))
315                      (index (item-label-index item)))
316                 (backtrace-frame-default-action frame index))))))))
317
318(objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>)
319    ((self backtrace-window-controller) view item)
320  (declare (ignore view))
321  (or (%null-ptr-p item)
322      (and (our-frame-label-p self item)
323           (> (frame-descriptor-value-count (frame-label-descriptor item)) 0))))
324
325(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :<NSI>nteger)
326    ((self backtrace-window-controller) view item)
327    (declare (ignore view))
328    (let* ((sd (backtrace-controller-stack-descriptor self)))
329      (cond ((%null-ptr-p item)
330             (stack-descriptor-frame-count sd))
331            ((our-frame-label-p self item)
332             (let ((frame (stack-descriptor-frame sd (frame-label-number item))))
333               (frame-descriptor-value-count frame)))
334            (t -1))))
335
336(objc:defmethod #/outlineView:child:ofItem:
337    ((self backtrace-window-controller) view (index :<NSI>nteger) item)
338  (declare (ignore view))
339  (cond ((%null-ptr-p item)
340         (make-instance 'frame-label
341           :with-frame-number index
342           :controller self))
343        ((our-frame-label-p self item)
344         (make-instance 'item-label
345           :with-frame-label item
346           :index index))
347        (t (break) (%make-nsstring "Huh?"))))
348
349(objc:defmethod #/outlineView:objectValueForTableColumn:byItem:
350    ((self backtrace-window-controller) view column item)
351  (declare (ignore view column))
352  (if (%null-ptr-p item)
353    #@"Open this"
354    (%setf-macptr (%null-ptr) item)))
355
356(defmethod initialize-instance :after ((self backtrace-window-controller)
357                                       &key &allow-other-keys)
358  (setf (slot-value self 'stack-descriptor)
359        (make-stack-descriptor (backtrace-controller-context self))))
360
361(defun backtrace-controller-for-context (context)
362  (let ((bt (ccl::bt.dialog context)))
363    (when bt
364      (stack-descriptor-refresh (backtrace-controller-stack-descriptor bt)))
365    (or bt
366        (setf (ccl::bt.dialog context)
367              (make-instance 'backtrace-window-controller
368                :with-window-nib-name #@"backtrace"
369                :context context)))))
370
371#+debug
372(objc:defmethod (#/willLoad :void) ((self backtrace-window-controller))
373  (#_NSLog #@"will load %@" :address  (#/windowNibName self)))
374
375;; Called when current process is about to enter a breakloop
376(defmethod ui-object-enter-backtrace-context ((app ns:ns-application)
377                                              context)
378  (let* ((proc *current-process*))
379    (when (typep proc 'cocoa-listener-process)
380      (push context (cocoa-listener-process-backtrace-contexts proc)))))
381
382(defmethod ui-object-exit-backtrace-context ((app ns:ns-application)
383                                              context)
384  (let* ((proc *current-process*))
385    (when (typep proc 'cocoa-listener-process)
386      (when (eq context (car (cocoa-listener-process-backtrace-contexts proc)))
387        (setf (cocoa-listener-process-backtrace-contexts proc)
388              (cdr (cocoa-listener-process-backtrace-contexts proc)))
389        (let* ((btwindow (prog1 (ccl::bt.dialog context)
390                           (setf (ccl::bt.dialog context) nil)))
391               (restartswindow
392                (prog1 (car (ccl::bt.restarts context))
393                           (setf (ccl::bt.restarts context) nil))))
394          (when btwindow
395            (#/performSelectorOnMainThread:withObject:waitUntilDone: btwindow (@selector #/close)  +null-ptr+ t))
396          (when restartswindow
397            (#/performSelectorOnMainThread:withObject:waitUntilDone: restartswindow (@selector #/close)  +null-ptr+ t)))))))
398
399 
400
401
402
403
404
Note: See TracBrowser for help on using the repository browser.