[Openmcl-cvs-notifications] r12652 - in /trunk/source/cocoa-ide: cocoa-backtrace.lisp cocoa-listener.lisp
gz at clozure.com
gz at clozure.com
Sun Aug 23 13:07:19 EDT 2009
Author: gz
Date: Sun Aug 23 13:07:19 2009
New Revision: 12652
Log:
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 t=
he frame function to frame children, so can still inspect the function by c=
licking 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 label=
s show the arguments as well as the function name.
Modified:
trunk/source/cocoa-ide/cocoa-backtrace.lisp
trunk/source/cocoa-ide/cocoa-listener.lisp
Modified: trunk/source/cocoa-ide/cocoa-backtrace.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-backtrace.lisp (original)
+++ trunk/source/cocoa-ide/cocoa-backtrace.lisp Sun Aug 23 13:07:19 2009
@@ -4,26 +4,178 @@
=
(in-package "GUI")
=
+(defclass stack-descriptor ()
+ ((context :initarg :context :reader stack-descriptor-context)
+ (filter :initform nil :initarg :filter :reader stack-descriptor-filter)
+ (interruptable-p :initform t :accessor stack-descriptor-interruptable-p)
+ (segment-size :initform 50 :reader stack-descriptor-segment-size)
+ (frame-count :initform -1 :reader stack-descriptor-frame-count)
+ (frame-cache :initform (make-hash-table) :reader stack-descriptor-frame=
-cache)))
+
+(defun make-stack-descriptor (context &rest keys)
+ (apply #'make-instance 'stack-descriptor
+ ;; For some reason backtrace context is an anonymous vector
+ :context (require-type context 'simple-vector)
+ keys))
+
+(defmethod initialize-instance :after ((sd stack-descriptor) &key &allow-o=
ther-keys)
+ (with-slots (frame-count) sd
+ (setf frame-count (count-stack-descriptor-frames sd))))
+
+(defmethod stack-descriptor-refresh ((sd stack-descriptor))
+ (clrhash (stack-descriptor-frame-cache sd)))
+
+(defmethod stack-descriptor-origin ((sd stack-descriptor))
+ (ccl::bt.youngest (stack-descriptor-context sd)))
+
+(defmethod stack-descriptor-process ((sd stack-descriptor))
+ (ccl::tcr->process (ccl::bt.tcr (stack-descriptor-context sd))))
+
+(defmethod stack-descriptor-condition ((sd stack-descriptor))
+ (ccl::bt.break-condition (stack-descriptor-context sd)))
+
+(defmethod map-stack-frames (sd function &optional start end)
+ (ccl:map-call-frames function
+ :origin (stack-descriptor-origin sd)
+ :process (stack-descriptor-process sd)
+ :test (stack-descriptor-filter sd)
+ :start-frame-number (or start 0)
+ :count (- (or end most-positive-fixnum)
+ (or start 0))))
+
+(defmethod count-stack-descriptor-frames ((sd stack-descriptor))
+ (let ((count 0))
+ (map-stack-frames sd (lambda (fp context)
+ (declare (ignore fp context))
+ (incf count)))
+ count))
+
+;; Function must be side-effect free, it may be restarted or aborted.
+(defun collect-stack-frames (sd function &optional start end)
+ (let ((process (stack-descriptor-process sd)))
+ ;; In general, it's best to run backtrace printing in the error proces=
s, since
+ ;; printing often depends on the dynamic state (e.g. bound vars) at th=
e point of
+ ;; error. However, if the erring process is wedged in some way, getti=
ng at it
+ ;; from outside may be better than nothing.
+ (if (or (not (stack-descriptor-interruptable-p sd))
+ (eq process *current-process*))
+ (let* ((results nil)
+ (*print-level* *backtrace-print-level*)
+ (*print-length* *backtrace-print-length*)
+ (*print-circle* (null *print-level*)))
+ (map-stack-frames sd (lambda (fp context)
+ (push (funcall function fp context) results=
))
+ start end)
+ (nreverse results))
+ (let ((s (make-semaphore))
+ (res :none))
+ (process-interrupt process
+ (lambda ()
+ (ignore-errors (setq res (collect-stack-frame=
s sd function start end)))
+ (signal-semaphore s)))
+ (timed-wait-on-semaphore s 2) ;; give it 2 seconds before going to=
plan B...
+ (if (eq res :none)
+ (progn
+ (setf (stack-descriptor-interruptable-p sd) nil)
+ (collect-stack-frames sd function start end))
+ res)))))
+
+(defclass frame-descriptor ()
+ ((data :initarg :data :reader frame-descriptor-data)
+ (label :initarg :label :reader frame-descriptor-label)
+ (values :initarg :values :reader frame-descriptor-values)))
+
+(defun make-frame-descriptor (fp context)
+ (let* ((args (ccl:frame-supplied-arguments fp context))
+ (vars (ccl:frame-named-variables fp context))
+ (lfun (ccl:frame-function fp context)))
+ (make-instance 'frame-descriptor
+ :data (cons fp context)
+ :label (with-output-to-string (stream)
+ (format stream "(~S" (or (ccl:function-name lfun) lfun))
+ (if (eq args (ccl::%unbound-marker))
+ (format stream " #<Unknown Arguments>")
+ (loop for arg in args
+ do (if (eq arg (ccl::%unbound-marker))
+ (format stream " #<Unavailable>")
+ (format stream " ~:['~;~]~s" (ccl::self-evaluating=
-p arg) arg))))
+ (format stream ")"))
+ :values (map 'vector
+ (lambda (var.val)
+ (destructuring-bind (var . val) var.val
+ (let ((label (format nil "~:[~s~;~a~]: ~s"
+ (stringp var) var val)))
+ (cons label var.val))))
+ (cons `("Function" . ,lfun) vars)))))
+
+(defmethod stack-descriptor-frame ((sd stack-descriptor) index)
+ (let ((cache (stack-descriptor-frame-cache sd)))
+ (or (gethash index cache)
+ ;; get a bunch at once.
+ (let* ((segment-size (stack-descriptor-segment-size sd))
+ (start (- index (rem index segment-size)))
+ (end (+ start segment-size))
+ (frames (collect-stack-frames sd #'make-frame-descriptor st=
art end)))
+ (loop for n upfrom start as frame in frames do (setf (gethash n =
cache) frame))
+ (gethash index cache)))))
+
+(defun frame-descriptor-function (frame)
+ (destructuring-bind (fp . context) (frame-descriptor-data frame)
+ (ccl:frame-function fp context)))
+
+;; Don't bother making first-class frame value descriptors =3D frame + ind=
ex
+
+(defun frame-descriptor-value-count (frame)
+ (length (frame-descriptor-values frame)))
+
+(defun frame-descriptor-value-label (frame index)
+ (car (svref (frame-descriptor-values frame) index)))
+
+(defun frame-descriptor-value (frame index)
+ (destructuring-bind (var . val)
+ (cdr (svref (frame-descriptor-values frame) index))
+ (values val var)))
+
+(defun backtrace-frame-default-action (frame &optional index)
+ (if index
+ (inspect (frame-descriptor-value frame index))
+ (multiple-value-bind (lfun pc) (frame-descriptor-function frame)
+ (when lfun
+ (let ((source (or (and pc (ccl:find-source-note-at-pc lfun pc))
+ (ccl:function-source-note lfun))))
+ (if (source-note-p source)
+ (hemlock-ext:execute-in-file-view
+ (ccl:source-note-filename source)
+ (lambda ()
+ (hemlock::move-to-source-note source)))
+ (hemlock::edit-definition lfun)))))))
+
+;; Cocoa layer
+
(defclass ns-lisp-string (ns:ns-string)
- ((lisp-string :initarg :string :reader ns-lisp-string-string))
+ ()
(:metaclass ns:+ns-object))
+
+(defgeneric ns-lisp-string-string (ns-lisp-string))
=
(objc:defmethod (#/length :<NSUI>nteger) ((self ns-lisp-string))
(length (ns-lisp-string-string self)))
=
(objc:defmethod (#/characterAtIndex: :unichar) ((self ns-lisp-string) (ind=
ex :<NSUI>nteger))
- (char-code (schar (ns-lisp-string-string self) index)))
-
-(objc:defmethod (#/dealloc :void) ((self ns-lisp-string))
- (ccl::%remove-lisp-slot-vector self)
- (call-next-method))
-
+ (char-code (char (ns-lisp-string-string self) index)))
=
(defclass frame-label (ns-lisp-string)
((frame-number :foreign-type :int :accessor frame-label-number)
- (controller :foreign-type :id :reader frame-label-controller)
- (frame-inspector :initform nil :accessor frame-label-frame-inspector))
+ (controller :foreign-type :id :reader frame-label-controller))
(:metaclass ns:+ns-object))
+
+(defmethod frame-label-descriptor ((self frame-label))
+ (stack-descriptor-frame
+ (backtrace-controller-stack-descriptor (frame-label-controller self))
+ (frame-label-number self)))
+ =
+(defmethod ns-lisp-string-string ((self frame-label))
+ (frame-descriptor-label (frame-label-descriptor self)))
=
(objc:defmethod #/initWithFrameNumber:controller: ((self frame-label) (fra=
me-number :int) controller)
(let* ((obj (#/init self)))
@@ -38,6 +190,10 @@
(index :foreign-type :int :accessor item-label-index))
(:metaclass ns:+ns-object))
=
+(defmethod ns-lisp-string-string ((self item-label))
+ (frame-descriptor-value-label (frame-label-descriptor (item-label-label =
self))
+ (item-label-index self)))
+
(objc:defmethod #/initWithFrameLabel:index: ((self item-label) the-frame-l=
abel (index :int))
(let* ((obj (#/init self)))
(unless (%null-ptr-p obj)
@@ -47,9 +203,17 @@
=
(defclass backtrace-window-controller (ns:ns-window-controller)
((context :initarg :context :reader backtrace-controller-context)
- (inspector :initform nil :reader backtrace-controller-inspector)
+ (stack-descriptor :initform nil :reader backtrace-controller-stack-de=
scriptor)
(outline-view :foreign-type :id :reader backtrace-controller-outline-=
view))
(:metaclass ns:+ns-object))
+
+(defmethod backtrace-controller-process ((self backtrace-window-controller=
))
+ (let ((context (backtrace-controller-context self)))
+ (and context (ccl::tcr->process (ccl::bt.tcr context)))))
+
+(defmethod backtrace-controller-break-level ((self backtrace-window-contro=
ller))
+ (let ((context (backtrace-controller-context self)))
+ (and context (ccl::bt.break-level context))))
=
(objc:defmethod #/windowNibName ((self backtrace-window-controller))
#@"backtrace")
@@ -66,9 +230,6 @@
#-darwin-target "Terminal" "Name of font used in backtr=
ace views")
(def-cocoa-default *backtrace-font-size* :float 9.0f0 "Size of font used i=
n backtrace views")
=
-
-(defun context-process (context)
- (and context (ccl::tcr->process (ccl::bt.tcr context))))
=
(objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller=
))
(let* ((outline (slot-value self 'outline-view))
@@ -86,10 +247,8 @@
(#/setFont: data-cell font)
(when (eql i 0)
(let* ((header-cell (#/headerCell column))
- (inspector (backtrace-controller-inspector self))
- (break-condition
- (inspector::break-condition
- (inspector::inspector-object inspector)))
+ (sd (backtrace-controller-stack-descriptor self))
+ (break-condition (stack-descriptor-condition sd))
(break-condition-string
(let* ((*print-level* 5)
(*print-length* 5)
@@ -101,8 +260,7 @@
(#/setStringValue: header-cell (%make-nsstring break-condi=
tion-string))))))))
(let* ((window (#/window self)))
(unless (%null-ptr-p window)
- (let* ((context (backtrace-controller-context self))
- (process (context-process context))
+ (let* ((process (backtrace-controller-process self))
(listener-window (if (typep process 'cocoa-listener-process)
(cocoa-listener-process-window process))=
))
(when listener-window
@@ -117,18 +275,16 @@
(format nil "Backtrace for ~a(~d), break l=
evel ~d"
(process-name process)
(process-serial-number process)
- (ccl::bt.break-level context))))))=
)))
+ (backtrace-controller-break-level =
self)))))))))
=
(objc:defmethod (#/continue: :void) ((self backtrace-window-controller) se=
nder)
(declare (ignore sender))
- (let* ((context (backtrace-controller-context self))
- (process (context-process context)))
+ (let ((process (backtrace-controller-process self)))
(when process (process-interrupt process #'continue))))
=
(objc:defmethod (#/exitBreak: :void) ((self backtrace-window-controller) s=
ender)
(declare (ignore sender))
- (let* ((context (backtrace-controller-context self))
- (process (context-process context)))
+ (let ((process (backtrace-controller-process self)))
(when process (process-interrupt process #'abort-break))))
=
(objc:defmethod (#/restarts: :void) ((self backtrace-window-controller) se=
nder)
@@ -136,33 +292,18 @@
(when context
(#/showWindow: (restarts-controller-for-context context) sender))))
=
-
-
(objc:defmethod (#/backtraceDoubleClick: :void)
((self backtrace-window-controller) sender)
(let* ((row (#/clickedRow sender)))
(if (>=3D row 0)
- (let* ((item (#/itemAtRow: sender row))
- (val-p nil)
- (value nil))
+ (let* ((item (#/itemAtRow: sender row)))
(cond ((typep item 'frame-label)
- (let* ((controller (frame-label-controller item))
- (inspector (backtrace-controller-inspector controlle=
r))
- (frame-number (frame-label-number item)))
- (setq val-p t value (inspector::line-n inspector frame-nu=
mber))))
+ (let ((frame (frame-label-descriptor item)))
+ (backtrace-frame-default-action frame)))
((typep item 'item-label)
- (let* ((the-frame-label (item-label-label item))
- (frame-inspector (frame-label-frame-inspector the-fr=
ame-label))
- (index (item-label-index item))
- (rawval (inspector::line-n frame-inspector index)))
- (if (and (consp rawval)
- (typep (car rawval) 'keyword))
- (setq val-p t value (cddr rawval))))))
- (if val-p
- (inspect value))))))
-
-
-
+ (let* ((frame (frame-label-descriptor (item-label-label ite=
m)))
+ (index (item-label-index item)))
+ (backtrace-frame-default-action frame index))))))))
=
(objc:defmethod (#/outlineView:isItemExpandable: :<BOOL>)
((self backtrace-window-controller) view item)
@@ -173,63 +314,26 @@
(objc:defmethod (#/outlineView:numberOfChildrenOfItem: :<NSI>nteger)
((self backtrace-window-controller) view item)
(declare (ignore view))
- (let* ((inspector (backtrace-controller-inspector self)))
+ (let* ((sd (backtrace-controller-stack-descriptor self)))
(cond ((%null-ptr-p item)
- (inspector::inspector-line-count inspector))
+ (stack-descriptor-frame-count sd))
((our-frame-label-p self item)
- (let* ((frame-inspector
- (or (frame-label-frame-inspector item)
- (setf (frame-label-frame-inspector item)
- (make-instance
- 'inspector::stack-frame-inspector
- :frame-number (frame-label-number item)
- :object (inspector::inspector-object inspe=
ctor)
- :update-line-count t)))))
- (inspector::inspector-line-count frame-inspector)))
+ (let ((frame (stack-descriptor-frame sd (frame-label-number i=
tem))))
+ (frame-descriptor-value-count frame)))
(t -1))))
=
(objc:defmethod #/outlineView:child:ofItem:
((self backtrace-window-controller) view (index :<NSI>nteger) item)
(declare (ignore view))
- (let* ((inspector (backtrace-controller-inspector self)))
- (cond ((%null-ptr-p item)
- (let* ((label
- (make-instance 'frame-label
- :with-frame-number index
- :controller self
- :string
- (let* ((value =
- (inspector::line-n inspector ind=
ex)))
- (if value
- (ccl::%lfun-name-string value)
- ":kernel")))))
- label))
- ((our-frame-label-p self item)
- (let* ((frame-inspector
- (or (frame-label-frame-inspector item)
- (setf (frame-label-frame-inspector item)
- (make-instance
- 'inspector::stack-frame-inspector
- :frame-number (frame-label-number item)
- :object (inspector::inspector-object inspect=
or)
- :update-line-count t)))))
- (make-instance 'item-label
- :with-frame-label item
- :index index
- :string
- (let* ((ccl::*aux-vsp-ranges* (inspector::vsp-=
range inspector))
- (ccl::*aux-tsp-ranges* (inspector::tsp-=
range inspector))
- (ccl::*aux-csp-ranges* (inspector::csp-=
range inspector)))
- (with-output-to-string (s)
- (let* ((value
- (inspector::l=
ine-n
- frame-inspec=
tor
- index)))
- (inspector::prin1-v=
alue
- frame-inspector
- s
- value)))))))
- (t (break) (%make-nsstring "Huh?")))))
+ (cond ((%null-ptr-p item)
+ (make-instance 'frame-label
+ :with-frame-number index
+ :controller self))
+ ((our-frame-label-p self item)
+ (make-instance 'item-label
+ :with-frame-label item
+ :index index))
+ (t (break) (%make-nsstring "Huh?"))))
=
(objc:defmethod #/outlineView:objectValueForTableColumn:byItem:
((self backtrace-window-controller) view column item)
@@ -240,20 +344,24 @@
=
(defmethod initialize-instance :after ((self backtrace-window-controller)
&key &allow-other-keys)
- (setf (slot-value self 'inspector)
- (make-instance 'inspector::stack-inspector :context (backtrace-con=
troller-context self) :update-line-count t)))
+ (setf (slot-value self 'stack-descriptor)
+ (make-stack-descriptor (backtrace-controller-context self))))
=
(defun backtrace-controller-for-context (context)
- (or (ccl::bt.dialog context)
- (setf (ccl::bt.dialog context)
- (make-instance 'backtrace-window-controller
- :with-window-nib-name #@"backtrace"
- :context context))))
+ (let ((bt (ccl::bt.dialog context)))
+ (when bt
+ (stack-descriptor-refresh (backtrace-controller-stack-descriptor bt)=
))
+ (or bt
+ (setf (ccl::bt.dialog context)
+ (make-instance 'backtrace-window-controller
+ :with-window-nib-name #@"backtrace"
+ :context context)))))
=
#+debug
(objc:defmethod (#/willLoad :void) ((self backtrace-window-controller))
(#_NSLog #@"will load %@" :address (#/windowNibName self)))
=
+;; Called when current process is about to enter a breakloop
(defmethod ui-object-enter-backtrace-context ((app ns:ns-application)
context)
(let* ((proc *current-process*))
Modified: trunk/source/cocoa-ide/cocoa-listener.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-listener.lisp (original)
+++ trunk/source/cocoa-ide/cocoa-listener.lisp Sun Aug 23 13:07:19 2009
@@ -544,7 +544,7 @@
(tsp-range (inspector::make-tsp-stack-range tcr context=
))
(vsp-range (inspector::make-vsp-stack-range tcr context=
))
(csp-range (inspector::make-csp-stack-range tcr context=
))
- (process (context-process context)))
+ (process (ccl::tcr->process tcr)))
(make-instance 'sequence-window-controller
:sequence (cdr (ccl::bt.restarts context))
:result-callback #'(lambda (r)
More information about the Openmcl-cvs-notifications
mailing list