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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.104 - (show annotations)
Sat May 22 08:14:39 2004 UTC (9 years, 10 months ago) by heller
Branch: MAIN
Changes since 1.103: +2 -1 lines
(arglist): Catch (reader) errors in read-arglist.
1 ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2 ;;;
3 ;;;; Introduction
4 ;;;
5 ;;; This is the CMUCL implementation of the `swank-backend' package.
6
7 (in-package :swank-backend)
8
9 ;;;; "Hot fixes"
10 ;;;
11 ;;; Here are necessary bugfixes to the latest released version of
12 ;;; CMUCL (currently 18e). Any fixes placed here should also be
13 ;;; submitted to the `cmucl-imp' mailing list and confirmed as
14 ;;; good. When a new release is made that includes the fixes we should
15 ;;; promptly delete them from here. It is enough to be compatible with
16 ;;; the latest release.
17
18 (in-package :lisp)
19
20 ;;; `READ-SEQUENCE' with large sequences has problems in 18e. This new
21 ;;; definition works better.
22
23 #+cmu18e
24 (progn
25 (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
26 (when s
27 (setf (symbol-value s) nil)))
28
29 (defun read-into-simple-string (s stream start end)
30 (declare (type simple-string s))
31 (declare (type stream stream))
32 (declare (type index start end))
33 (unless (subtypep (stream-element-type stream) 'character)
34 (error 'type-error
35 :datum (read-char stream nil #\Null)
36 :expected-type (stream-element-type stream)
37 :format-control "Trying to read characters from a binary stream."))
38 ;; Let's go as low level as it seems reasonable.
39 (let* ((numbytes (- end start))
40 (total-bytes 0))
41 ;; read-n-bytes may return fewer bytes than requested, so we need
42 ;; to keep trying.
43 (loop while (plusp numbytes) do
44 (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
45 (when (zerop bytes-read)
46 (return-from read-into-simple-string total-bytes))
47 (incf total-bytes bytes-read)
48 (incf start bytes-read)
49 (decf numbytes bytes-read)))
50 total-bytes))
51
52 (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
53 (when s
54 (setf (symbol-value s) t)))
55
56 )
57
58 (in-package :swank-backend)
59
60
61 ;;;; TCP server
62 ;;;
63 ;;; In CMUCL we support all communication styles. By default we use
64 ;;; `:SIGIO' because it is the most responsive, but it's somewhat
65 ;;; dangerous: CMUCL is not in general "signal safe", and you don't
66 ;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and
67 ;;; `:SPAWN' are reasonable alternatives.
68
69 (defimplementation preferred-communication-style ()
70 :sigio)
71
72 (defimplementation create-socket (host port)
73 (ext:create-inet-listener port :stream
74 :reuse-address t
75 :host (resolve-hostname host)))
76
77 (defimplementation local-port (socket)
78 (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
79
80 (defimplementation close-socket (socket)
81 (ext:close-socket (socket-fd socket)))
82
83 (defimplementation accept-connection (socket)
84 #+mp (mp:process-wait-until-fd-usable socket :input)
85 (make-socket-io-stream (ext:accept-tcp-connection socket)))
86
87 ;;;;; Sockets
88
89 (defun socket-fd (socket)
90 "Return the filedescriptor for the socket represented by SOCKET."
91 (etypecase socket
92 (fixnum socket)
93 (sys:fd-stream (sys:fd-stream-fd socket))))
94
95 (defun resolve-hostname (hostname)
96 "Return the IP address of HOSTNAME as an integer."
97 (let* ((hostent (ext:lookup-host-entry hostname))
98 (address (car (ext:host-entry-addr-list hostent))))
99 (ext:htonl address)))
100
101 (defun make-socket-io-stream (fd)
102 "Create a new input/output fd-stream for FD."
103 (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
104
105 ;;;;; Signal-driven I/O
106
107 (defvar *sigio-handlers* '()
108 "List of (key . function) pairs.
109 All functions are called on SIGIO, and the key is used for removing
110 specific functions.")
111
112 (defun set-sigio-handler ()
113 (sys:enable-interrupt :sigio (lambda (signal code scp)
114 (sigio-handler signal code scp))))
115
116 (defun sigio-handler (signal code scp)
117 (declare (ignore signal code scp))
118 (mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
119
120 (defun fcntl (fd command arg)
121 "fcntl(2) - manipulate a file descriptor."
122 (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
123 (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error)))))
124
125 (defimplementation add-sigio-handler (socket fn)
126 (set-sigio-handler)
127 (let ((fd (socket-fd socket)))
128 (format *debug-io* "; Adding input handler: ~S ~%" fd)
129 (fcntl fd unix:f-setown (unix:unix-getpid))
130 (fcntl fd unix:f-setfl unix:fasync)
131 (push (cons fd fn) *sigio-handlers*)))
132
133 (defimplementation remove-sigio-handlers (socket)
134 (let ((fd (socket-fd socket)))
135 (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
136 (sys:invalidate-descriptor fd))
137 (close socket))
138
139 ;;;;; SERVE-EVENT
140
141 (defimplementation add-fd-handler (socket fn)
142 (let ((fd (socket-fd socket)))
143 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
144 (sys:add-fd-handler fd :input (lambda (_)
145 _
146 (funcall fn)))))
147
148 (defimplementation remove-fd-handlers (socket)
149 (sys:invalidate-descriptor (socket-fd socket)))
150
151
152 ;;;; Stream handling
153 ;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
154
155 (defimplementation make-fn-streams (input-fn output-fn)
156 (let* ((output (make-slime-output-stream output-fn))
157 (input (make-slime-input-stream input-fn output)))
158 (values input output)))
159
160 (defstruct (slime-output-stream
161 (:include lisp::lisp-stream
162 (lisp::misc #'sos/misc)
163 (lisp::out #'sos/out)
164 (lisp::sout #'sos/sout))
165 (:conc-name sos.)
166 (:print-function %print-slime-output-stream)
167 (:constructor make-slime-output-stream (output-fn)))
168 (output-fn nil :type function)
169 (buffer (make-string 512) :type string)
170 (index 0 :type kernel:index)
171 (column 0 :type kernel:index))
172
173 (defun %print-slime-output-stream (s stream d)
174 (declare (ignore d))
175 (print-unreadable-object (s stream :type t :identity t)))
176
177 (defun sos/out (stream char)
178 (let ((buffer (sos.buffer stream))
179 (index (sos.index stream)))
180 (setf (schar buffer index) char)
181 (setf (sos.index stream) (1+ index))
182 (incf (sos.column stream))
183 (when (char= #\newline char)
184 (setf (sos.column stream) 0))
185 (when (= index (1- (length buffer)))
186 (force-output stream)))
187 char)
188
189 (defun sos/sout (stream string start end)
190 (loop for i from start below end
191 do (sos/out stream (aref string i))))
192
193 (defun sos/misc (stream operation &optional arg1 arg2)
194 (declare (ignore arg1 arg2))
195 (case operation
196 ((:force-output :finish-output)
197 (let ((end (sos.index stream)))
198 (unless (zerop end)
199 (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end))
200 (setf (sos.index stream) 0))))
201 (:charpos (sos.column stream))
202 (:line-length 75)
203 (:file-position nil)
204 (:element-type 'base-char)
205 (:get-command nil)
206 (:close nil)
207 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
208
209 (defstruct (slime-input-stream
210 (:include string-stream
211 (lisp::in #'sis/in)
212 (lisp::misc #'sis/misc))
213 (:conc-name sis.)
214 (:print-function %print-slime-output-stream)
215 (:constructor make-slime-input-stream (input-fn sos)))
216 (input-fn nil :type function)
217 ;; We know our sibling output stream, so that we can force it before
218 ;; requesting input.
219 (sos nil :type slime-output-stream)
220 (buffer "" :type string)
221 (index 0 :type kernel:index))
222
223 (defun sis/in (stream eof-errorp eof-value)
224 (declare (ignore eof-errorp eof-value))
225 (let ((index (sis.index stream))
226 (buffer (sis.buffer stream)))
227 (when (= index (length buffer))
228 (force-output (sis.sos stream))
229 (setf buffer (funcall (sis.input-fn stream)))
230 (setf (sis.buffer stream) buffer)
231 (setf index 0))
232 (prog1 (aref buffer index)
233 (setf (sis.index stream) (1+ index)))))
234
235 (defun sis/misc (stream operation &optional arg1 arg2)
236 (declare (ignore arg2))
237 (ecase operation
238 (:file-position nil)
239 (:file-length nil)
240 (:unread (setf (aref (sis.buffer stream)
241 (decf (sis.index stream)))
242 arg1))
243 (:clear-input
244 (setf (sis.index stream) 0
245 (sis.buffer stream) ""))
246 (:listen (< (sis.index stream) (length (sis.buffer stream))))
247 (:charpos nil)
248 (:line-length nil)
249 (:get-command nil)
250 (:element-type 'base-char)
251 (:close nil)))
252
253
254 ;;;; Compilation Commands
255
256 (defvar *previous-compiler-condition* nil
257 "Used to detect duplicates.")
258
259 (defvar *previous-context* nil
260 "Previous compiler error context.")
261
262 (defvar *buffer-name* nil
263 "The name of the Emacs buffer we are compiling from.
264 NIL if we aren't compiling from a buffer.")
265
266 (defvar *buffer-start-position* nil)
267 (defvar *buffer-substring* nil)
268
269 (defimplementation call-with-compilation-hooks (function)
270 (let ((*previous-compiler-condition* nil)
271 (*previous-context* nil)
272 (*print-readably* nil))
273 (handler-bind ((c::compiler-error #'handle-notification-condition)
274 (c::style-warning #'handle-notification-condition)
275 (c::warning #'handle-notification-condition))
276 (funcall function))))
277
278 (defimplementation swank-compile-file (filename load-p)
279 (clear-xref-info filename)
280 (with-compilation-hooks ()
281 (let ((*buffer-name* nil))
282 (multiple-value-bind (output-file warnings-p failure-p)
283 (compile-file filename :load load-p)
284 (unless failure-p
285 ;; Cache the latest source file for definition-finding.
286 (source-cache-get filename (file-write-date filename)))
287 (values output-file warnings-p failure-p)))))
288
289 (defimplementation swank-compile-string (string &key buffer position)
290 (with-compilation-hooks ()
291 (let ((*buffer-name* buffer)
292 (*buffer-start-position* position)
293 (*buffer-substring* string))
294 (with-input-from-string (stream string)
295 (ext:compile-from-stream
296 stream
297 :source-info `(:emacs-buffer ,buffer
298 :emacs-buffer-offset ,position
299 :emacs-buffer-string ,string))))))
300
301
302 ;;;;; Trapping notes
303 ;;;
304 ;;; We intercept conditions from the compiler and resignal them as
305 ;;; `SWANK:COMPILER-CONDITION's.
306
307 (defun handle-notification-condition (condition)
308 "Handle a condition caused by a compiler warning."
309 (unless (eq condition *previous-compiler-condition*)
310 (let ((context (c::find-error-context nil)))
311 (setq *previous-compiler-condition* condition)
312 (setq *previous-context* context)
313 (signal-compiler-condition condition context))))
314
315 (defun signal-compiler-condition (condition context)
316 (signal (make-condition
317 'compiler-condition
318 :original-condition condition
319 :severity (severity-for-emacs condition)
320 :short-message (brief-compiler-message-for-emacs condition)
321 :message (long-compiler-message-for-emacs condition context)
322 :location (compiler-note-location context))))
323
324 (defun severity-for-emacs (condition)
325 "Return the severity of CONDITION."
326 (etypecase condition
327 (c::compiler-error :error)
328 (c::style-warning :note)
329 (c::warning :warning)))
330
331 (defun brief-compiler-message-for-emacs (condition)
332 "Briefly describe a compiler error for Emacs.
333 When Emacs presents the message it already has the source popped up
334 and the source form highlighted. This makes much of the information in
335 the error-context redundant."
336 (princ-to-string condition))
337
338 (defun long-compiler-message-for-emacs (condition error-context)
339 "Describe a compiler error for Emacs including context information."
340 (declare (type (or c::compiler-error-context null) error-context))
341 (multiple-value-bind (enclosing source)
342 (if error-context
343 (values (c::compiler-error-context-enclosing-source error-context)
344 (c::compiler-error-context-source error-context)))
345 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
346 enclosing source condition)))
347
348 (defun compiler-note-location (context)
349 "Derive the location of a complier message from its context.
350 Return a `location' record, or (:error REASON) on failure."
351 (if (null context)
352 (note-error-location)
353 (let ((file (c::compiler-error-context-file-name context))
354 (source (c::compiler-error-context-original-source context))
355 (path
356 (reverse (c::compiler-error-context-original-source-path context))))
357 (or (locate-compiler-note file source path)
358 (note-error-location)))))
359
360 (defun note-error-location ()
361 "Pseudo-location for notes that can't be located."
362 (list :error "No error location available."))
363
364 (defun locate-compiler-note (file source source-path)
365 (cond ((and (eq file :stream) *buffer-name*)
366 ;; Compiling from a buffer
367 (let ((position (+ *buffer-start-position*
368 (source-path-string-position
369 source-path *buffer-substring*))))
370 (make-location (list :buffer *buffer-name*)
371 (list :position position))))
372 ((and (pathnamep file) (null *buffer-name*))
373 ;; Compiling from a file
374 (make-location (list :file (unix-truename file))
375 (list :position
376 (1+ (source-path-file-position
377 source-path file)))))
378 ((and (eq file :lisp) (stringp source))
379 ;; No location known, but we have the source form.
380 ;; XXX How is this case triggered? -luke (16/May/2004)
381 (make-location (list :source-form source)
382 (list :position 1)))))
383
384 (defun unix-truename (pathname)
385 (ext:unix-namestring (truename pathname)))
386
387
388 ;;;; XREF
389 ;;;
390 ;;; Cross-reference support is based on the standard CMUCL `XREF'
391 ;;; package. This package has some caveats: XREF information is
392 ;;; recorded during compilation and not preserved in fasl files, and
393 ;;; XREF recording is disabled by default. Redefining functions can
394 ;;; also cause duplicate references to accumulate, but
395 ;;; `swank-compile-file' will automatically clear out any old records
396 ;;; from the same filename.
397 ;;;
398 ;;; To enable XREF recording, set `c:*record-xref-info*' to true. To
399 ;;; clear out the XREF database call `xref:init-xref-database'.
400
401 (defmacro defxref (name function)
402 `(defimplementation ,name (name)
403 (xref-results (,function name))))
404
405 (defxref who-calls xref:who-calls)
406 (defxref who-references xref:who-references)
407 (defxref who-binds xref:who-binds)
408 (defxref who-sets xref:who-sets)
409
410 ;;; More types of XREF information were added since 18e:
411 ;;;
412 #+cmu19
413 (progn
414 (defxref who-macroexpands xref:who-macroexpands)
415 ;; XXX
416 (defimplementation who-specializes (symbol)
417 (let* ((methods (xref::who-specializes (find-class symbol)))
418 (locations (mapcar #'method-location methods)))
419 (mapcar #'list methods locations))))
420
421 (defun xref-results (contexts)
422 (mapcar (lambda (xref)
423 (list (xref:xref-context-name xref)
424 (resolve-xref-location xref)))
425 contexts))
426
427 (defun resolve-xref-location (xref)
428 (let ((name (xref:xref-context-name xref))
429 (file (xref:xref-context-file xref))
430 (source-path (xref:xref-context-source-path xref)))
431 (cond ((and file source-path)
432 (let ((position (source-path-file-position source-path file)))
433 (make-location (list :file (unix-truename file))
434 (list :position (1+ position)))))
435 (file
436 (make-location (list :file (unix-truename file))
437 (list :function-name (string name))))
438 (t
439 `(:error ,(format nil "Unknown source location: ~S ~S ~S "
440 name file source-path))))))
441
442 (defun clear-xref-info (namestring)
443 "Clear XREF notes pertaining to NAMESTRING.
444 This is a workaround for a CMUCL bug: XREF records are cumulative."
445 (when c:*record-xref-info*
446 (let ((filename (truename namestring)))
447 (dolist (db (list xref::*who-calls*
448 #+cmu19 xref::*who-is-called*
449 #+cmu19 xref::*who-macroexpands*
450 xref::*who-references*
451 xref::*who-binds*
452 xref::*who-sets*))
453 (maphash (lambda (target contexts)
454 ;; XXX update during traversal?
455 (setf (gethash target db)
456 (delete filename contexts
457 :key #'xref:xref-context-file
458 :test #'equalp)))
459 db)))))
460
461
462 ;;;; Find callers and callees
463 ;;;
464 ;;; Find callers and callees by looking at the constant pool of
465 ;;; compiled code objects. We assume every fdefn object in the
466 ;;; constant pool corresponds to a call to that function. A better
467 ;;; strategy would be to use the disassembler to find actual
468 ;;; call-sites.
469
470 (declaim (inline map-code-constants))
471 (defun map-code-constants (code fn)
472 "Call FN for each constant in CODE's constant pool."
473 (check-type code kernel:code-component)
474 (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
475 do (funcall fn (kernel:code-header-ref code i))))
476
477 (defun function-callees (function)
478 "Return FUNCTION's callees as a list of functions."
479 (let ((callees '()))
480 (map-code-constants
481 (vm::find-code-object function)
482 (lambda (obj)
483 (when (kernel:fdefn-p obj)
484 (push (kernel:fdefn-function obj) callees))))
485 callees))
486
487 (declaim (ext:maybe-inline map-allocated-code-components))
488 (defun map-allocated-code-components (spaces fn)
489 "Call FN for each allocated code component in one of SPACES. FN
490 receives the object as argument. SPACES should be a list of the
491 symbols :dynamic, :static, or :read-only."
492 (dolist (space spaces)
493 (declare (inline vm::map-allocated-objects))
494 (vm::map-allocated-objects
495 (lambda (obj header size)
496 (declare (type fixnum size) (ignore size))
497 (when (= vm:code-header-type header)
498 (funcall fn obj)))
499 space)))
500
501 (declaim (ext:maybe-inline map-caller-code-components))
502 (defun map-caller-code-components (function spaces fn)
503 "Call FN for each code component with a fdefn for FUNCTION in its
504 constant pool."
505 (let ((function (coerce function 'function)))
506 (declare (inline map-allocated-code-components))
507 (map-allocated-code-components
508 spaces
509 (lambda (obj)
510 (map-code-constants
511 obj
512 (lambda (constant)
513 (when (and (kernel:fdefn-p constant)
514 (eq (kernel:fdefn-function constant)
515 function))
516 (funcall fn obj))))))))
517
518 (defun function-callers (function &optional (spaces '(:read-only :static
519 :dynamic)))
520 "Return FUNCTION's callers. The result is a list of code-objects."
521 (let ((referrers '()))
522 (declare (inline map-caller-code-components))
523 (ext:gc :full t)
524 (map-caller-code-components function spaces
525 (lambda (code) (push code referrers)))
526 referrers))
527
528 (defun debug-info-definitions (debug-info)
529 "Return the defintions for a debug-info. This should only be used
530 for code-object without entry points, i.e., byte compiled
531 code (are theree others?)"
532 ;; This mess has only been tested with #'ext::skip-whitespace, a
533 ;; byte-compiled caller of #'read-char .
534 (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
535 (let ((name (c::debug-info-name debug-info))
536 (source (c::debug-info-source debug-info)))
537 (destructuring-bind (first) source
538 (ecase (c::debug-source-from first)
539 (:file
540 (list (list name
541 (make-location
542 (list :file (unix-truename (c::debug-source-name first)))
543 (list :function-name name)))))))))
544
545 (defun code-component-entry-points (code)
546 "Return a list ((NAME LOCATION) ...) of function definitons for
547 the code omponent CODE."
548 (delete-duplicates
549 (loop for e = (kernel:%code-entry-points code)
550 then (kernel::%function-next e)
551 while e
552 collect (list (kernel:%function-name e)
553 (function-location e)))
554 :test #'equal))
555
556 (defimplementation list-callers (symbol)
557 "Return a list ((NAME LOCATION) ...) of callers."
558 (let ((components (function-callers symbol))
559 (xrefs '()))
560 (dolist (code components)
561 (let* ((entry (kernel:%code-entry-points code))
562 (defs (if entry
563 (code-component-entry-points code)
564 ;; byte compiled stuff
565 (debug-info-definitions
566 (kernel:%code-debug-info code)))))
567 (setq xrefs (nconc defs xrefs))))
568 xrefs))
569
570 (defimplementation list-callees (symbol)
571 (let ((fns (function-callees symbol)))
572 (mapcar (lambda (fn)
573 (list (kernel:%function-name fn)
574 (function-location fn)))
575 fns)))
576
577
578 ;;;; Resolving source locations
579 ;;;
580 ;;; Our mission here is to "resolve" references to code locations into
581 ;;; actual file/buffer names and character positions. The references
582 ;;; we work from come out of the compiler's statically-generated debug
583 ;;; information, such as `code-location''s and `debug-source''s. For
584 ;;; more details, see the "Debugger Programmer's Interface" section of
585 ;;; the CMUCL manual.
586 ;;;
587 ;;; The first step is usually to find the corresponding "source-path"
588 ;;; for the location. Once we have the source-path we can pull up the
589 ;;; source file and `READ' our way through to the right position. The
590 ;;; main source-code groveling work is done in
591 ;;; `swank-source-path-parser.lisp'.
592
593 (defvar *debug-definition-finding* nil
594 "When true don't handle errors while looking for definitions.
595 This is useful when debugging the definition-finding code.")
596
597 (defvar *source-snippet-size* 256
598 "Maximum number of characters in a snippet of source code.
599 Snippets at the beginning of definitions are used to tell Emacs what
600 the definitions looks like, so that it can accurately find them by
601 text search.")
602
603 (defmacro safe-definition-finding (&body body)
604 "Execute BODY and return the source-location it returns.
605 If an error occurs and `*debug-definition-finding*' is false, then
606 return an error pseudo-location.
607
608 The second return value is NIL if no error occurs, otherwise it is the
609 condition object."
610 `(flet ((body () ,@body))
611 (if *debug-definition-finding*
612 (body)
613 (handler-case (values (progn ,@body) nil)
614 (error (c) (values (list :error (princ-to-string c)) c))))))
615
616 (defun code-location-source-location (code-location)
617 "Safe wrapper around `code-location-from-source-location'."
618 (safe-definition-finding
619 (source-location-from-code-location code-location)))
620
621 (defun source-location-from-code-location (code-location)
622 "Return the source location for CODE-LOCATION."
623 (let ((debug-fun (di:code-location-debug-function code-location)))
624 (when (di::bogus-debug-function-p debug-fun)
625 ;; Those lousy cheapskates! They've put in a bogus debug source
626 ;; because the code was compiled at a low debug setting.
627 (error "Bogus debug function: ~A" debug-fun)))
628 (let* ((debug-source (di:code-location-debug-source code-location))
629 (from (di:debug-source-from debug-source))
630 (name (di:debug-source-name debug-source)))
631 (ecase from
632 (:file
633 (location-in-file name code-location debug-source))
634 (:stream
635 (location-in-stream code-location debug-source))
636 (:lisp
637 ;; The location comes from a form passed to `compile'.
638 ;; The best we can do is return the form itself for printing.
639 (make-location
640 (list :source-form (with-output-to-string (*standard-output*)
641 (debug::print-code-location-source-form
642 code-location 100 t)))
643 (list :position 1))))))
644
645 (defun location-in-file (filename code-location debug-source)
646 "Resolve the source location for CODE-LOCATION in FILENAME."
647 (let* ((code-date (di:debug-source-created debug-source))
648 (source-code (or (source-cache-get filename code-date)
649 (read-file filename))))
650 (make-location (list :file (unix-truename filename)) nil)
651 (with-input-from-string (s source-code)
652 (make-location (list :file (unix-truename filename))
653 (list :position
654 (1+ (code-location-stream-position
655 code-location s)))
656 `(:snippet ,(read-snippet s))))))
657
658 (defun location-in-stream (code-location debug-source)
659 "Resolve the source location for a CODE-LOCATION from a stream.
660 This only succeeds if the code was compiled from an Emacs buffer."
661 (unless (debug-source-info-from-emacs-buffer-p debug-source)
662 (error "The code is compiled from a non-SLIME stream."))
663 (let* ((info (c::debug-source-info debug-source))
664 (string (getf info :emacs-buffer-string))
665 (position (code-location-string-offset
666 code-location
667 string)))
668 (make-location
669 (list :buffer (getf info :emacs-buffer))
670 (list :position (+ (getf info :emacs-buffer-offset) position))
671 (list :snippet (with-input-from-string (s string)
672 (file-position s position)
673 (read-snippet s))))))
674
675 (defun read-file (filename)
676 "Return the entire contents of FILENAME as a string."
677 (with-open-file (s filename :direction :input)
678 (let ((string (make-string (file-length s))))
679 (read-sequence string s)
680 string)))
681
682 (defun read-snippet (stream)
683 "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM."
684 (read-upto-n-chars stream *source-snippet-size*))
685
686 (defun read-upto-n-chars (stream n)
687 "Return a string of upto N chars from STREAM."
688 (let* ((string (make-string n))
689 (chars (read-sequence string stream)))
690 (subseq string 0 chars)))
691
692 ;;;;; Function-name locations
693 ;;;
694 (defun debug-info-function-name-location (debug-info)
695 "Return a function-name source-location for DEBUG-INFO.
696 Function-name source-locations are a fallback for when precise
697 positions aren't available."
698 (with-struct (c::debug-info- (fname name) source) debug-info
699 (with-struct (c::debug-source- info from name) (car source)
700 (ecase from
701 (:file
702 (make-location (list :file (namestring (truename name)))
703 (list :function-name fname)))
704 (:stream
705 (assert (debug-source-info-from-emacs-buffer-p (car source)))
706 (make-location (list :buffer (getf info :emacs-buffer))
707 (list :function-name fname)))
708 (:lisp
709 (make-location (list :source-form (princ-to-string (aref name 0)))
710 (list :position 1)))))))
711
712 (defun debug-source-info-from-emacs-buffer-p (debug-source)
713 "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location?
714 This is true for functions that were compiled directly from buffers."
715 (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
716
717 (defun info-from-emacs-buffer-p (info)
718 (and info
719 (consp info)
720 (eq :emacs-buffer (car info))))
721
722
723 ;;;;; Groveling source-code for positions
724
725 (defun code-location-stream-position (code-location stream)
726 "Return the byte offset of CODE-LOCATION in STREAM. Extract the
727 toplevel-form-number and form-number from CODE-LOCATION and use that
728 to find the position of the corresponding form.
729
730 Finish with STREAM positioned at the start of the code location."
731 (let* ((location (debug::maybe-block-start-location code-location))
732 (tlf-offset (di:code-location-top-level-form-offset location))
733 (form-number (di:code-location-form-number location)))
734 (let ((pos (form-number-stream-position tlf-offset form-number stream)))
735 (file-position stream pos)
736 pos)))
737
738 (defun form-number-stream-position (tlf-number form-number stream)
739 "Return the starting character position of a form in STREAM.
740 TLF-NUMBER is the top-level-form number.
741 FORM-NUMBER is an index into a source-path table for the TLF."
742 (let ((*read-suppress* t))
743 (dotimes (i tlf-number) (read stream))
744 (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
745 (let* ((path-table (di:form-number-translations tlf 0))
746 (source-path
747 (if (<= (length path-table) form-number) ; source out of sync?
748 (list 0) ; should probably signal a condition
749 (reverse (cdr (aref path-table form-number))))))
750 (source-path-source-position source-path tlf position-map)))))
751
752 (defun code-location-string-offset (code-location string)
753 "Return the byte offset of CODE-LOCATION in STRING.
754 See CODE-LOCATION-STREAM-POSITION."
755 (with-input-from-string (s string)
756 (code-location-stream-position code-location s)))
757
758 ;;;;; Source-file cache
759 ;;;
760 ;;; To robustly find source locations it's useful to have the exact
761 ;;; source code that the loaded code was compiled from. In this source
762 ;;; we can accurately find the right location, and from that location
763 ;;; we can extract a "snippet" of code to show what the definition
764 ;;; looks like. Emacs can use this snippet in a best-match search to
765 ;;; locate the right definition, which works well even if the buffer
766 ;;; has been modified.
767 ;;;
768 ;;; The idea is that if a definition previously started with
769 ;;; `(define-foo bar' then it probably still does.
770 ;;;
771 ;;; Whenever we see that the file on disk has the same
772 ;;; `file-write-date' as a location we're looking for, we cache the
773 ;;; whole file inside Lisp. That way we will still have the matching
774 ;;; version even if the file is later modified on disk. If the file is
775 ;;; later recompiled and reloaded then we replace our cache entry.
776
777 (defvar *cache-sourcecode* t
778 "When true complete source files are cached.
779 The cache is used to keep known good copies of the source text which
780 correspond to the loaded code. Finding definitions is much more
781 reliable when the exact source is available, so we cache it in case it
782 gets edited on disk later.")
783
784 (defvar *source-file-cache* (make-hash-table :test 'equal)
785 "Cache of source file contents.
786 Maps from truename to source-cache-entry structure.")
787
788 (defstruct (source-cache-entry
789 (:conc-name source-cache-entry.)
790 (:constructor make-source-cache-entry (text date)))
791 text date)
792
793 (defun source-cache-get (filename date)
794 "Return the source code for FILENAME as written on DATE in a string.
795 Return NIL if the right version cannot be found."
796 (let ((entry (gethash filename *source-file-cache*)))
797 (cond ((and entry (equal date (source-cache-entry.date entry)))
798 ;; Cache hit.
799 (source-cache-entry.text entry))
800 ((or (null entry)
801 (not (equal date (source-cache-entry.date entry))))
802 ;; Cache miss.
803 (if (equal (file-write-date filename) date)
804 ;; File on disk has the correct version.
805 (let ((source (read-file filename)))
806 (setf (gethash filename *source-file-cache*)
807 (make-source-cache-entry source date))
808 source)
809 nil)))))
810
811
812 ;;;; Finding definitions
813
814 ;;; There are a great many different types of definition for us to
815 ;;; find. We search for definitions of every kind and return them in a
816 ;;; list.
817
818 (defimplementation find-definitions (name)
819 (append (function-definitions name)
820 (setf-definitions name)
821 (variable-definitions name)
822 (class-definitions name)
823 (type-definitions name)
824 (compiler-macro-definitions name)
825 (source-transform-definitions name)
826 (function-info-definitions name)
827 (ir1-translator-definitions name)))
828
829 ;;;;; Functions, macros, generic functions, methods
830 ;;;
831 ;;; We make extensive use of the compile-time debug information that
832 ;;; CMUCL records, in particular "debug functions" and "code
833 ;;; locations." Refer to the "Debugger Programmer's Interface" section
834 ;;; of the CMUCL manual for more details.
835
836 (defun function-definitions (name)
837 "Return definitions for NAME in the \"function namespace\", i.e.,
838 regular functions, generic functions, methods and macros.
839 NAME can any valid function name (e.g, (setf car))."
840 (let ((macro? (and (symbolp name) (macro-function name)))
841 (special? (and (symbolp name) (special-operator-p name)))
842 (function? (and (ext:valid-function-name-p name)
843 (ext:info :function :definition name))))
844 (cond (macro?
845 (list `((defmacro ,name)
846 ,(function-location (macro-function name)))))
847 (special?
848 (list `((:special-operator ,name)
849 (:error ,(format nil "Special operator: ~S" name)))))
850 (function?
851 (let ((function (fdefinition name)))
852 (if (genericp function)
853 (generic-function-definitions name function)
854 (list (list `(function ,name)
855 (function-location function)))))))))
856
857 ;;;;;; Ordinary (non-generic/macro/special) functions
858 ;;;
859 ;;; First we test if FUNCTION is a closure created by defstruct, and
860 ;;; if so extract the defstruct-description (`dd') from the closure
861 ;;; and find the constructor for the struct. Defstruct creates a
862 ;;; defun for the default constructor and we use that as an
863 ;;; approximation to the source location of the defstruct.
864 ;;;
865 ;;; For an ordinary function we return the source location of the
866 ;;; first code-location we find.
867 ;;;
868 (defun function-location (function)
869 "Return the source location for FUNCTION."
870 (cond ((struct-closure-p function)
871 (struct-closure-location function))
872 ((c::byte-function-or-closure-p function)
873 (byte-function-location function))
874 (t
875 (compiled-function-location function))))
876
877 (defun compiled-function-location (function)
878 "Return the location of a regular compiled function."
879 (multiple-value-bind (code-location error)
880 (safe-definition-finding (function-first-code-location function))
881 (cond (error (list :error (princ-to-string error)))
882 (t (code-location-source-location code-location)))))
883
884 (defun function-first-code-location (function)
885 "Return the first code-location we can find for FUNCTION."
886 (and (function-has-debug-function-p function)
887 (di:debug-function-start-location
888 (di:function-debug-function function))))
889
890 (defun function-has-debug-function-p (function)
891 (di:function-debug-function function))
892
893 (defun function-code-object= (closure function)
894 (and (eq (vm::find-code-object closure)
895 (vm::find-code-object function))
896 (not (eq closure function))))
897
898
899 (defun byte-function-location (fn)
900 "Return the location of the byte-compiled function FN."
901 (etypecase fn
902 ((or c::hairy-byte-function c::simple-byte-function)
903 (let* ((component (c::byte-function-component fn))
904 (debug-info (kernel:%code-debug-info component)))
905 (debug-info-function-name-location debug-info)))
906 (c::byte-closure
907 (byte-function-location (c::byte-closure-function fn)))))
908
909 ;;; Here we deal with structure accessors. Note that `dd' is a
910 ;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a
911 ;;; `defstruct''d structure.
912
913 (defun struct-closure-p (function)
914 "Is FUNCTION a closure created by defstruct?"
915 (or (function-code-object= function #'kernel::structure-slot-accessor)
916 (function-code-object= function #'kernel::structure-slot-setter)
917 (function-code-object= function #'kernel::%defstruct)))
918
919 (defun struct-closure-location (function)
920 "Return the location of the structure that FUNCTION belongs to."
921 (assert (struct-closure-p function))
922 (safe-definition-finding
923 (dd-location (struct-closure-dd function))))
924
925 (defun struct-closure-dd (function)
926 "Return the defstruct-definition (dd) of FUNCTION."
927 (assert (= (kernel:get-type function) vm:closure-header-type))
928 (flet ((find-layout (function)
929 (sys:find-if-in-closure
930 (lambda (x)
931 (let ((value (if (di::indirect-value-cell-p x)
932 (c:value-cell-ref x)
933 x)))
934 (when (kernel::layout-p value)
935 (return-from find-layout value))))
936 function)))
937 (kernel:layout-info (find-layout function))))
938
939 (defun dd-location (dd)
940 "Return the location of a `defstruct'."
941 ;; Find the location in a constructor.
942 (function-location (struct-constructor dd)))
943
944 (defun struct-constructor (dd)
945 "Return a constructor function from a defstruct definition.
946 Signal an error if no constructor can be found."
947 (let ((constructor (or (kernel:dd-default-constructor dd)
948 (car (kernel::dd-constructors dd)))))
949 (when (or (null constructor)
950 (and (consp constructor) (null (car constructor))))
951 (error "Cannot find structure's constructor: ~S"
952 (kernel::dd-name dd)))
953 (coerce (if (consp constructor) (first constructor) constructor)
954 'function)))
955
956 ;;;;;; Generic functions and methods
957
958 (defun generic-function-definitions (name function)
959 "Return the definitions of a generic function and its methods."
960 (cons (list `(defgeneric ,name) (gf-location function))
961 (gf-method-definitions function)))
962
963 (defun gf-location (gf)
964 "Return the location of the generic function GF."
965 (definition-source-location gf (pcl::generic-function-name gf)))
966
967 (defun gf-method-definitions (gf)
968 "Return the locations of all methods of the generic function GF."
969 (mapcar #'method-definition (pcl::generic-function-methods gf)))
970
971 (defun method-definition (method)
972 (list (method-dspec method)
973 (method-location method)))
974
975 (defun method-dspec (method)
976 "Return a human-readable \"definition specifier\" for METHOD."
977 (let* ((gf (pcl:method-generic-function method))
978 (name (pcl:generic-function-name gf))
979 (specializers (pcl:method-specializers method))
980 (qualifiers (pcl:method-qualifiers method)))
981 `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
982
983 ;; XXX maybe special case setters/getters
984 (defun method-location (method)
985 (function-location (or (pcl::method-fast-function method)
986 (pcl:method-function method))))
987
988 (defun genericp (fn)
989 (typep fn 'generic-function))
990
991 (defun maybe-make-definition (function kind name)
992 (if function
993 (list (list `(,kind ,name) (function-location function)))))
994
995 (defun type-definitions (name)
996 (maybe-make-definition (ext:info :type :expander name) 'deftype name))
997
998 (defun find-dd (name)
999 (let ((layout (ext:info :type :compiler-layout name)))
1000 (if layout
1001 (kernel:layout-info layout))))
1002
1003 (defun condition-class-location (class)
1004 (let ((slots (conditions::condition-class-slots class))
1005 (name (conditions::condition-class-name class)))
1006 (cond ((null slots)
1007 `(:error ,(format nil "No location info for condition: ~A" name)))
1008 (t
1009 (let* ((slot (first slots))
1010 (gf (fdefinition
1011 (first (conditions::condition-slot-readers slot)))))
1012 (method-location
1013 (first
1014 (pcl:compute-applicable-methods-using-classes
1015 gf (list (find-class name))))))))))
1016
1017 (defun class-location (class)
1018 (definition-source-location class (pcl:class-name class)))
1019
1020 (defun make-name-in-file-location (file string)
1021 (multiple-value-bind (filename c)
1022 (ignore-errors
1023 (unix-truename (merge-pathnames (make-pathname :type "lisp")
1024 file)))
1025 (cond (filename (make-location `(:file ,filename)
1026 `(:function-name ,string)))
1027 (t (list :error (princ-to-string c))))))
1028
1029 (defun source-location-form-numbers (location)
1030 (c::decode-form-numbers (c::form-numbers-form-numbers location)))
1031
1032 (defun source-location-tlf-number (location)
1033 (nth-value 0 (source-location-form-numbers location)))
1034
1035 (defun source-location-form-number (location)
1036 (nth-value 1 (source-location-form-numbers location)))
1037
1038 (defun resolve-file-source-location (location)
1039 (let ((filename (c::file-source-location-pathname location))
1040 (tlf-number (source-location-tlf-number location))
1041 (form-number (source-location-form-number location)))
1042 (with-open-file (s filename)
1043 (let ((pos (form-number-stream-position tlf-number form-number s)))
1044 (make-location `(:file ,(unix-truename filename))
1045 `(:position ,(1+ pos)))))))
1046
1047 (defun resolve-stream-source-location (location)
1048 (let ((info (c::stream-source-location-user-info location))
1049 (tlf-number (source-location-tlf-number location))
1050 (form-number (source-location-form-number location)))
1051 ;; XXX duplication in frame-source-location
1052 (assert (info-from-emacs-buffer-p info))
1053 (destructuring-bind (&key emacs-buffer emacs-buffer-string
1054 emacs-buffer-offset) info
1055 (with-input-from-string (s emacs-buffer-string)
1056 (let ((pos (form-number-stream-position tlf-number form-number s)))
1057 (make-location `(:buffer ,emacs-buffer)
1058 `(:position ,(+ emacs-buffer-offset pos))))))))
1059
1060 ;; XXX predicates for 18e backward compatibilty. Remove them when
1061 ;; we're 19a only.
1062 (defun file-source-location-p (object)
1063 (when (fboundp 'c::file-source-location-p)
1064 (c::file-source-location-p object)))
1065
1066 (defun stream-source-location-p (object)
1067 (when (fboundp 'c::stream-source-location-p)
1068 (c::stream-source-location-p object)))
1069
1070 (defun source-location-p (object)
1071 (or (file-source-location-p object)
1072 (stream-source-location-p object)))
1073
1074 (defun resolve-source-location (location)
1075 (etypecase location
1076 ((satisfies file-source-location-p)
1077 (resolve-file-source-location location))
1078 ((satisfies stream-source-location-p)
1079 (resolve-stream-source-location location))))
1080
1081 (defun definition-source-location (object name)
1082 (let ((source (pcl::definition-source object)))
1083 (etypecase source
1084 (null
1085 `(:error ,(format nil "No source info for: ~A" object)))
1086 ((satisfies source-location-p)
1087 (resolve-source-location source))
1088 (pathname
1089 (make-name-in-file-location source name))
1090 (cons
1091 (destructuring-bind ((dg name) pathname) source
1092 (declare (ignore dg))
1093 (etypecase pathname
1094 (pathname (make-name-in-file-location pathname (string name)))
1095 (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
1096
1097 (defun class-definitions (name)
1098 (if (symbolp name)
1099 (let ((class (kernel::find-class name nil)))
1100 (etypecase class
1101 (null '())
1102 (kernel::structure-class
1103 (list (list `(defstruct ,name) (dd-location (find-dd name)))))
1104 #+(or)
1105 (conditions::condition-class
1106 (list (list `(define-condition ,name)
1107 (condition-class-location class))))
1108 (kernel::standard-class
1109 (list (list `(defclass ,name)
1110 (class-location (find-class name)))))
1111 ((or kernel::built-in-class
1112 conditions::condition-class
1113 kernel:funcallable-structure-class)
1114 (list (list `(kernel::define-type-class ,name)
1115 `(:error
1116 ,(format nil "No source info for ~A" name)))))))))
1117
1118 (defun setf-definitions (name)
1119 (let ((function (or (ext:info :setf :inverse name)
1120 (ext:info :setf :expander name))))
1121 (if function
1122 (list (list `(setf ,name)
1123 (function-location (coerce function 'function)))))))
1124
1125
1126 (defun variable-location (symbol)
1127 (multiple-value-bind (location foundp)
1128 ;; XXX for 18e compatibilty. rewrite this when we drop 18e
1129 ;; support.
1130 (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
1131 (if (and foundp location)
1132 (resolve-source-location location)
1133 `(:error ,(format nil "No source info for variable ~S" symbol)))))
1134
1135 (defun variable-definitions (name)
1136 (if (symbolp name)
1137 (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
1138 (if recorded-p
1139 (list (list `(variable ,kind ,name)
1140 (variable-location name)))))))
1141
1142 (defun compiler-macro-definitions (symbol)
1143 (maybe-make-definition (compiler-macro-function symbol)
1144 'define-compiler-macro
1145 symbol))
1146
1147 (defun source-transform-definitions (name)
1148 (maybe-make-definition (ext:info :function :source-transform name)
1149 'c:def-source-transform
1150 name))
1151
1152 (defun function-info-definitions (name)
1153 (let ((info (ext:info :function :info name)))
1154 (if info
1155 (append (loop for transform in (c::function-info-transforms info)
1156 collect (list `(c:deftransform ,name
1157 ,(c::type-specifier
1158 (c::transform-type transform)))
1159 (function-location (c::transform-function
1160 transform))))
1161 (maybe-make-definition (c::function-info-derive-type info)
1162 'c::derive-type name)
1163 (maybe-make-definition (c::function-info-optimizer info)
1164 'c::optimizer name)
1165 (maybe-make-definition (c::function-info-ltn-annotate info)
1166 'c::ltn-annotate name)
1167 (maybe-make-definition (c::function-info-ir2-convert info)
1168 'c::ir2-convert name)
1169 (loop for template in (c::function-info-templates info)
1170 collect (list `(c::vop ,(c::template-name template))
1171 (function-location
1172 (c::vop-info-generator-function
1173 template))))))))
1174
1175 (defun ir1-translator-definitions (name)
1176 (maybe-make-definition (ext:info :function :ir1-convert name)
1177 'c:def-ir1-translator name))
1178
1179
1180 ;;;; Documentation.
1181
1182 (defimplementation describe-symbol-for-emacs (symbol)
1183 (let ((result '()))
1184 (flet ((doc (kind)
1185 (or (documentation symbol kind) :not-documented))
1186 (maybe-push (property value)
1187 (when value
1188 (setf result (list* property value result)))))
1189 (maybe-push
1190 :variable (multiple-value-bind (kind recorded-p)
1191 (ext:info variable kind symbol)
1192 (declare (ignore kind))
1193 (if (or (boundp symbol) recorded-p)
1194 (doc 'variable))))
1195 (maybe-push
1196 :generic-function
1197 (if (and (fboundp symbol)
1198 (typep (fdefinition symbol) 'generic-function))
1199 (doc 'function)))
1200 (maybe-push
1201 :function (if (and (fboundp symbol)
1202 (not (typep (fdefinition symbol) 'generic-function)))
1203 (doc 'function)))
1204 (maybe-push
1205 :setf (if (or (ext:info setf inverse symbol)
1206 (ext:info setf expander symbol))
1207 (doc 'setf)))
1208 (maybe-push
1209 :type (if (ext:info type kind symbol)
1210 (doc 'type)))
1211 (maybe-push
1212 :class (if (find-class symbol nil)
1213 (doc 'class)))
1214 (maybe-push
1215 :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
1216 (doc 'alien-type)))
1217 (maybe-push
1218 :alien-struct (if (ext:info alien-type struct symbol)
1219 (doc nil)))
1220 (maybe-push
1221 :alien-union (if (ext:info alien-type union symbol)
1222 (doc nil)))
1223 (maybe-push
1224 :alien-enum (if (ext:info alien-type enum symbol)
1225 (doc nil)))
1226 result)))
1227
1228 (defimplementation describe-definition (symbol namespace)
1229 (describe (ecase namespace
1230 (:variable
1231 symbol)
1232 ((:function :generic-function)
1233 (symbol-function symbol))
1234 (:setf
1235 (or (ext:info setf inverse symbol)
1236 (ext:info setf expander symbol)))
1237 (:type
1238 (kernel:values-specifier-type symbol))
1239 (:class
1240 (find-class symbol))
1241 (:alien-struct
1242 (ext:info :alien-type :struct symbol))
1243 (:alien-union
1244 (ext:info :alien-type :union symbol))
1245 (:alien-enum
1246 (ext:info :alien-type :enum symbol))
1247 (:alien-type
1248 (ecase (ext:info :alien-type :kind symbol)
1249 (:primitive
1250 (let ((alien::*values-type-okay* t))
1251 (funcall (ext:info :alien-type :translator symbol)
1252 (list symbol))))
1253 ((:defined)
1254 (ext:info :alien-type :definition symbol))
1255 (:unknown
1256 (return-from describe-definition
1257 (format nil "Unknown alien type: ~S" symbol))))))))
1258
1259 ;;;;; Argument lists
1260
1261 (defimplementation arglist (symbol)
1262 (let* ((fun (or (macro-function symbol)
1263 (symbol-function symbol)))
1264 (arglist
1265 (cond ((eval:interpreted-function-p fun)
1266 (eval:interpreted-function-arglist fun))
1267 ((pcl::generic-function-p fun)
1268 (pcl:generic-function-lambda-list fun))
1269 ((c::byte-function-or-closure-p fun)
1270 (byte-code-function-arglist fun))
1271 ((kernel:%function-arglist (kernel:%function-self fun))
1272 (handler-case (read-arglist fun)
1273 (error () :not-available)))
1274 ;; this should work both for compiled-debug-function
1275 ;; and for interpreted-debug-function
1276 (t
1277 (handler-case (debug-function-arglist
1278 (di::function-debug-function fun))
1279 (di:unhandled-condition () :not-available))))))
1280 (check-type arglist (or list (member :not-available)))
1281 arglist))
1282
1283 ;;; A simple case: the arglist is available as a string that we can
1284 ;;; `read'.
1285
1286 (defun read-arglist (fn)
1287 "Parse the arglist-string of the function object FN."
1288 (let ((string (kernel:%function-arglist
1289 (kernel:%function-self fn)))
1290 (package (find-package
1291 (c::compiled-debug-info-package
1292 (kernel:%code-debug-info
1293 (vm::find-code-object fn))))))
1294 (with-standard-io-syntax
1295 (let ((*package* (or package *package*)))
1296 (read-from-string string)))))
1297
1298 ;;; A harder case: an approximate arglist is derived from available
1299 ;;; debugging information.
1300
1301 (defun debug-function-arglist (debug-function)
1302 "Derive the argument list of DEBUG-FUNCTION from debug info."
1303 (let ((args (di::debug-function-lambda-list debug-function))
1304 (required '())
1305 (optional '())
1306 (rest '())
1307 (key '()))
1308 ;; collect the names of debug-vars
1309 (dolist (arg args)
1310 (etypecase arg
1311 (di::debug-variable
1312 (push (di::debug-variable-symbol arg) required))
1313 ((member :deleted)
1314 (push ':deleted required))
1315 (cons
1316 (ecase (car arg)
1317 (:keyword
1318 (push (second arg) key))
1319 (:optional
1320 (push (debug-variable-symbol-or-deleted (second arg)) optional))
1321 (:rest
1322 (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
1323 ;; intersperse lambda keywords as needed
1324 (append (nreverse required)
1325 (if optional (cons '&optional (nreverse optional)))
1326 (if rest (cons '&rest (nreverse rest)))
1327 (if key (cons '&key (nreverse key))))))
1328
1329 (defun debug-variable-symbol-or-deleted (var)
1330 (etypecase var
1331 (di:debug-variable
1332 (di::debug-variable-symbol var))
1333 ((member :deleted)
1334 '#:deleted)))
1335
1336 (defun symbol-debug-function-arglist (fname)
1337 "Return FNAME's debug-function-arglist and %function-arglist.
1338 A utility for debugging DEBUG-FUNCTION-ARGLIST."
1339 (let ((fn (fdefinition fname)))
1340 (values (debug-function-arglist (di::function-debug-function fn))
1341 (kernel:%function-arglist (kernel:%function-self fn)))))
1342
1343 ;;; Deriving arglists for byte-compiled functions:
1344 ;;;
1345 (defun byte-code-function-arglist (fn)
1346 ;; There doesn't seem to be much arglist information around for
1347 ;; byte-code functions. Use the arg-count and return something like
1348 ;; (arg0 arg1 ...)
1349 (etypecase fn
1350 (c::simple-byte-function
1351 (loop for i from 0 below (c::simple-byte-function-num-args fn)
1352 collect (make-arg-symbol i)))
1353 (c::hairy-byte-function
1354 (hairy-byte-function-arglist fn))
1355 (c::byte-closure
1356 (byte-code-function-arglist (c::byte-closure-function fn)))))
1357
1358 (defun make-arg-symbol (i)
1359 (make-symbol (format nil "~A~D" (string 'arg) i)))
1360
1361 ;;; A "hairy" byte-function is one that takes a variable number of
1362 ;;; arguments. `hairy-byte-function' is a type from the bytecode
1363 ;;; interpreter.
1364 ;;;
1365 (defun hairy-byte-function-arglist (fn)
1366 (let ((counter -1))
1367 (flet ((next-arg () (make-arg-symbol (incf counter))))
1368 (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
1369 keywords-p keywords) fn
1370 (let ((arglist '())
1371 (optional (- max-args min-args)))
1372 ;; XXX isn't there a better way to write this?
1373 ;; (Looks fine to me. -luke)
1374 (dotimes (i min-args)
1375 (push (next-arg) arglist))
1376 (when (plusp optional)
1377 (push '&optional arglist)
1378 (dotimes (i optional)
1379 (push (next-arg) arglist)))
1380 (when rest-arg-p
1381 (push '&rest arglist)
1382 (push (next-arg) arglist))
1383 (when keywords-p
1384 (push '&key arglist)
1385 (loop for (key _ __) in keywords
1386 do (push key arglist))
1387 (when (eq keywords-p :allow-others)
1388 (push '&allow-other-keys arglist)))
1389 (nreverse arglist))))))
1390
1391
1392 ;;;; Miscellaneous.
1393
1394 (defimplementation macroexpand-all (form)
1395 (walker:macroexpand-all form))
1396
1397 (defimplementation set-default-directory (directory)
1398 (setf (ext:default-directory) (namestring directory))
1399 ;; Setting *default-pathname-defaults* to an absolute directory
1400 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
1401 (setf *default-pathname-defaults* (pathname (ext:default-directory)))
1402 (namestring (ext:default-directory)))
1403
1404 (defimplementation call-without-interrupts (fn)
1405 (sys:without-interrupts (funcall fn)))
1406
1407 (defimplementation getpid ()
1408 (unix:unix-getpid))
1409
1410 (defimplementation lisp-implementation-type-name ()
1411 "cmucl")
1412
1413 (defimplementation quit-lisp ()
1414 (ext::quit))
1415
1416 ;;; source-path-{stream,file,string,etc}-position moved into
1417 ;;; swank-source-path-parser
1418
1419
1420 ;;;; Debugging
1421
1422 (defvar *sldb-stack-top*)
1423
1424 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1425 (unix:unix-sigsetmask 0)
1426 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
1427 (debug:*stack-top-hint* nil))
1428 (handler-bind ((di:debug-condition
1429 (lambda (condition)
1430 (signal (make-condition
1431 'sldb-condition
1432 :original-condition condition)))))
1433 (funcall debugger-loop-fn))))
1434
1435 (defun nth-frame (index)
1436 (do ((frame *sldb-stack-top* (di:frame-down frame))
1437 (i index (1- i)))
1438 ((zerop i) frame)))
1439
1440 (defimplementation compute-backtrace (start end)
1441 (let ((end (or end most-positive-fixnum)))
1442 (loop for f = (nth-frame start) then (di:frame-down f)
1443 for i from start below end
1444 while f
1445 collect f)))
1446
1447 (defimplementation print-frame (frame stream)
1448 (let ((*standard-output* stream))
1449 (debug::print-frame-call frame :verbosity 1 :number nil)))
1450
1451 (defimplementation frame-source-location-for-emacs (index)
1452 (code-location-source-location (di:frame-code-location (nth-frame index))))
1453
1454 (defimplementation eval-in-frame (form index)
1455 (di:eval-in-frame (nth-frame index) form))
1456
1457 (defimplementation frame-locals (index)
1458 (let* ((frame (nth-frame index))
1459 (location (di:frame-code-location frame))
1460 (debug-function (di:frame-debug-function frame))
1461 (debug-variables (di::debug-function-debug-variables debug-function)))
1462 (loop for v across debug-variables collect
1463 (list :name (di:debug-variable-symbol v)
1464 :id (di:debug-variable-id v)
1465 :value (ecase (di:debug-variable-validity v location)
1466 (:valid
1467 (di:debug-variable-value v frame))
1468 ((:invalid :unknown)
1469 ':not-available))))))
1470
1471 (defimplementation frame-catch-tags (index)
1472 (mapcar #'car (di:frame-catches (nth-frame index))))
1473
1474 (defun set-step-breakpoints (frame)
1475 (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1476 (di:frame-code-location frame)))
1477 (error "Cannot step, in elsewhere code~%"))
1478 (let* ((code-location (di:frame-code-location frame))
1479 (debug::*bad-code-location-types*
1480 (remove :call-site debug::*bad-code-location-types*))
1481 (next (debug::next-code-locations code-location)))
1482 (cond (next
1483 (let ((steppoints '()))
1484 (flet ((hook (frame breakpoint)
1485 (let ((debug:*stack-top-hint* frame))
1486 (mapc #'di:delete-breakpoint steppoints)
1487 (let ((cl (di::breakpoint-what breakpoint)))
1488 (break "Breakpoint: ~S ~S"
1489 (di:code-location-kind cl)
1490 (di::compiled-code-location-pc cl))))))
1491 (dolist (code-location next)
1492 (let ((bp (di:make-breakpoint #'hook code-location
1493 :kind :code-location)))
1494 (di:activate-breakpoint bp)
1495 (push bp steppoints))))))
1496 (t
1497 (flet ((hook (frame breakpoint values cookie)
1498 (declare (ignore cookie))
1499 (di:delete-breakpoint breakpoint)
1500 (let ((debug:*stack-top-hint* frame))
1501 (break "Function-end: ~A ~A" breakpoint values))))
1502 (let* ((debug-function (di:frame-debug-function frame))
1503 (bp (di:make-breakpoint #'hook debug-function
1504 :kind :function-end)))
1505 (di:activate-breakpoint bp)))))))
1506
1507 ;; (defslimefun sldb-step (frame)
1508 ;; (cond ((find-restart 'continue *swank-debugger-condition*)
1509 ;; (set-step-breakpoints (nth-frame frame))
1510 ;; (continue *swank-debugger-condition*))
1511 ;; (t
1512 ;; (error "Cannot continue in from condition: ~A"
1513 ;; *swank-debugger-condition*))))
1514
1515 (defun frame-cfp (frame)
1516 "Return the Control-Stack-Frame-Pointer for FRAME."
1517 (etypecase frame
1518 (di::compiled-frame (di::frame-pointer frame))
1519 ((or di::interpreted-frame null) -1)))
1520
1521 (defun frame-ip (frame)
1522 "Return the (absolute) instruction pointer and the relative pc of FRAME."
1523 (if (not frame)
1524 -1
1525 (let ((debug-fun (di::frame-debug-function frame)))
1526 (etypecase debug-fun
1527 (di::compiled-debug-function
1528 (let* ((code-loc (di:frame-code-location frame))
1529 (component (di::compiled-debug-function-component debug-fun))
1530 (pc (di::compiled-code-location-pc code-loc))
1531 (ip (sys:without-gcing
1532 (sys:sap-int
1533 (sys:sap+ (kernel:code-instructions component) pc)))))
1534 (values ip pc)))
1535 ((or di::bogus-debug-function di::interpreted-debug-function)
1536 -1)))))
1537
1538 (defun frame-registers (frame)
1539 "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1540 (let* ((cfp (frame-cfp frame))
1541 (csp (frame-cfp (di::frame-up frame)))
1542 (ip (frame-ip frame))
1543 (ocfp (frame-cfp (di::frame-down frame)))
1544 (lra (frame-ip (di::frame-down frame))))
1545 (values csp cfp ip ocfp lra)))
1546
1547 (defun print-frame-registers (frame-number)
1548 (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1549 (flet ((fixnum (p) (etypecase p
1550 (integer p)
1551 (sys:system-area-pointer (sys:sap-int p)))))
1552 (apply #'format t "~
1553 CSP = ~X
1554 CFP = ~X
1555 IP = ~X
1556 OCFP = ~X
1557 LRA = ~X~%" (mapcar #'fixnum
1558 (multiple-value-list (frame-registers frame)))))))
1559
1560
1561 (defimplementation disassemble-frame (frame-number)
1562 "Return a string with the disassembly of frames code."
1563 (print-frame-registers frame-number)
1564 (terpri)
1565 (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1566 (debug-fun (di::frame-debug-function frame)))
1567 (etypecase debug-fun
1568 (di::compiled-debug-function
1569 (let* ((component (di::compiled-debug-function-component debug-fun))
1570 (fun (di:debug-function-function debug-fun)))
1571 (if fun
1572 (disassemble fun)
1573 (disassem:disassemble-code-component component))))
1574 (di::bogus-debug-function
1575 (format t "~%[Disassembling bogus frames not implemented]")))))
1576
1577
1578 ;;;; Inspecting
1579
1580 (defconstant +lowtag-symbols+
1581 '(vm:even-fixnum-type
1582 vm:function-pointer-type
1583 vm:other-immediate-0-type
1584 vm:list-pointer-type
1585 vm:odd-fixnum-type
1586 vm:instance-pointer-type
1587 vm:other-immediate-1-type
1588 vm:other-pointer-type)
1589 "Names of the constants that specify type tags.
1590 The `symbol-value' of each element is a type tag.")
1591
1592 (defconstant +header-type-symbols+
1593 (flet ((suffixp (suffix string)
1594 (and (>= (length string) (length suffix))
1595 (string= string suffix :start1 (- (length string)
1596 (length suffix))))))
1597 ;; Is there a convinient place for all those constants?
1598 (remove-if-not
1599 (lambda (x) (and (suffixp "-TYPE" (symbol-name x))
1600 (not (member x +lowtag-symbols+))
1601 (boundp x)
1602 (typep (symbol-value x) 'fixnum)))
1603 (append (apropos-list "-TYPE" "VM" t)
1604 (apropos-list "-TYPE" "BIGNUM" t))))
1605 "A list of names of the type codes in boxed objects.")
1606
1607 (defimplementation describe-primitive-type (object)
1608 (with-output-to-string (*standard-output*)
1609 (let* ((lowtag (kernel:get-lowtag object))
1610 (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1611 (format t "lowtag: ~A" lowtag-symbol)
1612 (when (member lowtag (list vm:other-pointer-type
1613 vm:function-pointer-type
1614 vm:other-immediate-0-type
1615 vm:other-immediate-1-type
1616 ))
1617 (let* ((type (kernel:get-type object))
1618 (type-symbol (find type +header-type-symbols+
1619 :key #'symbol-value)))
1620 (format t ", type: ~A" type-symbol))))))
1621
1622 (defimplementation inspected-parts (o)
1623 (cond ((di::indirect-value-cell-p o)
1624 (inspected-parts-of-value-cell o))
1625 (t
1626 (destructuring-bind (text labeledp . parts)
1627 (inspect::describe-parts o)
1628 (let ((parts (if labeledp
1629 (loop for (label . value) in parts
1630 collect (cons (string label) value))
1631 (loop for value in parts
1632 for i from 0
1633 collect (cons (format nil "~D" i) value)))))
1634 (values text parts))))))
1635
1636 (defun inspected-parts-of-value-cell (o)
1637 (values (format nil "~A~% is a value cell." o)
1638 (list (cons "Value" (c:value-cell-ref o)))))
1639
1640 (defmethod inspected-parts ((o function))
1641 (let ((header (kernel:get-type o)))
1642 (cond ((= header vm:function-header-type)
1643 (values
1644 (format nil "~A~% is a function." o)
1645 (list (cons "Self" (kernel:%function-self o))
1646 (cons "Next" (kernel:%function-next o))
1647 (cons "Name" (kernel:%function-name o))
1648 (cons "Arglist" (kernel:%function-arglist o))
1649 (cons "Type" (kernel:%function-type o))
1650 (cons "Code Object" (kernel:function-code-header o)))))
1651 ((= header vm:closure-header-type)
1652 (values (format nil "~A~% is a closure." o)
1653 (list*
1654 (cons "Function" (kernel:%closure-function o))
1655 (loop for i from 0 below (- (kernel:get-closure-length o)
1656 (1- vm:closure-info-offset))
1657 collect (cons (format nil "~D" i)
1658 (kernel:%closure-index-ref o i))))))
1659 (t (call-next-method o)))))
1660
1661 (defmethod inspected-parts ((o kernel:code-component))
1662 (values (format nil "~A~% is a code data-block." o)
1663 `(("First entry point" . ,(kernel:%code-entry-points o))
1664 ,@(loop for i from vm:code-constants-offset
1665 below (kernel:get-header-data o)
1666 collect (cons (format nil "Constant#~D" i)
1667 (kernel:code-header-ref o i)))
1668 ("Debug info" . ,(kernel:%code-debug-info o))
1669 ("Instructions" . ,(kernel:code-instructions o)))))
1670
1671 (defmethod inspected-parts ((o kernel:fdefn))
1672 (values (format nil "~A~% is a fdefn object." o)
1673 `(("Name" . ,(kernel:fdefn-name o))
1674 ("Function" . ,(kernel:fdefn-function o)))))
1675
1676
1677 ;;;; Profiling
1678 (defimplementation profile (fname)
1679 (eval `(profile:profile ,fname)))
1680
1681 (defimplementation unprofile (fname)
1682 (eval `(profile:unprofile ,fname)))
1683
1684 (defimplementation unprofile-all ()
1685 (eval '(profile:unprofile))
1686 "All functions unprofiled.")
1687
1688 (defimplementation profile-report ()
1689 (eval '(profile:report-time)))
1690
1691 (defimplementation profile-reset ()
1692 (eval '(profile:reset-time))
1693 "Reset profiling counters.")
1694
1695 (defimplementation profiled-functions ()
1696 profile:*timed-functions*)
1697
1698 (defimplementation profile-package (package callers methods)
1699 (profile:profile-all :package package
1700 :callers-p callers
1701 :methods methods))
1702
1703
1704 ;;;; Multiprocessing
1705
1706 #+mp
1707 (progn
1708 (defimplementation startup-multiprocessing ()
1709 ;; Threads magic: this never returns! But top-level becomes
1710 ;; available again.
1711 (mp::startup-idle-and-top-level-loops))
1712
1713 (defimplementation spawn (fn &key (name "Anonymous"))
1714 (mp:make-process fn :name name))
1715
1716 (defimplementation thread-name (thread)
1717 (mp:process-name thread))
1718
1719 (defimplementation thread-status (thread)
1720 (mp:process-whostate thread))
1721
1722 (defimplementation current-thread ()
1723 mp:*current-process*)
1724
1725 (defimplementation all-threads ()
1726 (copy-list mp:*all-processes*))
1727
1728 (defimplementation interrupt-thread (thread fn)
1729 (mp:process-interrupt thread fn))
1730
1731 (defimplementation kill-thread (thread)
1732 (mp:destroy-process thread))
1733
1734 (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
1735
1736 (defstruct (mailbox (:conc-name mailbox.))
1737 (mutex (mp:make-lock "process mailbox"))
1738 (queue '() :type list))
1739
1740 (defun mailbox (thread)
1741 "Return THREAD's mailbox."
1742 (mp:with-lock-held (*mailbox-lock*)
1743 (or (getf (mp:process-property-list thread) 'mailbox)
1744 (setf (getf (mp:process-property-list thread) 'mailbox)
1745 (make-mailbox)))))
1746
1747 (defimplementation send (thread message)
1748 (let* ((mbox (mailbox thread))
1749 (mutex (mailbox.mutex mbox)))
1750 (mp:with-lock-held (mutex)
1751 (setf (mailbox.queue mbox)
1752 (nconc (mailbox.queue mbox) (list message))))))
1753
1754 (defimplementation receive ()
1755 (let* ((mbox (mailbox mp:*current-process*))
1756 (mutex (mailbox.mutex mbox)))
1757 (mp:process-wait "receive" #'mailbox.queue mbox)
1758 (mp:with-lock-held (mutex)
1759 (pop (mailbox.queue mbox)))))
1760
1761 ) ;; #+mp
1762
1763 ;; Local Variables:
1764 ;; pbook-heading-regexp: "^;;;\\(;+\\)"
1765 ;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"
1766 ;; End:

  ViewVC Help
Powered by ViewVC 1.1.5