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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.197 - (show annotations)
Sat Oct 4 19:13:41 2008 UTC (5 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.196: +15 -12 lines
Some cleanups for compilation commands.

* slime.el ([defstruct] slime-compilation-result): Rename result
slot as successp.
(slime-make-compilation-finished-continuation): Deleted.
slime-eval-async preserves the current buffer and preserving the
window-configuration was always a questionable feature.
(slime-compilation-finished): Simplified.
(slime-show-note-counts): Also show the success/failure flag.
(slime-recompile-locations): Take a continuation as argument
rather than messing around with compilation-finished-hooks.
(slime-aggregate-compilation-results): New function.
(slime-xref-recompilation-cont): Renamed from
slime-make-xref-recompilation-cont.
(slime-compiler-results): Deleted.
(slime-goto-first-note-after-compilation): Replaced with hook
function slime-goto-first-note.
(slime-compilation-just-finished): Deleted.
(slime-to-lisp-filename-function): Use convert-standard-filename.
* swank.lisp ([defstruct] compilation-result): Renamed from
swank-compilation-result.
(measure-time-interval): Return seconds as float.
(collect-notes): Renamed from swank-compiler.  Return a single
compilation-result.
(compile-multiple-strings-for-emacs): Return a list of
compilation-results instead of a single result with merged notes.

* swank-backend.lisp (filename-to-pathname): Renamed from
parse-emacs-filename.  Updated callers.
(pathname-to-filename): New function.  Use it where appropriate.

* swank-scl.lisp (pathname-to-filename): Implement it in the
backend to get rid of the #+scl in swank.lisp.

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

  ViewVC Help
Powered by ViewVC 1.1.5