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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.152 - (hide annotations)
Mon Aug 29 19:33:26 2005 UTC (8 years, 7 months ago) by mkoeppe
Branch: MAIN
Changes since 1.151: +4 -4 lines
(eval-in-emacs): Removed.
(send-to-emacs): New.
(pre-gc-hook, post-gc-hook): Use new protocol message
:background-message rather than eval-in-emacs.
1 lgorrie 1.103 ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2     ;;;
3 heller 1.108 ;;; License: Public Domain
4     ;;;
5 lgorrie 1.103 ;;;; Introduction
6     ;;;
7     ;;; This is the CMUCL implementation of the `swank-backend' package.
8 dbarlow 1.1
9 heller 1.80 (in-package :swank-backend)
10 dbarlow 1.1
11 heller 1.119 (import-swank-mop-symbols :pcl '(:slot-definition-documentation))
12    
13     (defun swank-mop:slot-definition-documentation (slot)
14     (documentation slot t))
15    
16 lgorrie 1.103 ;;;; "Hot fixes"
17     ;;;
18 heller 1.147 ;;; Here are necessary bugfixes to the oldest supported version of
19 lgorrie 1.103 ;;; CMUCL (currently 18e). Any fixes placed here should also be
20     ;;; submitted to the `cmucl-imp' mailing list and confirmed as
21     ;;; good. When a new release is made that includes the fixes we should
22     ;;; promptly delete them from here. It is enough to be compatible with
23     ;;; the latest release.
24    
25 heller 1.67 (in-package :lisp)
26    
27 lgorrie 1.103 ;;; `READ-SEQUENCE' with large sequences has problems in 18e. This new
28     ;;; definition works better.
29    
30 heller 1.131 #-cmu19
31 heller 1.67 (progn
32     (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
33     (when s
34     (setf (symbol-value s) nil)))
35    
36     (defun read-into-simple-string (s stream start end)
37     (declare (type simple-string s))
38     (declare (type stream stream))
39     (declare (type index start end))
40     (unless (subtypep (stream-element-type stream) 'character)
41     (error 'type-error
42     :datum (read-char stream nil #\Null)
43     :expected-type (stream-element-type stream)
44     :format-control "Trying to read characters from a binary stream."))
45     ;; Let's go as low level as it seems reasonable.
46     (let* ((numbytes (- end start))
47 heller 1.79 (total-bytes 0))
48     ;; read-n-bytes may return fewer bytes than requested, so we need
49     ;; to keep trying.
50     (loop while (plusp numbytes) do
51     (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
52     (when (zerop bytes-read)
53     (return-from read-into-simple-string total-bytes))
54     (incf total-bytes bytes-read)
55     (incf start bytes-read)
56     (decf numbytes bytes-read)))
57     total-bytes))
58 heller 1.67
59     (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
60     (when s
61     (setf (symbol-value s) t)))
62    
63     )
64    
65 heller 1.80 (in-package :swank-backend)
66 heller 1.67
67 lgorrie 1.25
68 lgorrie 1.103 ;;;; TCP server
69     ;;;
70     ;;; In CMUCL we support all communication styles. By default we use
71     ;;; `:SIGIO' because it is the most responsive, but it's somewhat
72     ;;; dangerous: CMUCL is not in general "signal safe", and you don't
73     ;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and
74     ;;; `:SPAWN' are reasonable alternatives.
75 lgorrie 1.25
76 heller 1.80 (defimplementation preferred-communication-style ()
77     :sigio)
78 heller 1.48
79 heller 1.133 #-(or ppc mips)
80 heller 1.63 (defimplementation create-socket (host port)
81 heller 1.136 (let* ((addr (resolve-hostname host))
82     (addr (if (not (find-symbol "SOCKET-ERROR" :ext))
83     (ext:htonl addr)
84     addr)))
85     (ext:create-inet-listener port :stream :reuse-address t :host addr)))
86 heller 1.133
87     ;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix.
88     #+(or ppc mips)
89     (defimplementation create-socket (host port)
90     (declare (ignore host))
91     (ext:create-inet-listener port :stream :reuse-address t))
92 heller 1.47
93 lgorrie 1.56 (defimplementation local-port (socket)
94 heller 1.47 (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
95    
96 lgorrie 1.56 (defimplementation close-socket (socket)
97 lgorrie 1.106 (sys:invalidate-descriptor socket)
98 heller 1.47 (ext:close-socket (socket-fd socket)))
99    
100 heller 1.133 (defimplementation accept-connection (socket &key external-format)
101     (let ((ef (or external-format :iso-latin-1-unix)))
102     (assert (eq ef ':iso-latin-1-unix))
103     (make-socket-io-stream (ext:accept-tcp-connection socket))))
104 heller 1.47
105 lgorrie 1.103 ;;;;; Sockets
106    
107     (defun socket-fd (socket)
108     "Return the filedescriptor for the socket represented by SOCKET."
109     (etypecase socket
110     (fixnum socket)
111     (sys:fd-stream (sys:fd-stream-fd socket))))
112    
113     (defun resolve-hostname (hostname)
114 heller 1.136 "Return the IP address of HOSTNAME as an integer (in host byte-order)."
115     (let ((hostent (ext:lookup-host-entry hostname)))
116     (car (ext:host-entry-addr-list hostent))))
117 lgorrie 1.103
118     (defun make-socket-io-stream (fd)
119     "Create a new input/output fd-stream for FD."
120     (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
121    
122     ;;;;; Signal-driven I/O
123    
124 heller 1.59 (defvar *sigio-handlers* '()
125 lgorrie 1.103 "List of (key . function) pairs.
126     All functions are called on SIGIO, and the key is used for removing
127     specific functions.")
128 heller 1.59
129     (defun set-sigio-handler ()
130 heller 1.101 (sys:enable-interrupt :sigio (lambda (signal code scp)
131     (sigio-handler signal code scp))))
132 heller 1.59
133 lgorrie 1.103 (defun sigio-handler (signal code scp)
134     (declare (ignore signal code scp))
135     (mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
136    
137 heller 1.68 (defun fcntl (fd command arg)
138 lgorrie 1.103 "fcntl(2) - manipulate a file descriptor."
139 heller 1.68 (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
140 lgorrie 1.103 (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error)))))
141 heller 1.68
142     (defimplementation add-sigio-handler (socket fn)
143     (set-sigio-handler)
144 heller 1.59 (let ((fd (socket-fd socket)))
145 heller 1.68 (fcntl fd unix:f-setown (unix:unix-getpid))
146 heller 1.92 (fcntl fd unix:f-setfl unix:fasync)
147 heller 1.68 (push (cons fd fn) *sigio-handlers*)))
148 lgorrie 1.45
149 heller 1.68 (defimplementation remove-sigio-handlers (socket)
150 heller 1.59 (let ((fd (socket-fd socket)))
151 lgorrie 1.103 (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
152 heller 1.68 (sys:invalidate-descriptor fd))
153 heller 1.50 (close socket))
154    
155 lgorrie 1.103 ;;;;; SERVE-EVENT
156    
157 heller 1.68 (defimplementation add-fd-handler (socket fn)
158     (let ((fd (socket-fd socket)))
159     (sys:add-fd-handler fd :input (lambda (_)
160     _
161     (funcall fn)))))
162    
163     (defimplementation remove-fd-handlers (socket)
164     (sys:invalidate-descriptor (socket-fd socket)))
165    
166 lgorrie 1.103
167     ;;;; Stream handling
168     ;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
169    
170 lgorrie 1.56 (defimplementation make-fn-streams (input-fn output-fn)
171 lgorrie 1.45 (let* ((output (make-slime-output-stream output-fn))
172     (input (make-slime-input-stream input-fn output)))
173     (values input output)))
174 lgorrie 1.25
175 dbarlow 1.1 (defstruct (slime-output-stream
176 lgorrie 1.45 (:include lisp::lisp-stream
177     (lisp::misc #'sos/misc)
178     (lisp::out #'sos/out)
179     (lisp::sout #'sos/sout))
180     (:conc-name sos.)
181     (:print-function %print-slime-output-stream)
182     (:constructor make-slime-output-stream (output-fn)))
183     (output-fn nil :type function)
184 heller 1.16 (buffer (make-string 512) :type string)
185     (index 0 :type kernel:index)
186     (column 0 :type kernel:index))
187    
188 heller 1.17 (defun %print-slime-output-stream (s stream d)
189     (declare (ignore d))
190     (print-unreadable-object (s stream :type t :identity t)))
191    
192 heller 1.16 (defun sos/out (stream char)
193     (let ((buffer (sos.buffer stream))
194     (index (sos.index stream)))
195     (setf (schar buffer index) char)
196     (setf (sos.index stream) (1+ index))
197     (incf (sos.column stream))
198 heller 1.21 (when (char= #\newline char)
199 heller 1.119 (setf (sos.column stream) 0)
200     (force-output stream))
201 heller 1.21 (when (= index (1- (length buffer)))
202     (force-output stream)))
203 heller 1.16 char)
204    
205     (defun sos/sout (stream string start end)
206     (loop for i from start below end
207     do (sos/out stream (aref string i))))
208 lgorrie 1.45
209 heller 1.16 (defun sos/misc (stream operation &optional arg1 arg2)
210     (declare (ignore arg1 arg2))
211 dbarlow 1.1 (case operation
212 heller 1.17 ((:force-output :finish-output)
213 heller 1.16 (let ((end (sos.index stream)))
214     (unless (zerop end)
215 heller 1.128 (let ((s (subseq (sos.buffer stream) 0 end)))
216     (setf (sos.index stream) 0)
217     (funcall (sos.output-fn stream) s)))))
218 heller 1.16 (:charpos (sos.column stream))
219     (:line-length 75)
220 dbarlow 1.1 (:file-position nil)
221 heller 1.16 (:element-type 'base-char)
222     (:get-command nil)
223 heller 1.22 (:close nil)
224 heller 1.16 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
225 dbarlow 1.1
226 heller 1.9 (defstruct (slime-input-stream
227 lgorrie 1.45 (:include string-stream
228     (lisp::in #'sis/in)
229     (lisp::misc #'sis/misc))
230     (:conc-name sis.)
231     (:print-function %print-slime-output-stream)
232     (:constructor make-slime-input-stream (input-fn sos)))
233     (input-fn nil :type function)
234     ;; We know our sibling output stream, so that we can force it before
235     ;; requesting input.
236     (sos nil :type slime-output-stream)
237     (buffer "" :type string)
238     (index 0 :type kernel:index))
239 heller 1.16
240     (defun sis/in (stream eof-errorp eof-value)
241     (let ((index (sis.index stream))
242     (buffer (sis.buffer stream)))
243     (when (= index (length buffer))
244 lgorrie 1.45 (force-output (sis.sos stream))
245 heller 1.119 (let ((string (funcall (sis.input-fn stream))))
246     (cond ((zerop (length string))
247     (return-from sis/in
248     (if eof-errorp
249     (error (make-condition 'end-of-file :stream stream))
250     eof-value)))
251     (t
252     (setf buffer string)
253     (setf (sis.buffer stream) buffer)
254     (setf index 0)))))
255 heller 1.16 (prog1 (aref buffer index)
256     (setf (sis.index stream) (1+ index)))))
257 heller 1.9
258 heller 1.16 (defun sis/misc (stream operation &optional arg1 arg2)
259 heller 1.14 (declare (ignore arg2))
260 heller 1.15 (ecase operation
261     (:file-position nil)
262 heller 1.16 (:file-length nil)
263     (:unread (setf (aref (sis.buffer stream)
264     (decf (sis.index stream)))
265     arg1))
266 heller 1.57 (:clear-input
267     (setf (sis.index stream) 0
268 heller 1.16 (sis.buffer stream) ""))
269     (:listen (< (sis.index stream) (length (sis.buffer stream))))
270     (:charpos nil)
271     (:line-length nil)
272     (:get-command nil)
273 heller 1.22 (:element-type 'base-char)
274 heller 1.149 (:close nil)
275     (:interactive-p t)))
276 heller 1.16
277 lgorrie 1.25
278 dbarlow 1.1 ;;;; Compilation Commands
279    
280 lgorrie 1.24 (defvar *previous-compiler-condition* nil
281     "Used to detect duplicates.")
282    
283     (defvar *previous-context* nil
284     "Previous compiler error context.")
285    
286 lgorrie 1.103 (defvar *buffer-name* nil
287     "The name of the Emacs buffer we are compiling from.
288     NIL if we aren't compiling from a buffer.")
289    
290 heller 1.30 (defvar *buffer-start-position* nil)
291     (defvar *buffer-substring* nil)
292    
293 lgorrie 1.103 (defimplementation call-with-compilation-hooks (function)
294     (let ((*previous-compiler-condition* nil)
295     (*previous-context* nil)
296     (*print-readably* nil))
297     (handler-bind ((c::compiler-error #'handle-notification-condition)
298     (c::style-warning #'handle-notification-condition)
299     (c::warning #'handle-notification-condition))
300     (funcall function))))
301    
302 heller 1.150 (defimplementation swank-compile-file (filename load-p
303     &optional external-format)
304     (declare (ignore external-format))
305 lgorrie 1.103 (clear-xref-info filename)
306     (with-compilation-hooks ()
307 heller 1.127 (let ((*buffer-name* nil)
308     (ext:*ignore-extra-close-parentheses* nil))
309 lgorrie 1.103 (multiple-value-bind (output-file warnings-p failure-p)
310 heller 1.125 (compile-file filename)
311 lgorrie 1.103 (unless failure-p
312     ;; Cache the latest source file for definition-finding.
313 heller 1.125 (source-cache-get filename (file-write-date filename))
314 heller 1.130 (when load-p (load output-file)))
315 lgorrie 1.103 (values output-file warnings-p failure-p)))))
316    
317 pseibel 1.113 (defimplementation swank-compile-string (string &key buffer position directory)
318     (declare (ignore directory))
319 lgorrie 1.103 (with-compilation-hooks ()
320     (let ((*buffer-name* buffer)
321     (*buffer-start-position* position)
322     (*buffer-substring* string))
323     (with-input-from-string (stream string)
324     (ext:compile-from-stream
325     stream
326     :source-info `(:emacs-buffer ,buffer
327     :emacs-buffer-offset ,position
328     :emacs-buffer-string ,string))))))
329    
330 lgorrie 1.25
331 lgorrie 1.24 ;;;;; Trapping notes
332 lgorrie 1.103 ;;;
333     ;;; We intercept conditions from the compiler and resignal them as
334     ;;; `SWANK:COMPILER-CONDITION's.
335 lgorrie 1.24
336     (defun handle-notification-condition (condition)
337 lgorrie 1.103 "Handle a condition caused by a compiler warning."
338 dbarlow 1.1 (unless (eq condition *previous-compiler-condition*)
339 heller 1.65 (let ((context (c::find-error-context nil)))
340 dbarlow 1.1 (setq *previous-compiler-condition* condition)
341     (setq *previous-context* context)
342 lgorrie 1.24 (signal-compiler-condition condition context))))
343    
344     (defun signal-compiler-condition (condition context)
345     (signal (make-condition
346     'compiler-condition
347     :original-condition condition
348     :severity (severity-for-emacs condition)
349 heller 1.65 :short-message (brief-compiler-message-for-emacs condition)
350     :message (long-compiler-message-for-emacs condition context)
351 heller 1.127 :location (if (read-error-p condition)
352 heller 1.125 (read-error-location condition)
353     (compiler-note-location context)))))
354 lgorrie 1.24
355     (defun severity-for-emacs (condition)
356     "Return the severity of CONDITION."
357     (etypecase condition
358 heller 1.127 ((satisfies read-error-p) :read-error)
359 lgorrie 1.24 (c::compiler-error :error)
360     (c::style-warning :note)
361     (c::warning :warning)))
362    
363 heller 1.127 (defun read-error-p (condition)
364     (eq (type-of condition) 'c::compiler-read-error))
365    
366 heller 1.65 (defun brief-compiler-message-for-emacs (condition)
367 lgorrie 1.24 "Briefly describe a compiler error for Emacs.
368     When Emacs presents the message it already has the source popped up
369     and the source form highlighted. This makes much of the information in
370     the error-context redundant."
371 heller 1.65 (princ-to-string condition))
372    
373     (defun long-compiler-message-for-emacs (condition error-context)
374     "Describe a compiler error for Emacs including context information."
375 lgorrie 1.24 (declare (type (or c::compiler-error-context null) error-context))
376 heller 1.30 (multiple-value-bind (enclosing source)
377     (if error-context
378     (values (c::compiler-error-context-enclosing-source error-context)
379     (c::compiler-error-context-source error-context)))
380     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
381     enclosing source condition)))
382 heller 1.125
383     (defun read-error-location (condition)
384     (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
385     (file (c::file-info-name finfo))
386     (pos (c::compiler-read-error-position condition)))
387     (cond ((and (eq file :stream) *buffer-name*)
388     (make-location (list :buffer *buffer-name*)
389 heller 1.127 (list :position (+ *buffer-start-position* pos))))
390 heller 1.125 ((and (pathnamep file) (not *buffer-name*))
391     (make-location (list :file (unix-truename file))
392 heller 1.127 (list :position (1+ pos))))
393 heller 1.125 (t (break)))))
394 heller 1.30
395     (defun compiler-note-location (context)
396 lgorrie 1.103 "Derive the location of a complier message from its context.
397     Return a `location' record, or (:error REASON) on failure."
398     (if (null context)
399     (note-error-location)
400     (let ((file (c::compiler-error-context-file-name context))
401     (source (c::compiler-error-context-original-source context))
402     (path
403     (reverse (c::compiler-error-context-original-source-path context))))
404     (or (locate-compiler-note file source path)
405     (note-error-location)))))
406    
407     (defun note-error-location ()
408     "Pseudo-location for notes that can't be located."
409     (list :error "No error location available."))
410    
411     (defun locate-compiler-note (file source source-path)
412     (cond ((and (eq file :stream) *buffer-name*)
413     ;; Compiling from a buffer
414     (let ((position (+ *buffer-start-position*
415     (source-path-string-position
416     source-path *buffer-substring*))))
417     (make-location (list :buffer *buffer-name*)
418     (list :position position))))
419     ((and (pathnamep file) (null *buffer-name*))
420     ;; Compiling from a file
421     (make-location (list :file (unix-truename file))
422     (list :position
423     (1+ (source-path-file-position
424     source-path file)))))
425     ((and (eq file :lisp) (stringp source))
426     ;; No location known, but we have the source form.
427 heller 1.112 ;; XXX How is this case triggered? -luke (16/May/2004)
428     ;; This can happen if the compiler needs to expand a macro
429     ;; but the macro-expander is not yet compiled. Calling the
430     ;; (interpreted) macro-expander triggers IR1 conversion of
431     ;; the lambda expression for the expander and invokes the
432     ;; compiler recursively.
433 lgorrie 1.103 (make-location (list :source-form source)
434     (list :position 1)))))
435 heller 1.30
436 lgorrie 1.103 (defun unix-truename (pathname)
437     (ext:unix-namestring (truename pathname)))
438 dbarlow 1.1
439 lgorrie 1.25
440     ;;;; XREF
441 lgorrie 1.103 ;;;
442     ;;; Cross-reference support is based on the standard CMUCL `XREF'
443     ;;; package. This package has some caveats: XREF information is
444     ;;; recorded during compilation and not preserved in fasl files, and
445     ;;; XREF recording is disabled by default. Redefining functions can
446     ;;; also cause duplicate references to accumulate, but
447     ;;; `swank-compile-file' will automatically clear out any old records
448     ;;; from the same filename.
449     ;;;
450     ;;; To enable XREF recording, set `c:*record-xref-info*' to true. To
451     ;;; clear out the XREF database call `xref:init-xref-database'.
452 dbarlow 1.1
453 heller 1.81 (defmacro defxref (name function)
454     `(defimplementation ,name (name)
455 heller 1.82 (xref-results (,function name))))
456 heller 1.81
457     (defxref who-calls xref:who-calls)
458     (defxref who-references xref:who-references)
459     (defxref who-binds xref:who-binds)
460     (defxref who-sets xref:who-sets)
461 dbarlow 1.1
462 lgorrie 1.103 ;;; More types of XREF information were added since 18e:
463     ;;;
464 lgorrie 1.10 #+cmu19
465 heller 1.32 (progn
466 heller 1.81 (defxref who-macroexpands xref:who-macroexpands)
467     ;; XXX
468     (defimplementation who-specializes (symbol)
469     (let* ((methods (xref::who-specializes (find-class symbol)))
470 heller 1.86 (locations (mapcar #'method-location methods)))
471 heller 1.81 (mapcar #'list methods locations))))
472    
473     (defun xref-results (contexts)
474     (mapcar (lambda (xref)
475     (list (xref:xref-context-name xref)
476     (resolve-xref-location xref)))
477     contexts))
478 heller 1.30
479     (defun resolve-xref-location (xref)
480     (let ((name (xref:xref-context-name xref))
481     (file (xref:xref-context-file xref))
482     (source-path (xref:xref-context-source-path xref)))
483     (cond ((and file source-path)
484     (let ((position (source-path-file-position source-path file)))
485     (make-location (list :file (unix-truename file))
486     (list :position (1+ position)))))
487     (file
488     (make-location (list :file (unix-truename file))
489     (list :function-name (string name))))
490     (t
491 lgorrie 1.99 `(:error ,(format nil "Unknown source location: ~S ~S ~S "
492 heller 1.30 name file source-path))))))
493    
494 lgorrie 1.25 (defun clear-xref-info (namestring)
495 heller 1.66 "Clear XREF notes pertaining to NAMESTRING.
496 lgorrie 1.25 This is a workaround for a CMUCL bug: XREF records are cumulative."
497 heller 1.65 (when c:*record-xref-info*
498 heller 1.66 (let ((filename (truename namestring)))
499 lgorrie 1.25 (dolist (db (list xref::*who-calls*
500     #+cmu19 xref::*who-is-called*
501     #+cmu19 xref::*who-macroexpands*
502     xref::*who-references*
503     xref::*who-binds*
504     xref::*who-sets*))
505     (maphash (lambda (target contexts)
506 heller 1.66 ;; XXX update during traversal?
507 lgorrie 1.25 (setf (gethash target db)
508 heller 1.66 (delete filename contexts
509     :key #'xref:xref-context-file
510     :test #'equalp)))
511 lgorrie 1.25 db)))))
512    
513    
514     ;;;; Find callers and callees
515 lgorrie 1.103 ;;;
516 dbarlow 1.1 ;;; Find callers and callees by looking at the constant pool of
517     ;;; compiled code objects. We assume every fdefn object in the
518     ;;; constant pool corresponds to a call to that function. A better
519     ;;; strategy would be to use the disassembler to find actual
520     ;;; call-sites.
521    
522     (declaim (inline map-code-constants))
523     (defun map-code-constants (code fn)
524     "Call FN for each constant in CODE's constant pool."
525     (check-type code kernel:code-component)
526     (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
527     do (funcall fn (kernel:code-header-ref code i))))
528    
529     (defun function-callees (function)
530 heller 1.30 "Return FUNCTION's callees as a list of functions."
531 dbarlow 1.1 (let ((callees '()))
532     (map-code-constants
533     (vm::find-code-object function)
534     (lambda (obj)
535     (when (kernel:fdefn-p obj)
536 heller 1.30 (push (kernel:fdefn-function obj) callees))))
537 dbarlow 1.1 callees))
538    
539 heller 1.19 (declaim (ext:maybe-inline map-allocated-code-components))
540 dbarlow 1.1 (defun map-allocated-code-components (spaces fn)
541     "Call FN for each allocated code component in one of SPACES. FN
542 heller 1.19 receives the object as argument. SPACES should be a list of the
543     symbols :dynamic, :static, or :read-only."
544 dbarlow 1.1 (dolist (space spaces)
545 heller 1.119 (declare (inline vm::map-allocated-objects)
546     (optimize (ext:inhibit-warnings 3)))
547 dbarlow 1.1 (vm::map-allocated-objects
548     (lambda (obj header size)
549 heller 1.19 (declare (type fixnum size) (ignore size))
550 dbarlow 1.1 (when (= vm:code-header-type header)
551 heller 1.19 (funcall fn obj)))
552 dbarlow 1.1 space)))
553    
554 heller 1.19 (declaim (ext:maybe-inline map-caller-code-components))
555 dbarlow 1.1 (defun map-caller-code-components (function spaces fn)
556     "Call FN for each code component with a fdefn for FUNCTION in its
557     constant pool."
558     (let ((function (coerce function 'function)))
559 heller 1.19 (declare (inline map-allocated-code-components))
560 dbarlow 1.1 (map-allocated-code-components
561     spaces
562 heller 1.19 (lambda (obj)
563 dbarlow 1.1 (map-code-constants
564     obj
565     (lambda (constant)
566     (when (and (kernel:fdefn-p constant)
567     (eq (kernel:fdefn-function constant)
568     function))
569     (funcall fn obj))))))))
570    
571     (defun function-callers (function &optional (spaces '(:read-only :static
572     :dynamic)))
573 heller 1.30 "Return FUNCTION's callers. The result is a list of code-objects."
574 dbarlow 1.1 (let ((referrers '()))
575 heller 1.19 (declare (inline map-caller-code-components))
576 heller 1.108 ;;(ext:gc :full t)
577 heller 1.30 (map-caller-code-components function spaces
578     (lambda (code) (push code referrers)))
579 dbarlow 1.1 referrers))
580 heller 1.80
581 heller 1.30 (defun debug-info-definitions (debug-info)
582     "Return the defintions for a debug-info. This should only be used
583     for code-object without entry points, i.e., byte compiled
584     code (are theree others?)"
585     ;; This mess has only been tested with #'ext::skip-whitespace, a
586     ;; byte-compiled caller of #'read-char .
587     (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
588     (let ((name (c::debug-info-name debug-info))
589     (source (c::debug-info-source debug-info)))
590     (destructuring-bind (first) source
591     (ecase (c::debug-source-from first)
592     (:file
593 heller 1.80 (list (list name
594     (make-location
595     (list :file (unix-truename (c::debug-source-name first)))
596 heller 1.119 (list :function-name (string name))))))))))
597 heller 1.30
598     (defun code-component-entry-points (code)
599 heller 1.80 "Return a list ((NAME LOCATION) ...) of function definitons for
600 heller 1.30 the code omponent CODE."
601 heller 1.122 (let ((names '()))
602     (do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
603     ((not f))
604     (let ((name (kernel:%function-name f)))
605     (when (ext:valid-function-name-p name)
606     (push (list name (function-location f)) names))))
607     names))
608 dbarlow 1.1
609 heller 1.80 (defimplementation list-callers (symbol)
610     "Return a list ((NAME LOCATION) ...) of callers."
611     (let ((components (function-callers symbol))
612 heller 1.30 (xrefs '()))
613     (dolist (code components)
614     (let* ((entry (kernel:%code-entry-points code))
615     (defs (if entry
616     (code-component-entry-points code)
617     ;; byte compiled stuff
618     (debug-info-definitions
619     (kernel:%code-debug-info code)))))
620     (setq xrefs (nconc defs xrefs))))
621 heller 1.80 xrefs))
622 dbarlow 1.1
623 heller 1.80 (defimplementation list-callees (symbol)
624     (let ((fns (function-callees symbol)))
625     (mapcar (lambda (fn)
626     (list (kernel:%function-name fn)
627 heller 1.86 (function-location fn)))
628 heller 1.80 fns)))
629 dbarlow 1.1
630 lgorrie 1.42
631 lgorrie 1.103 ;;;; Resolving source locations
632     ;;;
633     ;;; Our mission here is to "resolve" references to code locations into
634     ;;; actual file/buffer names and character positions. The references
635     ;;; we work from come out of the compiler's statically-generated debug
636     ;;; information, such as `code-location''s and `debug-source''s. For
637     ;;; more details, see the "Debugger Programmer's Interface" section of
638     ;;; the CMUCL manual.
639     ;;;
640     ;;; The first step is usually to find the corresponding "source-path"
641     ;;; for the location. Once we have the source-path we can pull up the
642     ;;; source file and `READ' our way through to the right position. The
643     ;;; main source-code groveling work is done in
644     ;;; `swank-source-path-parser.lisp'.
645 dbarlow 1.1
646 lgorrie 1.35 (defvar *debug-definition-finding* nil
647 dbarlow 1.1 "When true don't handle errors while looking for definitions.
648     This is useful when debugging the definition-finding code.")
649    
650 lgorrie 1.99 (defvar *source-snippet-size* 256
651     "Maximum number of characters in a snippet of source code.
652     Snippets at the beginning of definitions are used to tell Emacs what
653     the definitions looks like, so that it can accurately find them by
654     text search.")
655    
656 lgorrie 1.103 (defmacro safe-definition-finding (&body body)
657     "Execute BODY and return the source-location it returns.
658     If an error occurs and `*debug-definition-finding*' is false, then
659     return an error pseudo-location.
660    
661     The second return value is NIL if no error occurs, otherwise it is the
662     condition object."
663     `(flet ((body () ,@body))
664     (if *debug-definition-finding*
665     (body)
666     (handler-case (values (progn ,@body) nil)
667     (error (c) (values (list :error (princ-to-string c)) c))))))
668    
669     (defun code-location-source-location (code-location)
670     "Safe wrapper around `code-location-from-source-location'."
671     (safe-definition-finding
672     (source-location-from-code-location code-location)))
673    
674     (defun source-location-from-code-location (code-location)
675     "Return the source location for CODE-LOCATION."
676     (let ((debug-fun (di:code-location-debug-function code-location)))
677     (when (di::bogus-debug-function-p debug-fun)
678     ;; Those lousy cheapskates! They've put in a bogus debug source
679     ;; because the code was compiled at a low debug setting.
680     (error "Bogus debug function: ~A" debug-fun)))
681     (let* ((debug-source (di:code-location-debug-source code-location))
682     (from (di:debug-source-from debug-source))
683     (name (di:debug-source-name debug-source)))
684     (ecase from
685     (:file
686     (location-in-file name code-location debug-source))
687     (:stream
688     (location-in-stream code-location debug-source))
689     (:lisp
690     ;; The location comes from a form passed to `compile'.
691     ;; The best we can do is return the form itself for printing.
692     (make-location
693     (list :source-form (with-output-to-string (*standard-output*)
694     (debug::print-code-location-source-form
695     code-location 100 t)))
696     (list :position 1))))))
697    
698     (defun location-in-file (filename code-location debug-source)
699     "Resolve the source location for CODE-LOCATION in FILENAME."
700     (let* ((code-date (di:debug-source-created debug-source))
701 lgorrie 1.141 (source-code (get-source-code filename code-date)))
702 lgorrie 1.103 (with-input-from-string (s source-code)
703     (make-location (list :file (unix-truename filename))
704 heller 1.142 (list :position (1+ (code-location-stream-position
705     code-location s)))
706 lgorrie 1.103 `(:snippet ,(read-snippet s))))))
707    
708     (defun location-in-stream (code-location debug-source)
709     "Resolve the source location for a CODE-LOCATION from a stream.
710     This only succeeds if the code was compiled from an Emacs buffer."
711     (unless (debug-source-info-from-emacs-buffer-p debug-source)
712     (error "The code is compiled from a non-SLIME stream."))
713     (let* ((info (c::debug-source-info debug-source))
714     (string (getf info :emacs-buffer-string))
715     (position (code-location-string-offset
716     code-location
717     string)))
718     (make-location
719     (list :buffer (getf info :emacs-buffer))
720     (list :position (+ (getf info :emacs-buffer-offset) position))
721     (list :snippet (with-input-from-string (s string)
722     (file-position s position)
723     (read-snippet s))))))
724    
725     ;;;;; Function-name locations
726     ;;;
727     (defun debug-info-function-name-location (debug-info)
728     "Return a function-name source-location for DEBUG-INFO.
729     Function-name source-locations are a fallback for when precise
730     positions aren't available."
731     (with-struct (c::debug-info- (fname name) source) debug-info
732     (with-struct (c::debug-source- info from name) (car source)
733     (ecase from
734     (:file
735     (make-location (list :file (namestring (truename name)))
736 heller 1.119 (list :function-name (string fname))))
737 lgorrie 1.103 (:stream
738     (assert (debug-source-info-from-emacs-buffer-p (car source)))
739     (make-location (list :buffer (getf info :emacs-buffer))
740 heller 1.119 (list :function-name (string fname))))
741 lgorrie 1.103 (:lisp
742     (make-location (list :source-form (princ-to-string (aref name 0)))
743     (list :position 1)))))))
744    
745     (defun debug-source-info-from-emacs-buffer-p (debug-source)
746     "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location?
747     This is true for functions that were compiled directly from buffers."
748     (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
749    
750     (defun info-from-emacs-buffer-p (info)
751     (and info
752     (consp info)
753     (eq :emacs-buffer (car info))))
754    
755    
756     ;;;;; Groveling source-code for positions
757    
758     (defun code-location-stream-position (code-location stream)
759     "Return the byte offset of CODE-LOCATION in STREAM. Extract the
760     toplevel-form-number and form-number from CODE-LOCATION and use that
761     to find the position of the corresponding form.
762    
763     Finish with STREAM positioned at the start of the code location."
764     (let* ((location (debug::maybe-block-start-location code-location))
765     (tlf-offset (di:code-location-top-level-form-offset location))
766     (form-number (di:code-location-form-number location)))
767     (let ((pos (form-number-stream-position tlf-offset form-number stream)))
768     (file-position stream pos)
769     pos)))
770    
771     (defun form-number-stream-position (tlf-number form-number stream)
772     "Return the starting character position of a form in STREAM.
773     TLF-NUMBER is the top-level-form number.
774     FORM-NUMBER is an index into a source-path table for the TLF."
775 heller 1.135 (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
776     (let* ((path-table (di:form-number-translations tlf 0))
777     (source-path
778     (if (<= (length path-table) form-number) ; source out of sync?
779     (list 0) ; should probably signal a condition
780     (reverse (cdr (aref path-table form-number))))))
781     (source-path-source-position source-path tlf position-map))))
782 lgorrie 1.103
783     (defun code-location-string-offset (code-location string)
784     "Return the byte offset of CODE-LOCATION in STRING.
785     See CODE-LOCATION-STREAM-POSITION."
786     (with-input-from-string (s string)
787     (code-location-stream-position code-location s)))
788 lgorrie 1.110
789 lgorrie 1.103
790     ;;;; Finding definitions
791    
792     ;;; There are a great many different types of definition for us to
793     ;;; find. We search for definitions of every kind and return them in a
794     ;;; list.
795    
796     (defimplementation find-definitions (name)
797     (append (function-definitions name)
798     (setf-definitions name)
799     (variable-definitions name)
800     (class-definitions name)
801     (type-definitions name)
802     (compiler-macro-definitions name)
803     (source-transform-definitions name)
804     (function-info-definitions name)
805     (ir1-translator-definitions name)))
806    
807     ;;;;; Functions, macros, generic functions, methods
808     ;;;
809     ;;; We make extensive use of the compile-time debug information that
810     ;;; CMUCL records, in particular "debug functions" and "code
811     ;;; locations." Refer to the "Debugger Programmer's Interface" section
812     ;;; of the CMUCL manual for more details.
813    
814     (defun function-definitions (name)
815     "Return definitions for NAME in the \"function namespace\", i.e.,
816     regular functions, generic functions, methods and macros.
817     NAME can any valid function name (e.g, (setf car))."
818     (let ((macro? (and (symbolp name) (macro-function name)))
819     (special? (and (symbolp name) (special-operator-p name)))
820     (function? (and (ext:valid-function-name-p name)
821 heller 1.140 (ext:info :function :definition name)
822     (if (symbolp name) (fboundp name) t))))
823 lgorrie 1.103 (cond (macro?
824     (list `((defmacro ,name)
825     ,(function-location (macro-function name)))))
826     (special?
827     (list `((:special-operator ,name)
828     (:error ,(format nil "Special operator: ~S" name)))))
829     (function?
830     (let ((function (fdefinition name)))
831     (if (genericp function)
832     (generic-function-definitions name function)
833     (list (list `(function ,name)
834     (function-location function)))))))))
835    
836     ;;;;;; Ordinary (non-generic/macro/special) functions
837     ;;;
838     ;;; First we test if FUNCTION is a closure created by defstruct, and
839     ;;; if so extract the defstruct-description (`dd') from the closure
840     ;;; and find the constructor for the struct. Defstruct creates a
841     ;;; defun for the default constructor and we use that as an
842     ;;; approximation to the source location of the defstruct.
843     ;;;
844     ;;; For an ordinary function we return the source location of the
845     ;;; first code-location we find.
846     ;;;
847     (defun function-location (function)
848     "Return the source location for FUNCTION."
849     (cond ((struct-closure-p function)
850     (struct-closure-location function))
851     ((c::byte-function-or-closure-p function)
852     (byte-function-location function))
853     (t
854     (compiled-function-location function))))
855 lgorrie 1.100
856 lgorrie 1.103 (defun compiled-function-location (function)
857     "Return the location of a regular compiled function."
858     (multiple-value-bind (code-location error)
859     (safe-definition-finding (function-first-code-location function))
860     (cond (error (list :error (princ-to-string error)))
861     (t (code-location-source-location code-location)))))
862 heller 1.88
863 dbarlow 1.1 (defun function-first-code-location (function)
864 lgorrie 1.103 "Return the first code-location we can find for FUNCTION."
865 dbarlow 1.1 (and (function-has-debug-function-p function)
866     (di:debug-function-start-location
867     (di:function-debug-function function))))
868    
869     (defun function-has-debug-function-p (function)
870     (di:function-debug-function function))
871    
872     (defun function-code-object= (closure function)
873     (and (eq (vm::find-code-object closure)
874     (vm::find-code-object function))
875     (not (eq closure function))))
876    
877 lgorrie 1.103
878     (defun byte-function-location (fn)
879     "Return the location of the byte-compiled function FN."
880     (etypecase fn
881     ((or c::hairy-byte-function c::simple-byte-function)
882     (let* ((component (c::byte-function-component fn))
883     (debug-info (kernel:%code-debug-info component)))
884     (debug-info-function-name-location debug-info)))
885     (c::byte-closure
886     (byte-function-location (c::byte-closure-function fn)))))
887    
888     ;;; Here we deal with structure accessors. Note that `dd' is a
889     ;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a
890     ;;; `defstruct''d structure.
891 heller 1.83
892 heller 1.4 (defun struct-closure-p (function)
893 lgorrie 1.103 "Is FUNCTION a closure created by defstruct?"
894 heller 1.4 (or (function-code-object= function #'kernel::structure-slot-accessor)
895     (function-code-object= function #'kernel::structure-slot-setter)
896     (function-code-object= function #'kernel::%defstruct)))
897 dbarlow 1.1
898 lgorrie 1.103 (defun struct-closure-location (function)
899     "Return the location of the structure that FUNCTION belongs to."
900     (assert (struct-closure-p function))
901     (safe-definition-finding
902     (dd-location (struct-closure-dd function))))
903    
904 heller 1.4 (defun struct-closure-dd (function)
905 lgorrie 1.103 "Return the defstruct-definition (dd) of FUNCTION."
906 dbarlow 1.1 (assert (= (kernel:get-type function) vm:closure-header-type))
907 heller 1.4 (flet ((find-layout (function)
908     (sys:find-if-in-closure
909     (lambda (x)
910 heller 1.18 (let ((value (if (di::indirect-value-cell-p x)
911     (c:value-cell-ref x)
912     x)))
913     (when (kernel::layout-p value)
914     (return-from find-layout value))))
915 heller 1.4 function)))
916     (kernel:layout-info (find-layout function))))
917 lgorrie 1.103
918 heller 1.86 (defun dd-location (dd)
919 lgorrie 1.103 "Return the location of a `defstruct'."
920     ;; Find the location in a constructor.
921     (function-location (struct-constructor dd)))
922    
923     (defun struct-constructor (dd)
924     "Return a constructor function from a defstruct definition.
925     Signal an error if no constructor can be found."
926 dbarlow 1.1 (let ((constructor (or (kernel:dd-default-constructor dd)
927 heller 1.32 (car (kernel::dd-constructors dd)))))
928 lgorrie 1.103 (when (or (null constructor)
929     (and (consp constructor) (null (car constructor))))
930     (error "Cannot find structure's constructor: ~S"
931 heller 1.32 (kernel::dd-name dd)))
932 lgorrie 1.103 (coerce (if (consp constructor) (first constructor) constructor)
933     'function)))
934    
935     ;;;;;; Generic functions and methods
936 dbarlow 1.1
937 lgorrie 1.103 (defun generic-function-definitions (name function)
938     "Return the definitions of a generic function and its methods."
939     (cons (list `(defgeneric ,name) (gf-location function))
940     (gf-method-definitions function)))
941    
942     (defun gf-location (gf)
943     "Return the location of the generic function GF."
944     (definition-source-location gf (pcl::generic-function-name gf)))
945 heller 1.101
946 lgorrie 1.103 (defun gf-method-definitions (gf)
947     "Return the locations of all methods of the generic function GF."
948     (mapcar #'method-definition (pcl::generic-function-methods gf)))
949 heller 1.83
950 lgorrie 1.103 (defun method-definition (method)
951     (list (method-dspec method)
952     (method-location method)))
953 heller 1.83
954     (defun method-dspec (method)
955 lgorrie 1.103 "Return a human-readable \"definition specifier\" for METHOD."
956 heller 1.83 (let* ((gf (pcl:method-generic-function method))
957     (name (pcl:generic-function-name gf))
958 heller 1.92 (specializers (pcl:method-specializers method))
959     (qualifiers (pcl:method-qualifiers method)))
960     `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
961 heller 1.83
962 lgorrie 1.103 ;; XXX maybe special case setters/getters
963     (defun method-location (method)
964     (function-location (or (pcl::method-fast-function method)
965     (pcl:method-function method))))
966 heller 1.83
967 lgorrie 1.103 (defun genericp (fn)
968     (typep fn 'generic-function))
969 dbarlow 1.1
970 lgorrie 1.105 ;;;;;; Types and classes
971    
972     (defun type-definitions (name)
973     "Return `deftype' locations for type NAME."
974     (maybe-make-definition (ext:info :type :expander name) 'deftype name))
975    
976 heller 1.88 (defun maybe-make-definition (function kind name)
977 lgorrie 1.105 "If FUNCTION is non-nil then return its definition location."
978 heller 1.87 (if function
979 heller 1.88 (list (list `(,kind ,name) (function-location function)))))
980 heller 1.87
981 lgorrie 1.105 (defun class-definitions (name)
982     "Return the definition locations for the class called NAME."
983     (if (symbolp name)
984     (let ((class (kernel::find-class name nil)))
985     (etypecase class
986     (null '())
987     (kernel::structure-class
988     (list (list `(defstruct ,name) (dd-location (find-dd name)))))
989     #+(or)
990     (conditions::condition-class
991     (list (list `(define-condition ,name)
992     (condition-class-location class))))
993     (kernel::standard-class
994     (list (list `(defclass ,name)
995     (class-location (find-class name)))))
996     ((or kernel::built-in-class
997     conditions::condition-class
998     kernel:funcallable-structure-class)
999     (list (list `(kernel::define-type-class ,name)
1000     `(:error
1001     ,(format nil "No source info for ~A" name)))))))))
1002    
1003     (defun class-location (class)
1004     "Return the `defclass' location for CLASS."
1005     (definition-source-location class (pcl:class-name class)))
1006 heller 1.86
1007     (defun find-dd (name)
1008 lgorrie 1.105 "Find the defstruct-definition by the name of its structure-class."
1009 heller 1.86 (let ((layout (ext:info :type :compiler-layout name)))
1010     (if layout
1011     (kernel:layout-info layout))))
1012    
1013 heller 1.92 (defun condition-class-location (class)
1014     (let ((slots (conditions::condition-class-slots class))
1015     (name (conditions::condition-class-name class)))
1016     (cond ((null slots)
1017     `(:error ,(format nil "No location info for condition: ~A" name)))
1018     (t
1019 lgorrie 1.105 ;; Find the class via one of its slot-reader methods.
1020 heller 1.92 (let* ((slot (first slots))
1021     (gf (fdefinition
1022     (first (conditions::condition-slot-readers slot)))))
1023     (method-location
1024     (first
1025     (pcl:compute-applicable-methods-using-classes
1026     gf (list (find-class name))))))))))
1027    
1028 heller 1.93 (defun make-name-in-file-location (file string)
1029     (multiple-value-bind (filename c)
1030     (ignore-errors
1031     (unix-truename (merge-pathnames (make-pathname :type "lisp")
1032     file)))
1033     (cond (filename (make-location `(:file ,filename)
1034 heller 1.119 `(:function-name ,(string string))))
1035 heller 1.93 (t (list :error (princ-to-string c))))))
1036 heller 1.92
1037 heller 1.95 (defun source-location-form-numbers (location)
1038     (c::decode-form-numbers (c::form-numbers-form-numbers location)))
1039    
1040     (defun source-location-tlf-number (location)
1041     (nth-value 0 (source-location-form-numbers location)))
1042    
1043     (defun source-location-form-number (location)
1044     (nth-value 1 (source-location-form-numbers location)))
1045    
1046 heller 1.93 (defun resolve-file-source-location (location)
1047     (let ((filename (c::file-source-location-pathname location))
1048 heller 1.95 (tlf-number (source-location-tlf-number location))
1049     (form-number (source-location-form-number location)))
1050 heller 1.93 (with-open-file (s filename)
1051     (let ((pos (form-number-stream-position tlf-number form-number s)))
1052     (make-location `(:file ,(unix-truename filename))
1053     `(:position ,(1+ pos)))))))
1054    
1055 heller 1.95 (defun resolve-stream-source-location (location)
1056     (let ((info (c::stream-source-location-user-info location))
1057     (tlf-number (source-location-tlf-number location))
1058     (form-number (source-location-form-number location)))
1059 heller 1.93 ;; XXX duplication in frame-source-location
1060     (assert (info-from-emacs-buffer-p info))
1061     (destructuring-bind (&key emacs-buffer emacs-buffer-string
1062     emacs-buffer-offset) info
1063     (with-input-from-string (s emacs-buffer-string)
1064     (let ((pos (form-number-stream-position tlf-number form-number s)))
1065     (make-location `(:buffer ,emacs-buffer)
1066     `(:position ,(+ emacs-buffer-offset pos))))))))
1067    
1068 heller 1.102 ;; XXX predicates for 18e backward compatibilty. Remove them when
1069     ;; we're 19a only.
1070 heller 1.96 (defun file-source-location-p (object)
1071     (when (fboundp 'c::file-source-location-p)
1072     (c::file-source-location-p object)))
1073    
1074     (defun stream-source-location-p (object)
1075     (when (fboundp 'c::stream-source-location-p)
1076     (c::stream-source-location-p object)))
1077    
1078 heller 1.102 (defun source-location-p (object)
1079     (or (file-source-location-p object)
1080     (stream-source-location-p object)))
1081    
1082     (defun resolve-source-location (location)
1083     (etypecase location
1084     ((satisfies file-source-location-p)
1085     (resolve-file-source-location location))
1086     ((satisfies stream-source-location-p)
1087     (resolve-stream-source-location location))))
1088    
1089 heller 1.93 (defun definition-source-location (object name)
1090     (let ((source (pcl::definition-source object)))
1091     (etypecase source
1092     (null
1093     `(:error ,(format nil "No source info for: ~A" object)))
1094 heller 1.102 ((satisfies source-location-p)
1095     (resolve-source-location source))
1096 heller 1.93 (pathname
1097     (make-name-in-file-location source name))
1098     (cons
1099     (destructuring-bind ((dg name) pathname) source
1100     (declare (ignore dg))
1101     (etypecase pathname
1102     (pathname (make-name-in-file-location pathname (string name)))
1103     (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
1104 heller 1.86
1105 heller 1.88 (defun setf-definitions (name)
1106     (let ((function (or (ext:info :setf :inverse name)
1107     (ext:info :setf :expander name))))
1108 heller 1.87 (if function
1109 heller 1.88 (list (list `(setf ,name)
1110 heller 1.87 (function-location (coerce function 'function)))))))
1111    
1112 heller 1.102
1113     (defun variable-location (symbol)
1114     (multiple-value-bind (location foundp)
1115     ;; XXX for 18e compatibilty. rewrite this when we drop 18e
1116     ;; support.
1117     (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
1118     (if (and foundp location)
1119     (resolve-source-location location)
1120     `(:error ,(format nil "No source info for variable ~S" symbol)))))
1121    
1122     (defun variable-definitions (name)
1123     (if (symbolp name)
1124     (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
1125     (if recorded-p
1126     (list (list `(variable ,kind ,name)
1127     (variable-location name)))))))
1128    
1129 heller 1.87 (defun compiler-macro-definitions (symbol)
1130     (maybe-make-definition (compiler-macro-function symbol)
1131     'define-compiler-macro
1132     symbol))
1133    
1134 heller 1.88 (defun source-transform-definitions (name)
1135     (maybe-make-definition (ext:info :function :source-transform name)
1136 heller 1.87 'c:def-source-transform
1137 heller 1.88 name))
1138 heller 1.87
1139 heller 1.88 (defun function-info-definitions (name)
1140     (let ((info (ext:info :function :info name)))
1141 heller 1.87 (if info
1142     (append (loop for transform in (c::function-info-transforms info)
1143 heller 1.88 collect (list `(c:deftransform ,name
1144 heller 1.87 ,(c::type-specifier
1145     (c::transform-type transform)))
1146     (function-location (c::transform-function
1147     transform))))
1148     (maybe-make-definition (c::function-info-derive-type info)
1149 heller 1.88 'c::derive-type name)
1150 heller 1.87 (maybe-make-definition (c::function-info-optimizer info)
1151 heller 1.88 'c::optimizer name)
1152 heller 1.87 (maybe-make-definition (c::function-info-ltn-annotate info)
1153 heller 1.88 'c::ltn-annotate name)
1154 heller 1.87 (maybe-make-definition (c::function-info-ir2-convert info)
1155 heller 1.88 'c::ir2-convert name)
1156 heller 1.87 (loop for template in (c::function-info-templates info)
1157     collect (list `(c::vop ,(c::template-name template))
1158     (function-location
1159     (c::vop-info-generator-function
1160     template))))))))
1161    
1162 heller 1.88 (defun ir1-translator-definitions (name)
1163     (maybe-make-definition (ext:info :function :ir1-convert name)
1164     'c:def-ir1-translator name))
1165    
1166 lgorrie 1.25
1167     ;;;; Documentation.
1168 dbarlow 1.1
1169 lgorrie 1.56 (defimplementation describe-symbol-for-emacs (symbol)
1170 dbarlow 1.1 (let ((result '()))
1171 lgorrie 1.24 (flet ((doc (kind)
1172     (or (documentation symbol kind) :not-documented))
1173     (maybe-push (property value)
1174     (when value
1175     (setf result (list* property value result)))))
1176 dbarlow 1.1 (maybe-push
1177     :variable (multiple-value-bind (kind recorded-p)
1178     (ext:info variable kind symbol)
1179     (declare (ignore kind))
1180     (if (or (boundp symbol) recorded-p)
1181     (doc 'variable))))
1182 heller 1.148 (when (fboundp symbol)
1183     (maybe-push
1184     (cond ((macro-function symbol) :macro)
1185     ((special-operator-p symbol) :special-operator)
1186     ((genericp (fdefinition symbol)) :generic-function)
1187     (t :function))
1188     (doc 'function)))
1189 dbarlow 1.1 (maybe-push
1190     :setf (if (or (ext:info setf inverse symbol)
1191     (ext:info setf expander symbol))
1192     (doc 'setf)))
1193     (maybe-push
1194     :type (if (ext:info type kind symbol)
1195     (doc 'type)))
1196     (maybe-push
1197     :class (if (find-class symbol nil)
1198     (doc 'class)))
1199 heller 1.18 (maybe-push
1200     :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
1201     (doc 'alien-type)))
1202     (maybe-push
1203     :alien-struct (if (ext:info alien-type struct symbol)
1204     (doc nil)))
1205     (maybe-push
1206     :alien-union (if (ext:info alien-type union symbol)
1207     (doc nil)))
1208     (maybe-push
1209     :alien-enum (if (ext:info alien-type enum symbol)
1210     (doc nil)))
1211 lgorrie 1.24 result)))
1212 dbarlow 1.1
1213 heller 1.80 (defimplementation describe-definition (symbol namespace)
1214 lgorrie 1.103 (describe (ecase namespace
1215     (:variable
1216     symbol)
1217     ((:function :generic-function)
1218     (symbol-function symbol))
1219     (:setf
1220     (or (ext:info setf inverse symbol)
1221     (ext:info setf expander symbol)))
1222     (:type
1223     (kernel:values-specifier-type symbol))
1224     (:class
1225     (find-class symbol))
1226     (:alien-struct
1227     (ext:info :alien-type :struct symbol))
1228     (:alien-union
1229     (ext:info :alien-type :union symbol))
1230     (:alien-enum
1231     (ext:info :alien-type :enum symbol))
1232     (:alien-type
1233     (ecase (ext:info :alien-type :kind symbol)
1234     (:primitive
1235     (let ((alien::*values-type-okay* t))
1236 heller 1.80 (funcall (ext:info :alien-type :translator symbol)
1237 lgorrie 1.103 (list symbol))))
1238     ((:defined)
1239     (ext:info :alien-type :definition symbol))
1240     (:unknown
1241     (return-from describe-definition
1242     (format nil "Unknown alien type: ~S" symbol))))))))
1243    
1244     ;;;;; Argument lists
1245    
1246 mbaringer 1.115 (defimplementation arglist ((name symbol))
1247 heller 1.120 (arglist (or (macro-function name)
1248 heller 1.119 (symbol-function name))))
1249 mbaringer 1.115
1250     (defimplementation arglist ((fun function))
1251 heller 1.140 (function-arglist fun))
1252    
1253     (defun function-arglist (fun)
1254 mbaringer 1.115 (let ((arglist
1255     (cond ((eval:interpreted-function-p fun)
1256     (eval:interpreted-function-arglist fun))
1257     ((pcl::generic-function-p fun)
1258     (pcl:generic-function-lambda-list fun))
1259     ((c::byte-function-or-closure-p fun)
1260     (byte-code-function-arglist fun))
1261     ((kernel:%function-arglist (kernel:%function-self fun))
1262     (handler-case (read-arglist fun)
1263     (error () :not-available)))
1264     ;; this should work both for compiled-debug-function
1265     ;; and for interpreted-debug-function
1266     (t
1267     (handler-case (debug-function-arglist
1268     (di::function-debug-function fun))
1269     (di:unhandled-condition () :not-available))))))
1270 lgorrie 1.103 (check-type arglist (or list (member :not-available)))
1271     arglist))
1272 mbaringer 1.115
1273     (defimplementation function-name (function)
1274     (cond ((eval:interpreted-function-p function)
1275     (eval:interpreted-function-name function))
1276     ((pcl::generic-function-p function)
1277     (pcl::generic-function-name function))
1278     ((c::byte-function-or-closure-p function)
1279     (c::byte-function-name function))
1280     (t (kernel:%function-name (kernel:%function-self function)))))
1281 heller 1.18
1282 lgorrie 1.103 ;;; A simple case: the arglist is available as a string that we can
1283     ;;; `read'.
1284    
1285     (defun read-arglist (fn)
1286     "Parse the arglist-string of the function object FN."
1287     (let ((string (kernel:%function-arglist
1288     (kernel:%function-self fn)))
1289     (package (find-package
1290     (c::compiled-debug-info-package
1291     (kernel:%code-debug-info
1292     (vm::find-code-object fn))))))
1293     (with-standard-io-syntax
1294     (let ((*package* (or package *package*)))
1295     (read-from-string string)))))
1296    
1297     ;;; A harder case: an approximate arglist is derived from available
1298     ;;; debugging information.
1299 heller 1.93
1300 heller 1.92 (defun debug-function-arglist (debug-function)
1301 lgorrie 1.103 "Derive the argument list of DEBUG-FUNCTION from debug info."
1302 heller 1.92 (let ((args (di::debug-function-lambda-list debug-function))
1303     (required '())
1304     (optional '())
1305     (rest '())
1306     (key '()))
1307     ;; collect the names of debug-vars
1308 heller 1.91 (dolist (arg args)
1309     (etypecase arg
1310     (di::debug-variable
1311 heller 1.93 (push (di::debug-variable-symbol arg) required))
1312 lgorrie 1.103 ((member :deleted)
1313 heller 1.93 (push ':deleted required))
1314 heller 1.91 (cons
1315     (ecase (car arg)
1316 heller 1.92 (:keyword
1317     (push (second arg) key))
1318     (:optional
1319 heller 1.93 (push (debug-variable-symbol-or-deleted (second arg)) optional))
1320 heller 1.92 (:rest
1321 heller 1.93 (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
1322 heller 1.92 ;; intersperse lambda keywords as needed
1323     (append (nreverse required)
1324     (if optional (cons '&optional (nreverse optional)))
1325     (if rest (cons '&rest (nreverse rest)))
1326     (if key (cons '&key (nreverse key))))))
1327    
1328 lgorrie 1.103 (defun debug-variable-symbol-or-deleted (var)
1329     (etypecase var
1330     (di:debug-variable
1331     (di::debug-variable-symbol var))
1332     ((member :deleted)
1333     '#:deleted)))
1334    
1335 heller 1.92 (defun symbol-debug-function-arglist (fname)
1336     "Return FNAME's debug-function-arglist and %function-arglist.
1337     A utility for debugging DEBUG-FUNCTION-ARGLIST."
1338     (let ((fn (fdefinition fname)))
1339     (values (debug-function-arglist (di::function-debug-function fn))
1340     (kernel:%function-arglist (kernel:%function-self fn)))))
1341 heller 1.91
1342 lgorrie 1.103 ;;; Deriving arglists for byte-compiled functions:
1343     ;;;
1344     (defun byte-code-function-arglist (fn)
1345     ;; There doesn't seem to be much arglist information around for
1346     ;; byte-code functions. Use the arg-count and return something like
1347     ;; (arg0 arg1 ...)
1348     (etypecase fn
1349     (c::simple-byte-function
1350     (loop for i from 0 below (c::simple-byte-function-num-args fn)
1351     collect (make-arg-symbol i)))
1352     (c::hairy-byte-function
1353     (hairy-byte-function-arglist fn))
1354     (c::byte-closure
1355     (byte-code-function-arglist (c::byte-closure-function fn)))))
1356 heller 1.97
1357 heller 1.101 (defun make-arg-symbol (i)
1358     (make-symbol (format nil "~A~D" (string 'arg) i)))
1359    
1360 lgorrie 1.103 ;;; A "hairy" byte-function is one that takes a variable number of
1361     ;;; arguments. `hairy-byte-function' is a type from the bytecode
1362     ;;; interpreter.
1363     ;;;
1364 heller 1.101 (defun hairy-byte-function-arglist (fn)
1365     (let ((counter -1))
1366     (flet ((next-arg () (make-arg-symbol (incf counter))))
1367     (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
1368     keywords-p keywords) fn
1369     (let ((arglist '())
1370     (optional (- max-args min-args)))
1371     ;; XXX isn't there a better way to write this?
1372 lgorrie 1.103 ;; (Looks fine to me. -luke)
1373 heller 1.101 (dotimes (i min-args)
1374     (push (next-arg) arglist))
1375     (when (plusp optional)
1376     (push '&optional arglist)
1377     (dotimes (i optional)
1378     (push (next-arg) arglist)))
1379     (when rest-arg-p
1380     (push '&rest arglist)
1381     (push (next-arg) arglist))
1382     (when keywords-p
1383     (push '&key arglist)
1384     (loop for (key _ __) in keywords
1385     do (push key arglist))
1386     (when (eq keywords-p :allow-others)
1387     (push '&allow-other-keys arglist)))
1388     (nreverse arglist))))))
1389 lgorrie 1.25
1390    
1391     ;;;; Miscellaneous.
1392 dbarlow 1.1
1393 lgorrie 1.56 (defimplementation macroexpand-all (form)
1394 lgorrie 1.24 (walker:macroexpand-all form))
1395 dbarlow 1.1
1396 mbaringer 1.90 (defimplementation set-default-directory (directory)
1397 lgorrie 1.25 (setf (ext:default-directory) (namestring directory))
1398     ;; Setting *default-pathname-defaults* to an absolute directory
1399     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
1400     (setf *default-pathname-defaults* (pathname (ext:default-directory)))
1401 heller 1.107 (default-directory))
1402    
1403     (defimplementation default-directory ()
1404 lgorrie 1.25 (namestring (ext:default-directory)))
1405    
1406 lgorrie 1.103 (defimplementation call-without-interrupts (fn)
1407     (sys:without-interrupts (funcall fn)))
1408 heller 1.19
1409 lgorrie 1.103 (defimplementation getpid ()
1410     (unix:unix-getpid))
1411 lgorrie 1.99
1412 lgorrie 1.103 (defimplementation lisp-implementation-type-name ()
1413     "cmucl")
1414 heller 1.92
1415 lgorrie 1.103 (defimplementation quit-lisp ()
1416     (ext::quit))
1417 heller 1.19
1418 lgorrie 1.103 ;;; source-path-{stream,file,string,etc}-position moved into
1419     ;;; swank-source-path-parser
1420 dbarlow 1.1
1421    
1422 lgorrie 1.25 ;;;; Debugging
1423 dbarlow 1.1
1424     (defvar *sldb-stack-top*)
1425    
1426 lgorrie 1.56 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1427 dbarlow 1.1 (unix:unix-sigsetmask 0)
1428 lgorrie 1.25 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
1429 heller 1.142 (debug:*stack-top-hint* nil)
1430     (kernel:*current-level* 0))
1431 heller 1.112 (handler-bind ((di::unhandled-condition
1432 dbarlow 1.1 (lambda (condition)
1433 heller 1.112 (error (make-condition
1434     'sldb-condition
1435     :original-condition condition)))))
1436 lgorrie 1.25 (funcall debugger-loop-fn))))
1437 dbarlow 1.1
1438 heller 1.112 (defun frame-down (frame)
1439     (handler-case (di:frame-down frame)
1440     (di:no-debug-info () nil)))
1441    
1442 dbarlow 1.1 (defun nth-frame (index)
1443 heller 1.112 (do ((frame *sldb-stack-top* (frame-down frame))
1444 dbarlow 1.1 (i index (1- i)))
1445     ((zerop i) frame)))
1446    
1447 heller 1.80 (defimplementation compute-backtrace (start end)
1448 dbarlow 1.1 (let ((end (or end most-positive-fixnum)))
1449 heller 1.112 (loop for f = (nth-frame start) then (frame-down f)
1450 dbarlow 1.1 for i from start below end
1451     while f
1452 heller 1.80 collect f)))
1453 dbarlow 1.1
1454 heller 1.80 (defimplementation print-frame (frame stream)
1455     (let ((*standard-output* stream))
1456 heller 1.114 (handler-case
1457     (debug::print-frame-call frame :verbosity 1 :number nil)
1458     (error (e)
1459     (ignore-errors (princ e stream))))))
1460 dbarlow 1.1
1461 lgorrie 1.56 (defimplementation frame-source-location-for-emacs (index)
1462 heller 1.29 (code-location-source-location (di:frame-code-location (nth-frame index))))
1463 dbarlow 1.1
1464 lgorrie 1.56 (defimplementation eval-in-frame (form index)
1465 lgorrie 1.26 (di:eval-in-frame (nth-frame index) form))
1466 heller 1.19
1467 heller 1.108 (defun frame-debug-vars (frame)
1468     "Return a vector of debug-variables in frame."
1469     (di::debug-function-debug-variables (di:frame-debug-function frame)))
1470    
1471     (defun debug-var-value (var frame location)
1472 heller 1.130 (let ((validity (di:debug-variable-validity var location)))
1473     (ecase validity
1474     (:valid (di:debug-variable-value var frame))
1475     ((:invalid :unknown) (make-symbol (string validity))))))
1476 heller 1.108
1477 lgorrie 1.56 (defimplementation frame-locals (index)
1478 dbarlow 1.1 (let* ((frame (nth-frame index))
1479 heller 1.108 (loc (di:frame-code-location frame))
1480     (vars (frame-debug-vars frame)))
1481     (loop for v across vars collect
1482 heller 1.80 (list :name (di:debug-variable-symbol v)
1483 heller 1.43 :id (di:debug-variable-id v)
1484 heller 1.108 :value (debug-var-value v frame loc)))))
1485    
1486     (defimplementation frame-var-value (frame var)
1487     (let* ((frame (nth-frame frame))
1488     (dvar (aref (frame-debug-vars frame) var)))
1489     (debug-var-value dvar frame (di:frame-code-location frame))))
1490 dbarlow 1.1
1491 lgorrie 1.56 (defimplementation frame-catch-tags (index)
1492 heller 1.80 (mapcar #'car (di:frame-catches (nth-frame index))))
1493 heller 1.33
1494 heller 1.123 (defimplementation return-from-frame (index form)
1495     (let ((sym (find-symbol (string 'find-debug-tag-for-frame)
1496     :debug-internals)))
1497     (if sym
1498     (let* ((frame (nth-frame index))
1499     (probe (funcall sym frame)))
1500     (cond (probe (throw (car probe) (eval-in-frame form index)))
1501     (t (format nil "Cannot return from frame: ~S" frame))))
1502     "return-from-frame is not implemented in this version of CMUCL.")))
1503    
1504 heller 1.126 (defimplementation activate-stepping (frame)
1505     (set-step-breakpoints (nth-frame frame)))
1506 heller 1.119
1507     (defimplementation sldb-break-on-return (frame)
1508     (break-on-return (nth-frame frame)))
1509    
1510 heller 1.133 ;;; We set the breakpoint in the caller which might be a bit confusing.
1511 heller 1.119 ;;;
1512     (defun break-on-return (frame)
1513     (let* ((caller (di:frame-down frame))
1514     (cl (di:frame-code-location caller)))
1515     (flet ((hook (frame bp)
1516     (when (frame-pointer= frame caller)
1517     (di:delete-breakpoint bp)
1518     (signal-breakpoint bp frame))))
1519     (let* ((info (ecase (di:code-location-kind cl)
1520     ((:single-value-return :unknown-return) nil)
1521     (:known-return (debug-function-returns
1522     (di:frame-debug-function frame)))))
1523     (bp (di:make-breakpoint #'hook cl :kind :code-location
1524     :info info)))
1525     (di:activate-breakpoint bp)
1526     `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
1527    
1528     (defun frame-pointer= (frame1 frame2)
1529     "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
1530     (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
1531    
1532 heller 1.126 ;;; The PC in escaped frames at a single-return-value point is
1533     ;;; actually vm:single-value-return-byte-offset bytes after the
1534     ;;; position given in the debug info. Here we try to recognize such
1535     ;;; cases.
1536     ;;;
1537     (defun next-code-locations (frame code-location)
1538     "Like `debug::next-code-locations' but be careful in escaped frames."
1539     (let ((next (debug::next-code-locations code-location)))
1540     (flet ((adjust-pc ()
1541     (let ((cl (di::copy-compiled-code-location code-location)))
1542     (incf (di::compiled-code-location-pc cl)
1543     vm:single-value-return-byte-offset)
1544     cl)))
1545     (cond ((and (di::compiled-frame-escaped frame)
1546     (eq (di:code-location-kind code-location)
1547     :single-value-return)
1548     (= (length next) 1)
1549     (di:code-location= (car next) (adjust-pc)))
1550     (debug::next-code-locations (car next)))
1551     (t
1552     next)))))
1553    
1554 heller 1.119 (defun set-step-breakpoints (frame)
1555     (let ((cl (di:frame-code-location frame)))
1556     (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
1557     (error "Cannot step in elsewhere code"))
1558 heller 1.126 (let* ((debug::*bad-code-location-types*
1559 heller 1.119 (remove :call-site debug::*bad-code-location-types*))
1560 heller 1.126 (next (next-code-locations frame cl)))
1561 heller 1.119 (cond (next
1562     (let ((steppoints '()))
1563     (flet ((hook (bp-frame bp)
1564 heller 1.126 (signal-breakpoint bp bp-frame)
1565     (mapc #'di:delete-breakpoint steppoints)))
1566 heller 1.119 (dolist (code-location next)
1567     (let ((bp (di:make-breakpoint #'hook code-location
1568     :kind :code-location)))
1569     (di:activate-breakpoint bp)
1570     (push bp steppoints))))))
1571     (t
1572     (break-on-return frame))))))
1573    
1574    
1575     ;; XXX the return values at return breakpoints should be passed to the
1576     ;; user hooks. debug-int.lisp should be changed to do this cleanly.
1577    
1578     ;;; The sigcontext and the PC for a breakpoint invocation are not
1579     ;;; passed to user hook functions, but we need them to extract return
1580     ;;; values. So we advice di::handle-breakpoint and bind the values to
1581     ;;; special variables.
1582     ;;;
1583     (defvar *breakpoint-sigcontext*)
1584     (defvar *breakpoint-pc*)
1585    
1586     ;; XXX don't break old versions without fwrappers. Remove this one day.
1587     #+#.(cl:if (cl:find-package :fwrappers) '(and) '(or))
1588     (progn
1589     (fwrappers:define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext)
1590     (let ((*breakpoint-sigcontext* sigcontext)
1591     (*breakpoint-pc* offset))
1592     (fwrappers:call-next-function)))
1593     (fwrappers:set-fwrappers 'di::handle-breakpoint '())
1594     (fwrappers:fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext))
1595    
1596     (defun sigcontext-object (sc index)
1597     "Extract the lisp object in sigcontext SC at offset INDEX."
1598     (kernel:make-lisp-obj (vm:sigcontext-register sc index)))
1599    
1600     (defun known-return-point-values (sigcontext sc-offsets)
1601     (let ((fp (system:int-sap (vm:sigcontext-register sigcontext
1602     vm::cfp-offset))))
1603     (system:without-gcing
1604     (loop for sc-offset across sc-offsets
1605     collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
1606    
1607     ;;; CMUCL returns the first few values in registers and the rest on
1608     ;;; the stack. In the multiple value case, the number of values is
1609     ;;; stored in a dedicated register. The values of the registers can be
1610     ;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
1611     ;;; of return conventions: :single-value-return, :unknown-return, and
1612     ;;; :known-return.
1613     ;;;
1614     ;;; The :single-value-return convention returns the value in a
1615     ;;; register without setting the nargs registers.
1616     ;;;
1617     ;;; The :unknown-return variant is used for multiple values. A
1618     ;;; :unknown-return point consists actually of 2 breakpoints: one for
1619     ;;; the single value case and one for the general case. The single
1620     ;;; value breakpoint comes vm:single-value-return-byte-offset after
1621     ;;; the multiple value breakpoint.
1622     ;;;
1623     ;;; The :known-return convention is used by local functions.
1624     ;;; :known-return is currently not supported because we don't know
1625     ;;; where the values are passed.
1626     ;;;
1627     (defun breakpoint-values (breakpoint)
1628     "Return the list of return values for a return point."
1629     (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
1630     (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
1631     (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext))))
1632     (cl (di:breakpoint-what breakpoint)))
1633     (ecase (di:code-location-kind cl)
1634     (:single-value-return
1635     (list (1st sc)))
1636     (:known-return
1637     (let ((info (di:breakpoint-info breakpoint)))
1638     (if (vectorp info)
1639     (known-return-point-values sc info)
1640 heller 1.142 (progn
1641     ;;(break)
1642     (list "<<known-return convention not supported>>" info)))))
1643 heller 1.119 (:unknown-return
1644     (let ((mv-return-pc (di::compiled-code-location-pc cl)))
1645     (if (= mv-return-pc *breakpoint-pc*)
1646 heller 1.143 (mv-function-end-breakpoint-values sc)
1647 heller 1.119 (list (1st sc)))))))))
1648 heller 1.143
1649     ;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in
1650     ;; newer versions of CMUCL (after ~March 2005).
1651     (defun mv-function-end-breakpoint-values (sigcontext)
1652     (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di)))
1653     (cond (sym (funcall sym sigcontext))
1654     (t (di::get-function-end-breakpoint-values sigcontext)))))
1655 heller 1.119
1656     (defun debug-function-returns (debug-fun)
1657     "Return the return style of DEBUG-FUN."
1658     (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
1659     (c::compiled-debug-function-returns cdfun)))
1660    
1661     (define-condition breakpoint (simple-condition)
1662 heller 1.137 ((message :initarg :message :reader breakpoint.message)
1663     (values :initarg :values :reader breakpoint.values))
1664 heller 1.119 (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
1665    
1666     (defimplementation condition-extras ((c breakpoint))
1667     ;; simply pop up the source buffer
1668     `((:short-frame-source 0)))
1669    
1670     (defun signal-breakpoint (breakpoint frame)
1671     "Signal a breakpoint condition for BREAKPOINT in FRAME.
1672     Try to create a informative message."
1673 heller 1.137 (flet ((brk (values fstring &rest args)
1674 heller 1.119 (let ((msg (apply #'format nil fstring args))
1675     (debug:*stack-top-hint* frame))
1676 heller 1.137 (break 'breakpoint :message msg :values values))))
1677     (with-struct (di::breakpoint- kind what) breakpoint
1678     (case kind
1679     (:code-location
1680     (case (di:code-location-kind what)
1681     ((:single-value-return :known-return :unknown-return)
1682     (let ((values (breakpoint-values breakpoint)))
1683     (brk values "Return value: ~{~S ~}" values)))
1684     (t
1685 heller 1.140 #+(or)
1686     (when (eq (di:code-location-kind what) :call-site)
1687     (call-site-function breakpoint frame))
1688 heller 1.137 (brk nil "Breakpoint: ~S ~S"
1689     (di:code-location-kind what)
1690     (di::compiled-code-location-pc what)))))
1691     (:function-start
1692     (brk nil "Function start breakpoint"))
1693     (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
1694 heller 1.119
1695     (defimplementation sldb-break-at-start (fname)
1696     (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
1697     (cond ((not debug-fun)
1698     `(:error ,(format nil "~S has no debug-function" fname)))
1699     (t
1700     (flet ((hook (frame bp &optional args cookie)
1701     (declare (ignore args cookie))
1702     (signal-breakpoint bp frame)))
1703     (let ((bp (di:make-breakpoint #'hook debug-fun
1704     :kind :function-start)))
1705     (di:activate-breakpoint bp)
1706     `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
1707 dbarlow 1.1
1708 heller 1.58 (defun frame-cfp (frame)
1709     "Return the Control-Stack-Frame-Pointer for FRAME."
1710     (etypecase frame
1711     (di::compiled-frame (di::frame-pointer frame))
1712     ((or di::interpreted-frame null) -1)))
1713    
1714     (defun frame-ip (frame)
1715     "Return the (absolute) instruction pointer and the relative pc of FRAME."
1716     (if (not frame)
1717     -1
1718     (let ((debug-fun (di::frame-debug-function frame)))
1719     (etypecase debug-fun
1720     (di::compiled-debug-function
1721     (let* ((code-loc (di:frame-code-location frame))
1722     (component (di::compiled-debug-function-component debug-fun))
1723     (pc (di::compiled-code-location-pc code-loc))
1724     (ip (sys:without-gcing
1725     (sys:sap-int
1726     (sys:sap+ (kernel:code-instructions component) pc)))))
1727     (values ip pc)))
1728     ((or di::bogus-debug-function di::interpreted-debug-function)
1729     -1)))))
1730    
1731     (defun frame-registers (frame)
1732     "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1733     (let* ((cfp (frame-cfp frame))
1734     (csp (frame-cfp (di::frame-up frame)))
1735     (ip (frame-ip frame))
1736     (ocfp (frame-cfp (di::frame-down frame)))
1737     (lra (frame-ip (di::frame-down frame))))
1738     (values csp cfp ip ocfp lra)))
1739    
1740     (defun print-frame-registers (frame-number)
1741     (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1742     (flet ((fixnum (p) (etypecase p
1743     (integer p)
1744     (sys:system-area-pointer (sys:sap-int p)))))
1745     (apply #'format t "~
1746     CSP = ~X
1747     CFP = ~X
1748     IP = ~X
1749     OCFP = ~X
1750     LRA = ~X~%" (mapcar #'fixnum
1751     (multiple-value-list (frame-registers frame)))))))
1752    
1753 heller 1.82
1754 heller 1.81 (defimplementation disassemble-frame (frame-number)
1755     "Return a string with the disassembly of frames code."
1756     (print-frame-registers frame-number)
1757     (terpri)
1758     (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1759     (debug-fun (di::frame-debug-function frame)))
1760     (etypecase debug-fun
1761     (di::compiled-debug-function
1762     (let* ((component (di::compiled-debug-function-component debug-fun))
1763     (fun (di:debug-function-function debug-fun)))
1764     (if fun
1765     (disassemble fun)
1766     (disassem:disassemble-code-component component))))
1767     (di::bogus-debug-function
1768     (format t "~%[Disassembling bogus frames not implemented]")))))
1769 heller 1.58
1770 dbarlow 1.1
1771 lgorrie 1.25 ;;;; Inspecting
1772 dbarlow 1.1
1773 mbaringer 1.116 (defclass cmucl-inspector (inspector)
1774     ())
1775    
1776     (defimplementation make-default-inspector ()
1777     (make-instance 'cmucl-inspector))
1778    
1779 dbarlow 1.1 (defconstant +lowtag-symbols+
1780     '(vm:even-fixnum-type
1781     vm:function-pointer-type
1782     vm:other-immediate-0-type
1783     vm:list-pointer-type
1784     vm:odd-fixnum-type
1785     vm:instance-pointer-type
1786     vm:other-immediate-1-type
1787 lgorrie 1.103 vm:other-pointer-type)
1788     "Names of the constants that specify type tags.
1789     The `symbol-value' of each element is a type tag.")
1790 dbarlow 1.1
1791     (defconstant +header-type-symbols+
1792 heller 1.144 (labels ((suffixp (suffix string)
1793     (and (>= (length string) (length suffix))
1794     (string= string suffix :start1 (- (length string)
1795     (length suffix)))))
1796     (header-type-symbol-p (x)
1797     (and (suffixp "-TYPE" (symbol-name x))
1798     (not (member x +lowtag-symbols+))
1799     (boundp x)
1800     (typep (symbol-value x) 'fixnum))))
1801     (remove-if-not #'header-type-symbol-p
1802     (append (apropos-list "-TYPE" "VM")
1803     (apropos-list "-TYPE" "BIGNUM"))))
1804 heller 1.102 "A list of names of the type codes in boxed objects.")
1805 heller 1.62
1806     (defimplementation describe-primitive-type (object)
1807 dbarlow 1.1 (with-output-to-string (*standard-output*)
1808     (let* ((lowtag (kernel:get-lowtag object))
1809     (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1810 heller 1.76 (format t "lowtag: ~A" lowtag-symbol)
1811     (when (member lowtag (list vm:other-pointer-type
1812     vm:function-pointer-type
1813     vm:other-immediate-0-type
1814     vm:other-immediate-1-type
1815     ))
1816     (let* ((type (kernel:get-type object))
1817     (type-symbol (find type +header-type-symbols+
1818     :key #'symbol-value)))
1819     (format t ", type: ~A" type-symbol))))))
1820 dbarlow 1.1
1821 mbaringer 1.116 (defimplementation inspect-for-emacs ((o t) (inspector cmucl-inspector))
1822 dbarlow 1.1 (cond ((di::indirect-value-cell-p o)
1823 heller 1.121 (values (format nil "~A is a value cell." o)
1824 mbaringer 1.116 `("Value: " (:value ,(c:value-cell-ref o)))))
1825 heller 1.130 ((alien::alien-value-p o)
1826     (inspect-alien-value o))
1827 dbarlow 1.1 (t
1828 heller 1.130 (cmucl-inspect o))))
1829    
1830     (defun cmucl-inspect (o)
1831     (destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
1832     (values (format nil "~A~%" text)
1833     (if labeledp
1834     (loop for (label . value) in parts
1835     append (label-value-line label value))
1836     (loop for value in parts for i from 0
1837     append (label-value-line i value))))))
1838 heller 1.55
1839 mbaringer 1.124 (defmethod inspect-for-emacs :around ((o function) (inspector cmucl-inspector))
1840 mbaringer 1.116 (declare (ignore inspector))
1841 heller 1.126 (let ((header (kernel:get-type o)))
1842     (cond ((= header vm:function-header-type)
1843     (values (format nil "~A is a function." o)
1844     (append (label-value-line*
1845     ("Self" (kernel:%function-self o))
1846     ("Next" (kernel:%function-next o))
1847     ("Name" (kernel:%function-name o))
1848     ("Arglist" (kernel:%function-arglist o))
1849     ("Type" (kernel:%function-type o))
1850     ("Code" (kernel:function-code-header o)))
1851     (list
1852     (with-output-to-string (s)
1853     (disassem:disassemble-function o :stream s))))))
1854     ((= header vm:closure-header-type)
1855     (values (format nil "~A is a closure" o)
1856     (append
1857     (label-value-line "Function" (kernel:%closure-function o))
1858     `("Environment:" (:newline))
1859     (loop for i from 0 below (1- (kernel:get-closure-length o))
1860     append (label-value-line
1861     i (kernel:%closure-index-ref o i))))))
1862 heller 1.142 ((eval::interpreted-function-p o)
1863     (cmucl-inspect o))
1864     (t
1865 heller 1.126 (call-next-method)))))
1866    
1867 dbarlow 1.1
1868 heller 1.121 (defmethod inspect-for-emacs ((o kernel:code-component) (_ cmucl-inspector))
1869     (declare (ignore _))
1870     (values (format nil "~A is a code data-block." o)
1871     (append
1872     (label-value-line*
1873     ("code-size" (kernel:%code-code-size o))
1874     ("entry-points" (kernel:%code-entry-points o))
1875     ("debug-info" (kernel:%code-debug-info o))
1876     ("trace-table-offset" (kernel:code-header-ref
1877     o vm:code-trace-table-offset-slot)))
1878     `("Constants:" (:newline))
1879     (loop for i from vm:code-constants-offset
1880     below (kernel:get-header-data o)
1881     append (label-value-line i (kernel:code-header-ref o i)))
1882     `("Code:" (:newline)
1883     , (with-output-to-string (s)
1884 heller 1.123 (cond ((kernel:%code-debug-info o)
1885     (disassem:disassemble-code-component o :stream s))
1886     (t
1887     (disassem:disassemble-memory
1888     (disassem::align
1889     (+ (logandc2 (kernel:get-lisp-obj-address o)
1890     vm:lowtag-mask)
1891     (* vm:code-constants-offset vm:word-bytes))
1892     (ash 1 vm:lowtag-bits))
1893     (ash (kernel:%code-code-size o) vm:word-shift)
1894     :stream s))))))))
1895 mbaringer 1.116
1896     (defmethod inspect-for-emacs ((o kernel:fdefn) (inspector cmucl-inspector))
1897     (declare (ignore inspector))
1898 heller 1.121 (values (format nil "~A is a fdenf object." o)
1899     (label-value-line*
1900     ("name" (kernel:fdefn-name o))
1901     ("function" (kernel:fdefn-function o))
1902     ("raw-addr" (sys:sap-ref-32
1903     (sys:int-sap (kernel:get-lisp-obj-address o))
1904     (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
1905 heller 1.58
1906 heller 1.129 (defmethod inspect-for-emacs ((o array) (inspector cmucl-inspector))
1907     inspector
1908     (values (format nil "~A is an array." o)
1909     (label-value-line*
1910     (:header (describe-primitive-type o))
1911     (:rank (array-rank o))
1912     (:fill-pointer (kernel:%array-fill-pointer o))
1913     (:fill-pointer-p (kernel:%array-fill-pointer-p o))
1914     (:elements (kernel:%array-available-elements o))
1915     (:data (kernel:%array-data-vector o))
1916     (:displacement (kernel:%array-displacement o))
1917     (:displaced-p (kernel:%array-displaced-p o))
1918     (:dimensions (array-dimensions o)))))
1919    
1920     (defmethod inspect-for-emacs ((o vector) (inspector cmucl-inspector))
1921     inspector
1922     (values (format nil "~A is a vector." o)
1923     (append
1924     (label-value-line*
1925     (:header (describe-primitive-type o))
1926     (:length (c::vector-length o)))
1927     (loop for i below (length o)
1928     append (label-value-line i (aref o i))))))
1929    
1930 heller 1.130 (defun inspect-alien-record (alien)
1931     (values
1932     (format nil "~A is an alien value." alien)
1933     (with-struct (alien::alien-value- sap type) alien
1934     (with-struct (alien::alien-record-type- kind name fields) type
1935     (append
1936     (label-value-line*
1937     (:sap sap)
1938     (:kind kind)
1939     (:name name))
1940     (loop for field in fields
1941     append (let ((slot (alien::alien-record-field-name field)))
1942     (label-value-line slot (alien:slot alien slot)))))))))
1943    
1944     (defun inspect-alien-pointer (alien)
1945     (values
1946     (format nil "~A is an alien value." alien)
1947     (with-struct (alien::alien-value- sap type) alien
1948     (label-value-line*
1949     (:sap sap)
1950     (:type type)
1951     (:to (alien::deref alien))))))
1952    
1953     (defun inspect-alien-value (alien)
1954     (typecase (alien::alien-value-type alien)
1955     (alien::alien-record-type (inspect-alien-record alien))
1956     (alien::alien-pointer-type (inspect-alien-pointer alien))
1957     (t (cmucl-inspect alien))))
1958 heller 1.58
1959     ;;;; Profiling
1960     (defimplementation profile (fname)
1961     (eval `(profile:profile ,fname)))
1962    
1963     (defimplementation unprofile (fname)
1964     (eval `(profile:unprofile ,fname)))
1965    
1966     (defimplementation unprofile-all ()
1967 heller 1.126 (eval `(profile:unprofile))
1968 heller 1.58 "All functions unprofiled.")
1969    
1970     (defimplementation profile-report ()
1971 heller 1.126 (eval `(profile:report-time)))
1972 heller 1.58
1973     (defimplementation profile-reset ()
1974 heller 1.126 (eval `(profile:reset-time))
1975 heller 1.58 "Reset profiling counters.")
1976    
1977     (defimplementation profiled-functions ()
1978     profile:*timed-functions*)
1979    
1980     (defimplementation profile-package (package callers methods)
1981 heller 1.80 (profile:profile-all :package package
1982 heller 1.58 :callers-p callers
1983 lgorrie 1.105 #-cmu18e :methods #-cmu18e methods))
1984 dbarlow 1.1
1985 lgorrie 1.42
1986     ;;;; Multiprocessing
1987    
1988 heller 1.91 #+mp
1989 lgorrie 1.42 (progn
1990 lgorrie 1.56 (defimplementation startup-multiprocessing ()
1991 lgorrie 1.49 ;; Threads magic: this never returns! But top-level becomes
1992     ;; available again.
1993 lgorrie 1.42 (mp::startup-idle-and-top-level-loops))
1994 heller 1.54
1995 heller 1.59 (defimplementation spawn (fn &key (name "Anonymous"))
1996 heller 1.54 (mp:make-process fn :name name))
1997 lgorrie 1.42
1998 heller 1.109 (defvar *thread-id-counter* 0)
1999    
2000     (defimplementation thread-id (thread)
2001     (or (getf (mp:process-property-list thread) 'id)
2002     (setf (getf (mp:process-property-list thread) 'id)
2003     (incf *thread-id-counter*))))
2004    
2005     (defimplementation find-thread (id)
2006     (find id (all-threads)
2007     :key (lambda (p) (getf (mp:process-property-list p) 'id))))
2008    
2009 heller 1.61 (defimplementation thread-name (thread)
2010     (mp:process-name thread))
2011 lgorrie 1.42
2012 heller 1.61 (defimplementation thread-status (thread)
2013     (mp:process-whostate thread))
2014 lgorrie 1.42
2015 heller 1.61 (defimplementation current-thread ()
2016     mp:*current-process*)
2017 lgorrie 1.42
2018 heller 1.61 (defimplementation all-threads ()
2019     (copy-list mp:*all-processes*))
2020 heller 1.62
2021     (defimplementation interrupt-thread (thread fn)
2022     (mp:process-interrupt thread fn))
2023    
2024 heller 1.73 (defimplementation kill-thread (thread)
2025     (mp:destroy-process thread))
2026    
2027 heller 1.62 (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
2028    
2029     (defstruct (mailbox (:conc-name mailbox.))
2030     (mutex (mp:make-lock "process mailbox"))
2031     (queue '() :type list))
2032    
2033     (defun mailbox (thread)
2034     "Return THREAD's mailbox."
2035     (mp:with-lock-held (*mailbox-lock*)
2036     (or (getf (mp:process-property-list thread) 'mailbox)
2037     (setf (getf (mp:process-property-list thread) 'mailbox)
2038     (make-mailbox)))))
2039    
2040     (defimplementation send (thread message)
2041     (let* ((mbox (mailbox thread))
2042     (mutex (mailbox.mutex mbox)))
2043     (mp:with-lock-held (mutex)
2044     (setf (mailbox.queue mbox)
2045     (nconc (mailbox.queue mbox) (list message))))))
2046    
2047     (defimplementation receive ()
2048     (let* ((mbox (mailbox mp:*current-process*))
2049     (mutex (mailbox.mutex mbox)))
2050     (mp:process-wait "receive" #'mailbox.queue mbox)
2051     (mp:with-lock-held (mutex)
2052     (pop (mailbox.queue mbox)))))
2053 heller 1.59
2054 lgorrie 1.103 ) ;; #+mp
2055 heller 1.128
2056    
2057    
2058     ;;;; GC hooks
2059     ;;;
2060     ;;; Display GC messages in the echo area to avoid cluttering the
2061     ;;; normal output.
2062     ;;;
2063    
2064 heller 1.133 (defun swank-sym (name) (find-symbol (string name) :swank))
2065     (defun sending-safe-p () (symbol-value (swank-sym :*emacs-connection*)))
2066    
2067 heller 1.128 ;; this should probably not be here, but where else?
2068 mkoeppe 1.152 (defun send-to-emacs (message)
2069     (funcall (swank-sym :send-to-emacs) message))
2070 heller 1.128
2071     (defun print-bytes (nbytes &optional stream)
2072     "Print the number NBYTES to STREAM in KB, MB, or GB units."
2073     (let ((names '((0 bytes) (10 kb) (20 mb) (30 gb) (40 tb) (50 eb))))
2074     (multiple-value-bind (power name)
2075     (loop for ((p1 n1) (p2 n2)) on names
2076     while n2 do
2077     (when (<= (expt 2 p1) nbytes (1- (expt 2 p2)))
2078     (return (values p1 n1))))
2079     (cond (