/[slime]/slime/swank-cmucl.lisp
ViewVC logotype

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.36 - (hide annotations)
Wed Dec 10 13:20:47 2003 UTC (10 years, 4 months ago) by heller
Branch: MAIN
CVS Tags: SLIME-0-9
Changes since 1.35: +40 -6 lines
(create-swank-server): Use announce callback.
(sldb-disassemble): New function.
1 lgorrie 1.24 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2 dbarlow 1.1
3     (declaim (optimize debug))
4    
5     (in-package :swank)
6    
7 lgorrie 1.25 ;; Turn on xref. [should we?]
8     (setf c:*record-xref-info* t)
9    
10 heller 1.22 (defun without-interrupts* (body)
11     (sys:without-interrupts (funcall body)))
12    
13 dbarlow 1.1 (defun set-fd-non-blocking (fd)
14     (flet ((fcntl (fd cmd arg)
15     (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
16     (or flags
17     (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
18     (let ((flags (fcntl fd unix:F-GETFL 0)))
19     (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
20    
21 lgorrie 1.25
22     ;;;; TCP server.
23    
24 heller 1.28 (defun resolve-hostname (name)
25     (let* ((hostent (ext:lookup-host-entry name))
26     (address (car (ext:host-entry-addr-list hostent))))
27     (ext:htonl address)))
28    
29 heller 1.32 (defun create-swank-server (port &key (reuse-address t)
30 heller 1.36 (address "localhost")
31     (announce #'simple-announce-function))
32 lgorrie 1.25 "Create a SWANK TCP server."
33 heller 1.28 (let* ((ip (resolve-hostname address))
34     (fd (ext:create-inet-listener port :stream
35     :reuse-address reuse-address
36     :host ip)))
37 heller 1.36 (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd)))
38     (accept-connection fd)))
39 lgorrie 1.25
40     (defun accept-connection (socket)
41     "Accept one Swank TCP connection on SOCKET and then close it."
42     (setup-request-handler (ext:accept-tcp-connection socket))
43     (sys:invalidate-descriptor socket)
44     (unix:unix-close socket))
45    
46 heller 1.28 (defun open-stream-to-emacs ()
47     "Return an output-stream to Emacs' output buffer."
48     (let* ((ip (resolve-hostname "localhost"))
49     (listener (ext:create-inet-listener 0 :stream :host ip))
50     (port (nth-value 1 (ext::get-socket-host-and-port listener))))
51     (unwind-protect
52     (progn
53     (eval-in-emacs `(slime-open-stream-to-lisp ,port))
54     (let ((fd (ext:accept-tcp-connection listener)))
55     (sys:make-fd-stream fd :output t)))
56     (ext:close-socket listener))))
57    
58     (defvar *use-dedicated-output-stream* t)
59    
60 lgorrie 1.25 (defun setup-request-handler (socket)
61     "Setup request handling for SOCKET."
62     (let* ((stream (sys:make-fd-stream socket
63     :input t :output t
64     :element-type 'base-char))
65     (input (make-slime-input-stream))
66 heller 1.28 (output (if *use-dedicated-output-stream*
67     (let ((*emacs-io* stream)) (open-stream-to-emacs))
68     (make-slime-output-stream)))
69 lgorrie 1.25 (io (make-two-way-stream input output)))
70     (system:add-fd-handler socket
71     :input (lambda (fd)
72     (declare (ignore fd))
73     (serve-request stream output input io)))))
74    
75     (defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
76     "Read and process a request from a SWANK client.
77     The request is read from the socket as a sexp and then evaluated."
78     (catch 'slime-toplevel
79     (with-simple-restart (abort "Return to Slime toplevel.")
80     (handler-case (read-from-emacs)
81     (slime-read-error (e)
82     (when *swank-debug-p*
83     (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
84     (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
85     (close *emacs-io*)))))
86     (sys:scrub-control-stack))
87 dbarlow 1.1
88 lgorrie 1.25
89     ;;;; Stream handling
90 dbarlow 1.1
91     (defstruct (slime-output-stream
92 heller 1.16 (:include lisp::lisp-stream
93     (lisp::misc #'sos/misc)
94     (lisp::out #'sos/out)
95     (lisp::sout #'sos/sout))
96 heller 1.17 (:conc-name sos.)
97     (:print-function %print-slime-output-stream))
98 heller 1.16 (buffer (make-string 512) :type string)
99     (index 0 :type kernel:index)
100     (column 0 :type kernel:index))
101    
102 heller 1.17 (defun %print-slime-output-stream (s stream d)
103     (declare (ignore d))
104     (print-unreadable-object (s stream :type t :identity t)))
105    
106 heller 1.16 (defun sos/out (stream char)
107     (let ((buffer (sos.buffer stream))
108     (index (sos.index stream)))
109     (setf (schar buffer index) char)
110     (setf (sos.index stream) (1+ index))
111     (incf (sos.column stream))
112 heller 1.21 (when (char= #\newline char)
113     (setf (sos.column stream) 0))
114     (when (= index (1- (length buffer)))
115     (force-output stream)))
116 heller 1.16 char)
117    
118     (defun sos/sout (stream string start end)
119     (loop for i from start below end
120     do (sos/out stream (aref string i))))
121    
122     (defun sos/misc (stream operation &optional arg1 arg2)
123     (declare (ignore arg1 arg2))
124 dbarlow 1.1 (case operation
125 heller 1.17 ((:force-output :finish-output)
126 heller 1.16 (let ((end (sos.index stream)))
127     (unless (zerop end)
128     (send-to-emacs `(:read-output ,(subseq (sos.buffer stream) 0 end)))
129     (setf (sos.index stream) 0))))
130     (:charpos (sos.column stream))
131     (:line-length 75)
132 dbarlow 1.1 (:file-position nil)
133 heller 1.16 (:element-type 'base-char)
134     (:get-command nil)
135 heller 1.22 (:close nil)
136 heller 1.16 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
137 dbarlow 1.1
138 heller 1.9 (defstruct (slime-input-stream
139 heller 1.16 (:include string-stream
140     (lisp::in #'sis/in)
141     (lisp::misc #'sis/misc))
142 heller 1.17 (:conc-name sis.)
143     (:print-function %print-slime-output-stream))
144 heller 1.16 (buffer "" :type string)
145     (index 0 :type kernel:index))
146    
147     (defun sis/in (stream eof-errorp eof-value)
148 heller 1.18 (declare (ignore eof-errorp eof-value))
149 heller 1.16 (let ((index (sis.index stream))
150     (buffer (sis.buffer stream)))
151     (when (= index (length buffer))
152     (setf buffer (slime-read-string))
153     (setf (sis.buffer stream) buffer)
154     (setf index 0))
155     (prog1 (aref buffer index)
156     (setf (sis.index stream) (1+ index)))))
157 heller 1.9
158 heller 1.16 (defun sis/misc (stream operation &optional arg1 arg2)
159 heller 1.14 (declare (ignore arg2))
160 heller 1.15 (ecase operation
161     (:file-position nil)
162 heller 1.16 (:file-length nil)
163     (:unread (setf (aref (sis.buffer stream)
164     (decf (sis.index stream)))
165     arg1))
166     (:clear-input (setf (sis.index stream) 0
167     (sis.buffer stream) ""))
168     (:listen (< (sis.index stream) (length (sis.buffer stream))))
169     (:charpos nil)
170     (:line-length nil)
171     (:get-command nil)
172 heller 1.22 (:element-type 'base-char)
173     (:close nil)))
174 heller 1.16
175 lgorrie 1.25
176 dbarlow 1.1 ;;;; Compilation Commands
177    
178 heller 1.19 (defvar *swank-source-info* nil
179     "Bound to a SOURCE-INFO object during compilation.")
180 dbarlow 1.1
181 lgorrie 1.24 (defvar *previous-compiler-condition* nil
182     "Used to detect duplicates.")
183    
184     (defvar *previous-context* nil
185     "Previous compiler error context.")
186    
187     (defvar *compiler-notes* '()
188     "List of compiler notes for the last compilation unit.")
189    
190 heller 1.30 (defvar *buffer-name* nil)
191     (defvar *buffer-start-position* nil)
192     (defvar *buffer-substring* nil)
193     (defvar *compile-filename* nil)
194    
195 lgorrie 1.25
196 lgorrie 1.24 ;;;;; Trapping notes
197    
198     (defun handle-notification-condition (condition)
199 dbarlow 1.1 "Handle a condition caused by a compiler warning.
200     This traps all compiler conditions at a lower-level than using
201     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
202     craft our own error messages, which can omit a lot of redundant
203     information."
204     (unless (eq condition *previous-compiler-condition*)
205     (let ((context (or (c::find-error-context nil) *previous-context*)))
206     (setq *previous-compiler-condition* condition)
207     (setq *previous-context* context)
208 lgorrie 1.24 (signal-compiler-condition condition context))))
209    
210     (defun signal-compiler-condition (condition context)
211     (signal (make-condition
212     'compiler-condition
213     :original-condition condition
214     :severity (severity-for-emacs condition)
215     :message (brief-compiler-message-for-emacs condition context)
216     :location (compiler-note-location context))))
217    
218     (defun severity-for-emacs (condition)
219     "Return the severity of CONDITION."
220     (etypecase condition
221     (c::compiler-error :error)
222     (c::style-warning :note)
223     (c::warning :warning)))
224    
225     (defun brief-compiler-message-for-emacs (condition error-context)
226     "Briefly describe a compiler error for Emacs.
227     When Emacs presents the message it already has the source popped up
228     and the source form highlighted. This makes much of the information in
229     the error-context redundant."
230     (declare (type (or c::compiler-error-context null) error-context))
231 heller 1.30 (multiple-value-bind (enclosing source)
232     (if error-context
233     (values (c::compiler-error-context-enclosing-source error-context)
234     (c::compiler-error-context-source error-context)))
235     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
236     enclosing source condition)))
237    
238 heller 1.31
239 heller 1.30 (defun compiler-note-location (context)
240     (cond (context
241     (resolve-note-location
242     *buffer-name*
243     (c::compiler-error-context-file-name context)
244     (c::compiler-error-context-file-position context)
245     (reverse (c::compiler-error-context-original-source-path context))
246     (c::compiler-error-context-original-source context)))
247     (t
248     (resolve-note-location *buffer-name* nil nil nil nil))))
249    
250     (defgeneric resolve-note-location (buffer file-name file-position
251     source-path source))
252    
253     (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
254     (make-location
255     `(:file ,(unix-truename f))
256     `(:position ,(1+ (source-path-file-position path f)))))
257    
258     (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
259     (make-location
260     `(:buffer ,b)
261     `(:position ,(+ *buffer-start-position*
262     (source-path-string-position path *buffer-substring*)))))
263    
264 heller 1.32 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
265     (make-location
266     `(:source-form ,source)
267     `(:position 1)))
268    
269 heller 1.30 (defmethod resolve-note-location (buffer
270     (file (eql nil))
271     (pos (eql nil))
272     (path (eql nil))
273     (source (eql nil)))
274     (cond (buffer
275     (make-location (list :buffer buffer)
276     (list :position *buffer-start-position*)))
277     (*compile-file-truename*
278     (make-location (list :file (namestring *compile-file-truename*))
279     (list :position 0)))
280     (*compile-filename*
281     (make-location (list :file *compile-filename*) (list :position 0)))
282     (t
283     (list :error "No error location available"))))
284 dbarlow 1.1
285 lgorrie 1.24 (defmacro with-compilation-hooks (() &body body)
286 lgorrie 1.25 "Execute BODY and record the set of compiler notes."
287 lgorrie 1.24 `(let ((*previous-compiler-condition* nil)
288 heller 1.30 (*previous-context* nil)
289     (*print-readably* nil))
290 lgorrie 1.24 (handler-bind ((c::compiler-error #'handle-notification-condition)
291     (c::style-warning #'handle-notification-condition)
292     (c::warning #'handle-notification-condition))
293     ,@body)))
294    
295     (defmethod compile-file-for-emacs (filename load-p)
296     (clear-xref-info filename)
297     (with-compilation-hooks ()
298 heller 1.30 (let ((*buffer-name* nil)
299     (*compile-filename* filename))
300     (compile-file filename :load load-p))))
301 lgorrie 1.24
302     (defmethod compile-string-for-emacs (string &key buffer position)
303     (with-compilation-hooks ()
304     (let ((*package* *buffer-package*)
305 heller 1.30 (*compile-filename* nil)
306     (*buffer-name* buffer)
307     (*buffer-start-position* position)
308     (*buffer-substring* string))
309 lgorrie 1.24 (with-input-from-string (stream string)
310     (ext:compile-from-stream
311     stream
312     :source-info `(:emacs-buffer ,buffer
313     :emacs-buffer-offset ,position
314     :emacs-buffer-string ,string))))))
315 dbarlow 1.1
316 lgorrie 1.25
317     ;;;; XREF
318 dbarlow 1.1
319 heller 1.30 (defun lookup-xrefs (finder name)
320     (xref-results-for-emacs (funcall finder (from-string name))))
321    
322 dbarlow 1.1 (defslimefun who-calls (function-name)
323     "Return the places where FUNCTION-NAME is called."
324 heller 1.30 (lookup-xrefs #'xref:who-calls function-name))
325 dbarlow 1.1
326     (defslimefun who-references (variable)
327     "Return the places where the global variable VARIABLE is referenced."
328 heller 1.30 (lookup-xrefs #'xref:who-references variable))
329 dbarlow 1.1
330     (defslimefun who-binds (variable)
331     "Return the places where the global variable VARIABLE is bound."
332 heller 1.30 (lookup-xrefs #'xref:who-binds variable))
333 dbarlow 1.1
334     (defslimefun who-sets (variable)
335     "Return the places where the global variable VARIABLE is set."
336 heller 1.30 (lookup-xrefs #'xref:who-sets variable))
337 dbarlow 1.1
338 lgorrie 1.10 #+cmu19
339 heller 1.32 (progn
340     (defslimefun who-macroexpands (macro)
341     "Return the places where MACRO is expanded."
342     (lookup-xrefs #'xref:who-macroexpands macro))
343    
344     (defslimefun who-specializes (class)
345     "Return the methods with specializers for CLASS."
346     (let* ((methods (xref::who-specializes (find-class (from-string class))))
347     (locations (mapcar #'method-source-location methods)))
348     (group-xrefs (mapcar (lambda (m l)
349     (cons (let ((*print-pretty* nil))
350     (to-string m))
351     l))
352     methods locations))))
353     )
354 heller 1.30
355     (defun resolve-xref-location (xref)
356     (let ((name (xref:xref-context-name xref))
357     (file (xref:xref-context-file xref))
358     (source-path (xref:xref-context-source-path xref)))
359     (cond ((and file source-path)
360     (let ((position (source-path-file-position source-path file)))
361     (make-location (list :file (unix-truename file))
362     (list :position (1+ position)))))
363     (file
364     (make-location (list :file (unix-truename file))
365     (list :function-name (string name))))
366     (t
367     `(:error ,(format nil "Unkown source location: ~S ~S ~S "
368     name file source-path))))))
369    
370 dbarlow 1.1
371     (defun xref-results-for-emacs (contexts)
372     "Prepare a list of xref contexts for Emacs.
373 heller 1.29 The result is a list of xrefs:
374     group ::= (FILENAME . ({reference}+))
375     reference ::= (FUNCTION-SPECIFIER . SOURCE-LOCATION)"
376     (let ((xrefs '()))
377     (dolist (cxt contexts)
378 heller 1.30 (let ((name (xref:xref-context-name cxt)))
379 heller 1.29 (push (cons (to-string name)
380 heller 1.30 (resolve-xref-location cxt))
381 heller 1.29 xrefs)))
382     (group-xrefs xrefs)))
383    
384    
385     (defun location-buffer= (location1 location2)
386     (equalp location1 location2))
387    
388 dbarlow 1.1 (defun file-xrefs-for-emacs (unix-filename contexts)
389     "Return a summary of the references from a particular file.
390     The result is a list of the form (FILENAME ((REFERRER SOURCE-PATH) ...))"
391     (list unix-filename
392     (loop for context in (sort-contexts-by-source-path contexts)
393     collect (list (let ((*print-pretty* nil))
394     (to-string (xref:xref-context-name context)))
395     (xref:xref-context-source-path context)))))
396    
397     (defun sort-contexts-by-source-path (contexts)
398     "Sort xref contexts by lexical position of source-paths.
399     It is assumed that all contexts belong to the same file."
400     (sort contexts #'source-path< :key #'xref:xref-context-source-path))
401    
402     (defun source-path< (path1 path2)
403     "Return true if PATH1 is lexically before PATH2."
404     (and (every #'< path1 path2)
405     (< (length path1) (length path2))))
406    
407 lgorrie 1.25 (defun clear-xref-info (namestring)
408     "Clear XREF notes pertaining to FILENAME.
409     This is a workaround for a CMUCL bug: XREF records are cumulative."
410     (let ((filename (parse-namestring namestring)))
411     (when c:*record-xref-info*
412     (dolist (db (list xref::*who-calls*
413     #+cmu19 xref::*who-is-called*
414     #+cmu19 xref::*who-macroexpands*
415     xref::*who-references*
416     xref::*who-binds*
417     xref::*who-sets*))
418     (maphash (lambda (target contexts)
419     (setf (gethash target db)
420     (delete-if
421     (lambda (ctx)
422     (xref-context-derived-from-p ctx filename))
423     contexts)))
424     db)))))
425    
426     (defun xref-context-derived-from-p (context filename)
427     (let ((xref-file (xref:xref-context-file context)))
428     (and xref-file (pathname= filename xref-file))))
429    
430     (defun pathname= (&rest pathnames)
431     "True if PATHNAMES refer to the same file."
432     (apply #'string= (mapcar #'unix-truename pathnames)))
433    
434     (defun unix-truename (pathname)
435     (ext:unix-namestring (truename pathname)))
436    
437    
438     ;;;; Find callers and callees
439    
440 dbarlow 1.1 ;;; Find callers and callees by looking at the constant pool of
441     ;;; compiled code objects. We assume every fdefn object in the
442     ;;; constant pool corresponds to a call to that function. A better
443     ;;; strategy would be to use the disassembler to find actual
444     ;;; call-sites.
445    
446     (declaim (inline map-code-constants))
447     (defun map-code-constants (code fn)
448     "Call FN for each constant in CODE's constant pool."
449     (check-type code kernel:code-component)
450     (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
451     do (funcall fn (kernel:code-header-ref code i))))
452    
453     (defun function-callees (function)
454 heller 1.30 "Return FUNCTION's callees as a list of functions."
455 dbarlow 1.1 (let ((callees '()))
456     (map-code-constants
457     (vm::find-code-object function)
458     (lambda (obj)
459     (when (kernel:fdefn-p obj)
460 heller 1.30 (push (kernel:fdefn-function obj) callees))))
461 dbarlow 1.1 callees))
462    
463 heller 1.19 (declaim (ext:maybe-inline map-allocated-code-components))
464 dbarlow 1.1 (defun map-allocated-code-components (spaces fn)
465     "Call FN for each allocated code component in one of SPACES. FN
466 heller 1.19 receives the object as argument. SPACES should be a list of the
467     symbols :dynamic, :static, or :read-only."
468 dbarlow 1.1 (dolist (space spaces)
469 heller 1.18 (declare (inline vm::map-allocated-objects))
470 dbarlow 1.1 (vm::map-allocated-objects
471     (lambda (obj header size)
472 heller 1.19 (declare (type fixnum size) (ignore size))
473 dbarlow 1.1 (when (= vm:code-header-type header)
474 heller 1.19 (funcall fn obj)))
475 dbarlow 1.1 space)))
476    
477 heller 1.19 (declaim (ext:maybe-inline map-caller-code-components))
478 dbarlow 1.1 (defun map-caller-code-components (function spaces fn)
479     "Call FN for each code component with a fdefn for FUNCTION in its
480     constant pool."
481     (let ((function (coerce function 'function)))
482 heller 1.19 (declare (inline map-allocated-code-components))
483 dbarlow 1.1 (map-allocated-code-components
484     spaces
485 heller 1.19 (lambda (obj)
486 dbarlow 1.1 (map-code-constants
487     obj
488     (lambda (constant)
489     (when (and (kernel:fdefn-p constant)
490     (eq (kernel:fdefn-function constant)
491     function))
492     (funcall fn obj))))))))
493    
494     (defun function-callers (function &optional (spaces '(:read-only :static
495     :dynamic)))
496 heller 1.30 "Return FUNCTION's callers. The result is a list of code-objects."
497 dbarlow 1.1 (let ((referrers '()))
498 heller 1.19 (declare (inline map-caller-code-components))
499 heller 1.30 (ext:gc :full t)
500     (map-caller-code-components function spaces
501     (lambda (code) (push code referrers)))
502 dbarlow 1.1 referrers))
503 heller 1.30
504     (defun debug-info-definitions (debug-info)
505     "Return the defintions for a debug-info. This should only be used
506     for code-object without entry points, i.e., byte compiled
507     code (are theree others?)"
508     ;; This mess has only been tested with #'ext::skip-whitespace, a
509     ;; byte-compiled caller of #'read-char .
510     (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
511     (let ((name (c::debug-info-name debug-info))
512     (source (c::debug-info-source debug-info)))
513     (destructuring-bind (first) source
514     (ecase (c::debug-source-from first)
515     (:file
516     (list
517     (cons name
518     (make-location
519     (list :file (unix-truename (c::debug-source-name first)))
520     (list :function-name name)))))))))
521    
522     (defun code-component-entry-points (code)
523     "Return a list ((NAME . LOCATION) ...) of function definitons for
524     the code omponent CODE."
525     (delete-duplicates
526     (loop for e = (kernel:%code-entry-points code)
527     then (kernel::%function-next e)
528     while e
529     collect (cons (to-string (kernel:%function-name e))
530     (function-source-location e)))
531     :test #'equal))
532 dbarlow 1.1
533     (defslimefun list-callers (symbol-name)
534 heller 1.30 "Return a list ((FILE . ((NAME . LOCATION) ...)) ...) of callers."
535     (let ((components (function-callers (from-string symbol-name)))
536     (xrefs '()))
537     (dolist (code components)
538     (let* ((entry (kernel:%code-entry-points code))
539     (defs (if entry
540     (code-component-entry-points code)
541     ;; byte compiled stuff
542     (debug-info-definitions
543     (kernel:%code-debug-info code)))))
544     (setq xrefs (nconc defs xrefs))))
545     (group-xrefs xrefs)))
546 dbarlow 1.1
547 heller 1.18
548 dbarlow 1.1 (defslimefun list-callees (symbol-name)
549 heller 1.30 (let ((fns (function-callees (from-string symbol-name))))
550     (group-xrefs (mapcar (lambda (fn)
551     (cons (to-string (kernel:%function-name fn))
552     (function-source-location fn)))
553     fns))))
554 dbarlow 1.1
555     ;;;; Definitions
556    
557 lgorrie 1.35 (defvar *debug-definition-finding* nil
558 dbarlow 1.1 "When true don't handle errors while looking for definitions.
559     This is useful when debugging the definition-finding code.")
560    
561 heller 1.29 (defmacro safe-definition-finding (&body body)
562     "Execute BODY ignoring errors. Return a the source location
563     returned by BODY or if an error occurs a description of the error.
564     The second return value is the condition or nil."
565     `(flet ((body () ,@body))
566     (if *debug-definition-finding*
567     (body)
568     (handler-case (values (progn ,@body) nil)
569     (error (c) (values (list :error (princ-to-string c)) c))))))
570    
571 dbarlow 1.1 (defun function-first-code-location (function)
572     (and (function-has-debug-function-p function)
573     (di:debug-function-start-location
574     (di:function-debug-function function))))
575    
576     (defun function-has-debug-function-p (function)
577     (di:function-debug-function function))
578    
579     (defun function-code-object= (closure function)
580     (and (eq (vm::find-code-object closure)
581     (vm::find-code-object function))
582     (not (eq closure function))))
583    
584 heller 1.4 (defun struct-closure-p (function)
585     (or (function-code-object= function #'kernel::structure-slot-accessor)
586     (function-code-object= function #'kernel::structure-slot-setter)
587     (function-code-object= function #'kernel::%defstruct)))
588 dbarlow 1.1
589 heller 1.4 (defun struct-closure-dd (function)
590 dbarlow 1.1 (assert (= (kernel:get-type function) vm:closure-header-type))
591 heller 1.4 (flet ((find-layout (function)
592     (sys:find-if-in-closure
593     (lambda (x)
594 heller 1.18 (let ((value (if (di::indirect-value-cell-p x)
595     (c:value-cell-ref x)
596     x)))
597     (when (kernel::layout-p value)
598     (return-from find-layout value))))
599 heller 1.4 function)))
600     (kernel:layout-info (find-layout function))))
601    
602 dbarlow 1.1 (defun dd-source-location (dd)
603     (let ((constructor (or (kernel:dd-default-constructor dd)
604 heller 1.32 (car (kernel::dd-constructors dd)))))
605     (when (or (not constructor) (and (consp constructor)
606     (not (car constructor))))
607     (error "Cannot locate struct without constructor: ~S"
608     (kernel::dd-name dd)))
609     (function-source-location
610     (coerce (if (consp constructor) (car constructor) constructor)
611     'function))))
612 dbarlow 1.1
613 heller 1.27 (defun genericp (fn)
614     (typep fn 'generic-function))
615    
616     (defun gf-definition-location (gf)
617     (flet ((guess-source-file (faslfile)
618     (unix-truename
619     (merge-pathnames (make-pathname :type "lisp")
620     faslfile))))
621     (let ((def-source (pcl::definition-source gf))
622     (name (string (pcl:generic-function-name gf))))
623     (etypecase def-source
624 heller 1.30 (pathname (make-location
625     `(:file ,(guess-source-file def-source))
626     `(:function-name ,name)))
627 heller 1.27 (cons
628     (destructuring-bind ((dg name) pathname) def-source
629     (declare (ignore dg))
630 heller 1.30 (etypecase pathname
631     (pathname
632     (make-location `(:file ,(guess-source-file pathname))
633     `(:function-name ,(string name)))))))))))
634 heller 1.27
635     (defun method-source-location (method)
636     (function-source-location (or (pcl::method-fast-function method)
637     (pcl:method-function method))))
638    
639     (defun gf-method-locations (gf)
640     (let ((ms (pcl::generic-function-methods gf)))
641     (mapcar #'method-source-location ms)))
642    
643     (defun gf-source-locations (gf)
644     (list* (gf-definition-location gf)
645     (gf-method-locations gf)))
646    
647 heller 1.29 (defun function-source-locations (function)
648     "Return a list of source locations for FUNCTION."
649 dbarlow 1.1 ;; First test if FUNCTION is a closure created by defstruct; if so
650     ;; extract the defstruct-description (dd) from the closure and find
651     ;; the constructor for the struct. Defstruct creates a defun for
652     ;; the default constructor and we use that as an approximation to
653     ;; the source location of the defstruct.
654     ;;
655     ;; For an ordinary function we return the source location of the
656     ;; first code-location we find.
657 heller 1.4 (cond ((struct-closure-p function)
658 heller 1.29 (list
659     (safe-definition-finding
660     (dd-source-location (struct-closure-dd function)))))
661 heller 1.27 ((genericp function)
662 heller 1.29 (gf-source-locations function))
663 heller 1.27 (t
664 heller 1.29 (list
665     (multiple-value-bind (code-location error)
666     (safe-definition-finding (function-first-code-location function))
667     (cond (error (list :error (princ-to-string error)))
668     (t (code-location-source-location code-location))))))))
669    
670     (defun function-source-location (function)
671     (destructuring-bind (first) (function-source-locations function)
672     first))
673 dbarlow 1.1
674 heller 1.34 (defmethod find-function-locations (symbol-name)
675 heller 1.29 "Return a list of source-locations for SYMBOL-NAME's functions."
676     (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
677     (cond ((not foundp)
678     (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
679     ((macro-function symbol)
680     (function-source-locations (macro-function symbol)))
681     ((special-operator-p symbol)
682 heller 1.31 (list (list :error (format nil "~A is a special-operator" symbol))))
683 heller 1.29 ((fboundp symbol)
684     (function-source-locations (coerce symbol 'function)))
685     (t (list (list :error
686     (format nil "Symbol not fbound: ~A" symbol-name))))
687     )))
688    
689 lgorrie 1.25
690     ;;;; Documentation.
691 dbarlow 1.1
692 lgorrie 1.24 (defmethod describe-symbol-for-emacs (symbol)
693 dbarlow 1.1 (let ((result '()))
694 lgorrie 1.24 (flet ((doc (kind)
695     (or (documentation symbol kind) :not-documented))
696     (maybe-push (property value)
697     (when value
698     (setf result (list* property value result)))))
699 dbarlow 1.1 (maybe-push
700     :variable (multiple-value-bind (kind recorded-p)
701     (ext:info variable kind symbol)
702     (declare (ignore kind))
703     (if (or (boundp symbol) recorded-p)
704     (doc 'variable))))
705     (maybe-push
706 heller 1.27 :generic-function
707     (if (and (fboundp symbol)
708     (typep (fdefinition symbol) 'generic-function))
709     (doc 'function)))
710     (maybe-push
711     :function (if (and (fboundp symbol)
712     (not (typep (fdefinition symbol) 'generic-function)))
713     (doc 'function)))
714 dbarlow 1.1 (maybe-push
715     :setf (if (or (ext:info setf inverse symbol)
716     (ext:info setf expander symbol))
717     (doc 'setf)))
718     (maybe-push
719     :type (if (ext:info type kind symbol)
720     (doc 'type)))
721     (maybe-push
722     :class (if (find-class symbol nil)
723     (doc 'class)))
724 heller 1.18 (maybe-push
725     :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
726     (doc 'alien-type)))
727     (maybe-push
728     :alien-struct (if (ext:info alien-type struct symbol)
729     (doc nil)))
730     (maybe-push
731     :alien-union (if (ext:info alien-type union symbol)
732     (doc nil)))
733     (maybe-push
734     :alien-enum (if (ext:info alien-type enum symbol)
735     (doc nil)))
736 lgorrie 1.24 result)))
737 dbarlow 1.1
738     (defslimefun describe-setf-function (symbol-name)
739 dbarlow 1.3 (print-description-to-string
740 dbarlow 1.1 (or (ext:info setf inverse (from-string symbol-name))
741     (ext:info setf expander (from-string symbol-name)))))
742    
743     (defslimefun describe-type (symbol-name)
744 dbarlow 1.3 (print-description-to-string
745 dbarlow 1.1 (kernel:values-specifier-type (from-string symbol-name))))
746    
747     (defslimefun describe-class (symbol-name)
748 dbarlow 1.3 (print-description-to-string (find-class (from-string symbol-name) nil)))
749 dbarlow 1.1
750 heller 1.18 (defslimefun describe-alien-type (symbol-name)
751     (let ((name (from-string symbol-name)))
752     (ecase (ext:info :alien-type :kind name)
753     (:primitive
754     (print-description-to-string
755     (let ((alien::*values-type-okay* t))
756     (funcall (ext:info :alien-type :translator name) (list name)))))
757     ((:defined)
758     (print-description-to-string (ext:info :alien-type :definition name)))
759     (:unknown
760     (format nil "Unkown alien type: ~A" symbol-name)))))
761    
762     (defmacro %describe-alien (symbol-name namespace)
763     `(print-description-to-string
764     (ext:info :alien-type ,namespace (from-string ,symbol-name))))
765    
766     (defslimefun describe-alien-struct (symbol-name)
767     (%describe-alien symbol-name :struct))
768    
769     (defslimefun describe-alien-union (symbol-name)
770     (%describe-alien symbol-name :union))
771    
772     (defslimefun describe-alien-enum (symbol-name)
773     (%describe-alien symbol-name :enum))
774    
775 lgorrie 1.25 (defmethod arglist-string (fname)
776     "Return a string describing the argument list for FNAME.
777     The result has the format \"(...)\"."
778     (declare (type string fname))
779     (multiple-value-bind (function condition)
780     (ignore-errors (values (find-symbol-designator fname *buffer-package*)))
781     (when condition
782     (return-from arglist-string (format nil "(-- ~A)" condition)))
783     (let ((arglist
784     (if (not (or (fboundp function)
785     (functionp function)))
786     "(-- <Unknown-Function>)"
787     (let* ((fun (or (macro-function function)
788     (symbol-function function)))
789     (df (di::function-debug-function fun))
790     (arglist (kernel:%function-arglist fun)))
791     (cond ((eval:interpreted-function-p fun)
792     (eval:interpreted-function-arglist fun))
793     ((pcl::generic-function-p fun)
794     (pcl::gf-pretty-arglist fun))
795     (arglist arglist)
796     ;; this should work both for
797     ;; compiled-debug-function and for
798     ;; interpreted-debug-function
799     (df (di::debug-function-lambda-list df))
800     (t "(<arglist-unavailable>)"))))))
801     (if (stringp arglist)
802     arglist
803     (to-string arglist)))))
804    
805    
806     ;;;; Miscellaneous.
807 dbarlow 1.1
808 lgorrie 1.24 (defmethod macroexpand-all (form)
809     (walker:macroexpand-all form))
810 dbarlow 1.1
811     (defun tracedp (fname)
812     (gethash (debug::trace-fdefinition fname)
813     debug::*traced-functions*))
814    
815     (defslimefun toggle-trace-fdefinition (fname-string)
816     (let ((fname (from-string fname-string)))
817     (cond ((tracedp fname)
818     (debug::untrace-1 fname)
819     (format nil "~S is now untraced." fname))
820     (t
821     (debug::trace-1 fname (debug::make-trace-info))
822     (format nil "~S is now traced." fname)))))
823 lgorrie 1.25
824     (defslimefun set-default-directory (directory)
825     (setf (ext:default-directory) (namestring directory))
826     ;; Setting *default-pathname-defaults* to an absolute directory
827     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
828     (setf *default-pathname-defaults* (pathname (ext:default-directory)))
829     (namestring (ext:default-directory)))
830    
831 heller 1.19
832 lgorrie 1.25 ;;;; Source-paths
833 heller 1.19
834 lgorrie 1.25 ;;; CMUCL uses a data structure called "source-path" to locate
835     ;;; subforms. The compiler assigns a source-path to each form in a
836     ;;; compilation unit. Compiler notes usually contain the source-path
837     ;;; of the error location.
838     ;;;
839     ;;; Compiled code objects don't contain source paths, only the
840     ;;; "toplevel-form-number" and the (sub-) "form-number". To get from
841     ;;; the form-number to the source-path we need the entire toplevel-form
842     ;;; (i.e. we have to read the source code). CMUCL has already some
843     ;;; utilities to do this translation, but we use some extended
844     ;;; versions, because we need more exact position info. Apparently
845     ;;; Hemlock is happy with the position of the toplevel-form; we also
846     ;;; need the position of subforms.
847     ;;;
848     ;;; We use a special readtable to get the positions of the subforms.
849     ;;; The readtable stores the start and end position for each subform in
850     ;;; hashtable for later retrieval.
851 heller 1.19
852     (defun make-source-recorder (fn source-map)
853     "Return a macro character function that does the same as FN, but
854     additionally stores the result together with the stream positions
855     before and after of calling FN in the hashtable SOURCE-MAP."
856     (lambda (stream char)
857     (let ((start (file-position stream))
858     (values (multiple-value-list (funcall fn stream char)))
859     (end (file-position stream)))
860     #+(or) (format t "~&[~D ~{~A~^, ~} ~D]~%" start values end)
861     (unless (null values)
862     (push (cons start end) (gethash (car values) source-map)))
863     (values-list values))))
864    
865     (defun make-source-recording-readtable (readtable source-map)
866     "Return a source position recording copy of READTABLE.
867     The source locations are stored in SOURCE-MAP."
868     (let* ((tab (copy-readtable readtable))
869     (*readtable* tab))
870     (dotimes (code char-code-limit)
871     (let ((char (code-char code)))
872     (multiple-value-bind (fn term) (get-macro-character char tab)
873     (when fn
874     (set-macro-character char (make-source-recorder fn source-map)
875     term tab)))))
876     tab))
877    
878     (defun make-source-map ()
879     (make-hash-table :test #'eq))
880    
881     (defvar *source-map* (make-source-map)
882     "The hashtable table used for source position recording.")
883    
884     (defvar *recording-readtable-cache* '()
885     "An alist of (READTABLE . RECORDING-READTABLE) pairs.")
886    
887     (defun lookup-recording-readtable (readtable)
888     "Find a cached or create a new recording readtable for READTABLE."
889     (or (cdr (assoc readtable *recording-readtable-cache*))
890     (let ((table (make-source-recording-readtable readtable *source-map*)))
891     (push (cons readtable table) *recording-readtable-cache*)
892     table)))
893    
894     (defun read-and-record-source-map (stream)
895     "Read the next object from STREAM.
896     Return the object together with a hashtable that maps
897     subexpressions of the object to stream positions."
898     (let ((*readtable* (lookup-recording-readtable *readtable*)))
899     (clrhash *source-map*)
900     (values (read stream) *source-map*)))
901    
902     (defun source-path-stream-position (path stream)
903     "Search the source-path PATH in STREAM and return its position."
904     (destructuring-bind (tlf-number . path) path
905     (let ((*read-suppress* t))
906     (dotimes (i tlf-number) (read stream))
907     (multiple-value-bind (form source-map)
908     (read-and-record-source-map stream)
909     (source-path-source-position (cons 0 path) form source-map)))))
910    
911     (defun source-path-string-position (path string)
912     (with-input-from-string (s string)
913     (source-path-stream-position path s)))
914    
915     (defun source-path-file-position (path filename)
916     (with-open-file (file filename)
917     (source-path-stream-position path file)))
918    
919     (defun source-path-source-position (path form source-map)
920     "Return the start position of PATH form FORM and SOURCE-MAP. All
921     subforms along the path are considered and the start and end position
922     of deepest (i.e. smallest) possible form is returned."
923     ;; compute all subforms along path
924     (let ((forms (loop for n in path
925     for f = form then (nth n f)
926     collect f)))
927     ;; select the first subform present in source-map
928     (loop for form in (reverse forms)
929     for positions = (gethash form source-map)
930 heller 1.32 until (and positions (null (cdr positions)))
931 heller 1.19 finally (destructuring-bind ((start . end)) positions
932     (return (values (1- start) end))))))
933    
934     (defun code-location-stream-position (code-location stream)
935     "Return the byte offset of CODE-LOCATION in STREAM. Extract the
936     toplevel-form-number and form-number from CODE-LOCATION and use that
937     to find the position of the corresponding form."
938     (let* ((location (debug::maybe-block-start-location code-location))
939     (tlf-offset (di:code-location-top-level-form-offset location))
940     (form-number (di:code-location-form-number location))
941     (*read-suppress* t))
942     (dotimes (i tlf-offset) (read stream))
943     (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
944     (let* ((path-table (di:form-number-translations tlf 0))
945 heller 1.30 (source-path
946     (if (<= (length path-table) form-number) ; source out of sync?
947     (list 0) ; should probably signal a condition
948     (reverse (cdr (aref path-table form-number))))))
949 heller 1.19 (source-path-source-position source-path tlf position-map)))))
950    
951     (defun code-location-string-offset (code-location string)
952     (with-input-from-string (s string)
953     (code-location-stream-position code-location s)))
954    
955     (defun code-location-file-position (code-location filename)
956     (with-open-file (s filename :direction :input)
957     (code-location-stream-position code-location s)))
958    
959     (defun debug-source-info-from-emacs-buffer-p (debug-source)
960     (let ((info (c::debug-source-info debug-source)))
961     (and info
962     (consp info)
963     (eq :emacs-buffer (car info)))))
964    
965 heller 1.30 (defun source-location-from-code-location (code-location)
966 heller 1.29 "Return the source location for CODE-LOCATION."
967 heller 1.30 (let ((debug-fun (di:code-location-debug-function code-location)))
968     (when (di::bogus-debug-function-p debug-fun)
969     (error "Bogus debug function: ~A" debug-fun)))
970 heller 1.19 (let* ((debug-source (di:code-location-debug-source code-location))
971 heller 1.30 (from (di:debug-source-from debug-source))
972     (name (di:debug-source-name debug-source)))
973 heller 1.19 (ecase from
974 heller 1.32 (:file
975     (make-location (list :file (unix-truename name))
976     (list :position (1+ (code-location-file-position
977     code-location name)))))
978 heller 1.19 (:stream
979     (assert (debug-source-info-from-emacs-buffer-p debug-source))
980     (let ((info (c::debug-source-info debug-source)))
981 heller 1.32 (make-location
982     (list :buffer (getf info :emacs-buffer))
983     (list :position (+ (getf info :emacs-buffer-offset)
984     (code-location-string-offset
985     code-location
986     (getf info :emacs-buffer-string)))))))
987 heller 1.19 (:lisp
988 heller 1.32 (make-location
989     (list :source-form (with-output-to-string (*standard-output*)
990     (debug::print-code-location-source-form
991     code-location 100 t)))
992     (list :position 1))))))
993 heller 1.19
994 heller 1.29 (defun code-location-source-location (code-location)
995     "Safe wrapper around `code-location-from-source-location'."
996     (safe-definition-finding
997 heller 1.30 (source-location-from-code-location code-location)))
998 dbarlow 1.1
999 lgorrie 1.25 (defslimefun getpid ()
1000     (unix:unix-getpid))
1001    
1002 dbarlow 1.1
1003 lgorrie 1.25 ;;;; Debugging
1004 dbarlow 1.1
1005     (defvar *sldb-stack-top*)
1006     (defvar *sldb-restarts*)
1007    
1008 lgorrie 1.25 (defmethod call-with-debugging-environment (debugger-loop-fn)
1009 dbarlow 1.1 (unix:unix-sigsetmask 0)
1010 lgorrie 1.25 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
1011 dbarlow 1.1 (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
1012     (debug:*stack-top-hint* nil)
1013     (*debugger-hook* nil)
1014     (*readtable* (or debug:*debug-readtable* *readtable*))
1015     (*print-level* debug:*debug-print-level*)
1016 heller 1.30 (*print-length* debug:*debug-print-length*)
1017     (*print-readably* nil))
1018 dbarlow 1.1 (handler-bind ((di:debug-condition
1019     (lambda (condition)
1020 lgorrie 1.25 (signal (make-condition
1021     'sldb-condition
1022     :original-condition condition)))))
1023     (funcall debugger-loop-fn))))
1024 dbarlow 1.1
1025     (defun format-restarts-for-emacs ()
1026     "Return a list of restarts for *swank-debugger-condition* in a
1027     format suitable for Emacs."
1028     (loop for restart in *sldb-restarts*
1029     collect (list (princ-to-string (restart-name restart))
1030     (princ-to-string restart))))
1031    
1032     (defun format-condition-for-emacs ()
1033     (format nil "~A~% [Condition of type ~S]"
1034     (debug::safe-condition-message *swank-debugger-condition*)
1035     (type-of *swank-debugger-condition*)))
1036    
1037     (defun nth-frame (index)
1038     (do ((frame *sldb-stack-top* (di:frame-down frame))
1039     (i index (1- i)))
1040     ((zerop i) frame)))
1041    
1042     (defun nth-restart (index)
1043     (nth index *sldb-restarts*))
1044    
1045     (defun format-frame-for-emacs (frame)
1046 heller 1.33 (with-output-to-string (*standard-output*)
1047     (let ((*print-pretty* *sldb-pprint-frames*))
1048     (debug::print-frame-call frame :verbosity 1 :number t))))
1049 dbarlow 1.1
1050     (defun compute-backtrace (start end)
1051     "Return a list of frames starting with frame number START and
1052     continuing to frame number END or, if END is nil, the last frame on the
1053     stack."
1054     (let ((end (or end most-positive-fixnum)))
1055     (loop for f = (nth-frame start) then (di:frame-down f)
1056     for i from start below end
1057     while f
1058 heller 1.33 collect (cons i f))))
1059 dbarlow 1.1
1060 lgorrie 1.26 (defmethod backtrace (start end)
1061 heller 1.33 (loop for (n . frame) in (compute-backtrace start end)
1062     collect (list n (format-frame-for-emacs frame))))
1063 dbarlow 1.1
1064 lgorrie 1.25 (defmethod debugger-info-for-emacs (start end)
1065 dbarlow 1.1 (list (format-condition-for-emacs)
1066     (format-restarts-for-emacs)
1067 lgorrie 1.26 (backtrace start end)))
1068 dbarlow 1.1
1069 lgorrie 1.26 (defmethod frame-source-location-for-emacs (index)
1070 heller 1.29 (code-location-source-location (di:frame-code-location (nth-frame index))))
1071 dbarlow 1.1
1072 lgorrie 1.26 (defmethod eval-in-frame (form index)
1073     (di:eval-in-frame (nth-frame index) form))
1074 heller 1.19
1075     (defslimefun pprint-eval-string-in-frame (string index)
1076 heller 1.23 (swank-pprint
1077     (multiple-value-list
1078     (di:eval-in-frame (nth-frame index) (from-string string)))))
1079 dbarlow 1.1
1080 heller 1.13 (defslimefun inspect-in-frame (string index)
1081     (reset-inspector)
1082     (inspect-object (di:eval-in-frame (nth-frame index) (from-string string))))
1083    
1084 lgorrie 1.26 (defmethod frame-locals (index)
1085 dbarlow 1.1 (let* ((frame (nth-frame index))
1086     (location (di:frame-code-location frame))
1087     (debug-function (di:frame-debug-function frame))
1088     (debug-variables (di::debug-function-debug-variables debug-function)))
1089     (loop for v across debug-variables
1090     collect (list
1091     :symbol (di:debug-variable-symbol v)
1092     :id (di:debug-variable-id v)
1093     :value-string
1094     (if (eq (di:debug-variable-validity v location)
1095     :valid)
1096     (to-string (di:debug-variable-value v frame))
1097     "<not-available>")))))
1098    
1099 lgorrie 1.26 (defmethod frame-catch-tags (index)
1100 dbarlow 1.1 (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
1101 heller 1.29 collect `(,tag . ,(code-location-source-location code-location))))
1102 dbarlow 1.1
1103     (defslimefun invoke-nth-restart (index)
1104 heller 1.31 (invoke-restart-interactively (nth-restart index)))
1105 dbarlow 1.1
1106     (defslimefun sldb-abort ()
1107     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1108 heller 1.33
1109     (defun set-step-breakpoints (frame)
1110     (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1111     (di:frame-code-location frame)))
1112     (error "Cannot step, in elsewhere code~%"))
1113     (let* ((code-location (di:frame-code-location frame))
1114 heller 1.36 (debug::*bad-code-location-types*
1115     (remove :call-site debug::*bad-code-location-types*))
1116 heller 1.33 (next (debug::next-code-locations code-location)))
1117     (cond (next
1118     (let ((steppoints '()))
1119     (flet ((hook (frame breakpoint)
1120     (let ((debug:*stack-top-hint* frame))
1121 heller 1.36 (mapc #'di:delete-breakpoint steppoints)
1122     (let ((cl (di::breakpoint-what breakpoint)))
1123     (break "Breakpoint: ~S ~S"
1124     (di:code-location-kind cl)
1125     (di::compiled-code-location-pc cl))))))
1126 heller 1.33 (dolist (code-location next)
1127     (let ((bp (di:make-breakpoint #'hook code-location
1128     :kind :code-location)))
1129     (di:activate-breakpoint bp)
1130     (push bp steppoints))))))
1131     (t
1132     (flet ((hook (frame breakpoint values cookie)
1133     (declare (ignore cookie))
1134 heller 1.36 (di:delete-breakpoint breakpoint)
1135 heller 1.33 (let ((debug:*stack-top-hint* frame))
1136     (break "Function-end: ~A ~A" breakpoint values))))
1137     (let* ((debug-function (di:frame-debug-function frame))
1138     (bp (di:make-breakpoint #'hook debug-function
1139     :kind :function-end)))
1140     (di:activate-breakpoint bp)))))))
1141    
1142     (defslimefun sldb-step (frame)
1143     (cond ((find-restart 'continue *swank-debugger-condition*)
1144     (set-step-breakpoints (nth-frame frame))
1145     (continue *swank-debugger-condition*))
1146     (t
1147     (error "Cannot continue in from condition: ~A"
1148     *swank-debugger-condition*))))
1149 dbarlow 1.1
1150 heller 1.36 (defslimefun sldb-disassemble (frame-number)
1151     "Return a string with the disassembly of frames code."
1152     ;; this could need some refactoring.
1153     (let* ((frame (nth-frame frame-number))
1154     (real-frame (di::frame-real-frame frame))
1155     (frame-pointer (di::frame-pointer real-frame))
1156     (debug-fun (di:frame-debug-function real-frame)))
1157     (with-output-to-string (*standard-output*)
1158     (format t "Frame: ~S~%~:[~;Real Frame: ~S~%~]Frame Pointer: ~S~%"
1159     frame (eq frame real-frame) real-frame frame-pointer)
1160     (etypecase debug-fun
1161     (di::compiled-debug-function
1162     (let* ((code-loc (di:frame-code-location frame))
1163     (component (di::compiled-debug-function-component debug-fun))
1164     (pc (di::compiled-code-location-pc code-loc))
1165     (ip (sys:sap-int
1166     (sys:sap+ (kernel:code-instructions component) pc)))
1167     (kind (if (di:code-location-unknown-p code-loc)
1168     :unkown
1169     (di:code-location-kind code-loc)))
1170     (fun (di:debug-function-function debug-fun)))
1171     (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%"
1172     ip pc kind)
1173     (if fun
1174     (disassemble fun)
1175     (disassem:disassemble-code-component component))))
1176     (di::bogus-debug-function
1177     (format t "~%[Disassembling bogus frames not implemented]"))))))
1178 dbarlow 1.1
1179 lgorrie 1.25 ;;;; Inspecting
1180 dbarlow 1.1
1181     (defvar *inspectee*)
1182     (defvar *inspectee-parts*)
1183     (defvar *inspector-stack* '())
1184     (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
1185     (defvar *inspect-length* 30)
1186    
1187     (defun reset-inspector ()
1188     (setq *inspectee* nil)
1189     (setq *inspectee-parts* nil)
1190     (setq *inspector-stack* nil)
1191     (setf (fill-pointer *inspector-history*) 0))
1192    
1193     (defslimefun init-inspector (string)
1194     (reset-inspector)
1195     (inspect-object (eval (from-string string))))
1196    
1197     (defun print-part-to-string (value)
1198     (let ((*print-pretty* nil))
1199     (let ((string (to-string value))
1200     (pos (position value *inspector-history*)))
1201     (if pos
1202     (format nil "#~D=~A" pos string)
1203     string))))
1204    
1205     (defun inspect-object (object)
1206     (push (setq *inspectee* object) *inspector-stack*)
1207     (unless (find object *inspector-history*)
1208     (vector-push-extend object *inspector-history*))
1209     (multiple-value-bind (text parts) (inspected-parts object)
1210     (setq *inspectee-parts* parts)
1211     (list :text text
1212     :type (to-string (type-of object))
1213     :primitive-type (describe-primitive-type object)
1214     :parts (loop for (label . value) in parts
1215     collect (cons label
1216     (print-part-to-string value))))))
1217     (defconstant +lowtag-symbols+
1218     '(vm:even-fixnum-type
1219     vm:function-pointer-type
1220     vm:other-immediate-0-type
1221     vm:list-pointer-type
1222     vm:odd-fixnum-type
1223     vm:instance-pointer-type
1224     vm:other-immediate-1-type
1225     vm:other-pointer-type))
1226    
1227     (defconstant +header-type-symbols+
1228     ;; Is there a convinient place for all those constants?
1229     (flet ((tail-comp (string tail)
1230     (and (>= (length string) (length tail))
1231     (string= string tail :start1 (- (length string)
1232     (length tail))))))
1233     (remove-if-not
1234     (lambda (x) (and (tail-comp (symbol-name x) "-TYPE")
1235     (not (member x +lowtag-symbols+))
1236     (boundp x)
1237     (typep (symbol-value x) 'fixnum)))
1238     (append (apropos-list "-TYPE" "VM" t)
1239     (apropos-list "-TYPE" "BIGNUM" t)))))
1240    
1241     (defun describe-primitive-type (object)
1242     (with-output-to-string (*standard-output*)
1243     (let* ((lowtag (kernel:get-lowtag object))
1244     (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1245     (format t "[lowtag: ~A" lowtag-symbol)
1246     (cond ((member lowtag (list vm:other-pointer-type
1247     vm:function-pointer-type
1248     vm:other-immediate-0-type
1249     vm:other-immediate-1-type
1250     ))
1251     (let* ((type (kernel:get-type object))
1252     (type-symbol (find type +header-type-symbols+
1253     :key #'symbol-value)))
1254     (format t ", type: ~A]" type-symbol)))
1255     (t (format t "]"))))))
1256    
1257     (defun nth-part (index)
1258     (cdr (nth index *inspectee-parts*)))
1259    
1260     (defslimefun inspect-nth-part (index)
1261     (inspect-object (nth-part index)))
1262    
1263     (defslimefun inspector-pop ()
1264     "Drop the inspector stack and inspect the second element. Return
1265     nil if there's no second element."
1266     (cond ((cdr *inspector-stack*)
1267     (pop *inspector-stack*)
1268     (inspect-object (pop *inspector-stack*)))
1269     (t nil)))
1270    
1271     (defslimefun inspector-next ()
1272     "Inspect the next element in the *inspector-history*."
1273     (let ((position (position *inspectee* *inspector-history*)))
1274     (cond ((= (1+ position) (length *inspector-history*))
1275     nil)
1276     (t (inspect-object (aref *inspector-history* (1+ position)))))))
1277    
1278     (defslimefun quit-inspector ()
1279     (reset-inspector)
1280     nil)
1281    
1282     (defslimefun describe-inspectee ()
1283     "Describe the currently inspected object."
1284 heller 1.4 (print-description-to-string *inspectee*))
1285 dbarlow 1.1
1286     (defgeneric inspected-parts (object)
1287     (:documentation
1288     "Return a short description and a list of (label . value) pairs."))
1289    
1290     (defmethod inspected-parts (o)
1291     (cond ((di::indirect-value-cell-p o)
1292     (inspected-parts-of-value-cell o))
1293     (t
1294     (destructuring-bind (text labeledp . parts)
1295     (inspect::describe-parts o)
1296     (let ((parts (if labeledp
1297     (loop for (label . value) in parts
1298     collect (cons (string label) value))
1299     (loop for value in parts
1300     for i from 0
1301     collect (cons (format nil "~D" i) value)))))
1302     (values text parts))))))
1303    
1304     (defun inspected-parts-of-value-cell (o)
1305     (values (format nil "~A~% is a value cell." o)
1306     (list (cons "Value" (c:value-cell-ref o)))))
1307    
1308     ;; borrowed from sbcl
1309     (defmethod inspected-parts ((object cons))
1310     (if (consp (cdr object))
1311     (inspected-parts-of-nontrivial-list object)
1312     (inspected-parts-of-simple-cons object)))
1313    
1314     (defun inspected-parts-of-simple-cons (object)
1315     (values "The object is a CONS."
1316     (list (cons (string 'car) (car object))
1317     (cons (string 'cdr) (cdr object)))))
1318    
1319     (defun inspected-parts-of-nontrivial-list (object)
1320     (let ((length 0)
1321     (in-list object)
1322     (reversed-elements nil))
1323     (flet ((done (description-format)
1324     (return-from inspected-parts-of-nontrivial-list
1325     (values (format nil description-format length)
1326     (nreverse reversed-elements)))))
1327     (loop
1328     (cond ((null in-list)
1329     (done "The object is a proper list of length ~S.~%"))
1330     ((>= length *inspect-length*)
1331     (push (cons (string 'rest) in-list) reversed-elements)
1332     (done "The object is a long list (more than ~S elements).~%"))
1333     ((consp in-list)
1334     (push (cons (format nil "~D" length) (pop in-list))
1335     reversed-elements)
1336     (incf length))
1337     (t
1338     (push (cons (string 'rest) in-list) reversed-elements)
1339     (done "The object is an improper list of length ~S.~%")))))))
1340    
1341     (defmethod inspected-parts ((o function))
1342     (let ((header (kernel:get-type o)))
1343     (cond ((= header vm:function-header-type)
1344     (values
1345     (format nil "~A~% is a function." o)
1346     (list (cons "Self" (kernel:%function-self o))
1347     (cons "Next" (kernel:%function-next o))
1348     (cons "Name" (kernel:%function-name o))
1349     (cons "Arglist" (kernel:%function-arglist o))
1350     (cons "Type" (kernel:%function-type o))
1351     (cons "Code Object" (kernel:function-code-header o)))))
1352     ((= header vm:closure-header-type)
1353     (values (format nil "~A~% is a closure." o)
1354     (list*
1355     (cons "Function" (kernel:%closure-function o))
1356     (loop for i from 0 below (- (kernel:get-closure-length o)
1357     (1- vm:closure-info-offset))
1358     collect (cons (format nil "~D" i)
1359     (kernel:%closure-index-ref o i))))))
1360     (t (call-next-method o)))))
1361    
1362     (defmethod inspected-parts ((o kernel:code-component))
1363     (values (format nil "~A~% is a code data-block." o)
1364     `(("First entry point" . ,(kernel:%code-entry-points o))
1365     ,@(loop for i from vm:code-constants-offset
1366     below (kernel:get-header-data o)
1367     collect (cons (format nil "Constant#~D" i)
1368     (kernel:code-header-ref o i)))
1369     ("Debug info" . ,(kernel:%code-debug-info o))
1370     ("Instructions" . ,(kernel:code-instructions o)))))
1371    
1372     (defmethod inspected-parts ((o kernel:fdefn))
1373     (values (format nil "~A~% is a fdefn object." o)
1374     `(("Name" . ,(kernel:fdefn-name o))
1375     ("Function" . ,(kernel:fdefn-function o)))))
1376    
1377     ;;; Local Variables:
1378     ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1379     ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5