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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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