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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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