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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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