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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.205 - (hide annotations)
Tue Dec 30 18:57:54 2008 UTC (5 years, 3 months ago) by trittweiler
Branch: MAIN
Changes since 1.204: +2 -2 lines
	As of now, `C-u C-c C-c' compiled a function with maximum debug
	settings (SBCL only.)

	Now, `M-- C-c C-c' will compile a function with maximum _speed_
	settings (still SBCL only) --- useful to elicit compiler notes.

	* slime.el (slime-compilation-debug-level): Renamed to
	`slime-compilation-policy'.
	(slime-normalize-optimization-level): Renamed to
	`slime-compute-policy'.

	* swank.lisp (compile-string-for-emacs): Takes a policy now.
	(compile-multiple-strings-for-emacs): Ditto.

	* swank-backend.lisp (swank-compile-string): Change :DEBUG key arg
	to :POLICY.

	* swank-scl.lisp, swank-openmcl.lisp, swank-lispworks.lisp
	* swank-ecl.lisp, swank-corman.lisp, swank-cmucl.lisp,
	* swank-clisp.lisp, swank-allegro.lisp, swank-sbcl.lisp:

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