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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.105 - (hide annotations)
Mon Jun 7 18:37:54 2004 UTC (9 years, 10 months ago) by lgorrie
Branch: MAIN
Changes since 1.104: +38 -30 lines
Minor refactorings.
1 lgorrie 1.103 ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2     ;;;
3     ;;;; Introduction
4     ;;;
5     ;;; This is the CMUCL implementation of the `swank-backend' package.
6 dbarlow 1.1
7 heller 1.80 (in-package :swank-backend)
8 dbarlow 1.1
9 lgorrie 1.103 ;;;; "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 heller 1.67 (in-package :lisp)
19    
20 lgorrie 1.103 ;;; `READ-SEQUENCE' with large sequences has problems in 18e. This new
21     ;;; definition works better.
22    
23 heller 1.67 #+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 heller 1.79 (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 heller 1.67
52     (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
53     (when s
54     (setf (symbol-value s) t)))
55    
56     )
57    
58 heller 1.80 (in-package :swank-backend)
59 heller 1.67
60 lgorrie 1.25
61 lgorrie 1.103 ;;;; 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 lgorrie 1.25
69 heller 1.80 (defimplementation preferred-communication-style ()
70     :sigio)
71 heller 1.48
72 heller 1.63 (defimplementation create-socket (host port)
73 heller 1.64 (ext:create-inet-listener port :stream
74 heller 1.63 :reuse-address t
75     :host (resolve-hostname host)))
76 heller 1.47
77 lgorrie 1.56 (defimplementation local-port (socket)
78 heller 1.47 (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
79    
80 lgorrie 1.56 (defimplementation close-socket (socket)
81 heller 1.47 (ext:close-socket (socket-fd socket)))
82    
83 lgorrie 1.56 (defimplementation accept-connection (socket)
84 heller 1.91 #+mp (mp:process-wait-until-fd-usable socket :input)
85 heller 1.47 (make-socket-io-stream (ext:accept-tcp-connection socket)))
86    
87 lgorrie 1.103 ;;;;; 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 heller 1.59 (defvar *sigio-handlers* '()
108 lgorrie 1.103 "List of (key . function) pairs.
109     All functions are called on SIGIO, and the key is used for removing
110     specific functions.")
111 heller 1.59
112     (defun set-sigio-handler ()
113 heller 1.101 (sys:enable-interrupt :sigio (lambda (signal code scp)
114     (sigio-handler signal code scp))))
115 heller 1.59
116 lgorrie 1.103 (defun sigio-handler (signal code scp)
117     (declare (ignore signal code scp))
118     (mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
119    
120 heller 1.68 (defun fcntl (fd command arg)
121 lgorrie 1.103 "fcntl(2) - manipulate a file descriptor."
122 heller 1.68 (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
123 lgorrie 1.103 (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error)))))
124 heller 1.68
125     (defimplementation add-sigio-handler (socket fn)
126     (set-sigio-handler)
127 heller 1.59 (let ((fd (socket-fd socket)))
128 heller 1.68 (format *debug-io* "; Adding input handler: ~S ~%" fd)
129     (fcntl fd unix:f-setown (unix:unix-getpid))
130 heller 1.92 (fcntl fd unix:f-setfl unix:fasync)
131 heller 1.68 (push (cons fd fn) *sigio-handlers*)))
132 lgorrie 1.45
133 heller 1.68 (defimplementation remove-sigio-handlers (socket)
134 heller 1.59 (let ((fd (socket-fd socket)))
135 lgorrie 1.103 (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
136 heller 1.68 (sys:invalidate-descriptor fd))
137 heller 1.50 (close socket))
138    
139 lgorrie 1.103 ;;;;; SERVE-EVENT
140    
141 heller 1.68 (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 lgorrie 1.103
152     ;;;; Stream handling
153     ;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
154    
155 lgorrie 1.56 (defimplementation make-fn-streams (input-fn output-fn)
156 lgorrie 1.45 (let* ((output (make-slime-output-stream output-fn))
157     (input (make-slime-input-stream input-fn output)))
158     (values input output)))
159 lgorrie 1.25
160 dbarlow 1.1 (defstruct (slime-output-stream
161 lgorrie 1.45 (: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 heller 1.16 (buffer (make-string 512) :type string)
170     (index 0 :type kernel:index)
171     (column 0 :type kernel:index))
172    
173 heller 1.17 (defun %print-slime-output-stream (s stream d)
174     (declare (ignore d))
175     (print-unreadable-object (s stream :type t :identity t)))
176    
177 heller 1.16 (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 heller 1.21 (when (char= #\newline char)
184     (setf (sos.column stream) 0))
185     (when (= index (1- (length buffer)))
186     (force-output stream)))
187 heller 1.16 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 lgorrie 1.45
193 heller 1.16 (defun sos/misc (stream operation &optional arg1 arg2)
194     (declare (ignore arg1 arg2))
195 dbarlow 1.1 (case operation
196 heller 1.17 ((:force-output :finish-output)
197 heller 1.16 (let ((end (sos.index stream)))
198     (unless (zerop end)
199 lgorrie 1.45 (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end))
200     (setf (sos.index stream) 0))))
201 heller 1.16 (:charpos (sos.column stream))
202     (:line-length 75)
203 dbarlow 1.1 (:file-position nil)
204 heller 1.16 (:element-type 'base-char)
205     (:get-command nil)
206 heller 1.22 (:close nil)
207 heller 1.16 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
208 dbarlow 1.1
209 heller 1.9 (defstruct (slime-input-stream
210 lgorrie 1.45 (: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 heller 1.16
223     (defun sis/in (stream eof-errorp eof-value)
224 heller 1.18 (declare (ignore eof-errorp eof-value))
225 heller 1.16 (let ((index (sis.index stream))
226     (buffer (sis.buffer stream)))
227     (when (= index (length buffer))
228 lgorrie 1.45 (force-output (sis.sos stream))
229     (setf buffer (funcall (sis.input-fn stream)))
230 heller 1.16 (setf (sis.buffer stream) buffer)
231     (setf index 0))
232     (prog1 (aref buffer index)
233     (setf (sis.index stream) (1+ index)))))
234 heller 1.9
235 heller 1.16 (defun sis/misc (stream operation &optional arg1 arg2)
236 heller 1.14 (declare (ignore arg2))
237 heller 1.15 (ecase operation
238     (:file-position nil)
239 heller 1.16 (:file-length nil)
240     (:unread (setf (aref (sis.buffer stream)
241     (decf (sis.index stream)))
242     arg1))
243 heller 1.57 (:clear-input
244     (setf (sis.index stream) 0
245 heller 1.16 (sis.buffer stream) ""))
246     (:listen (< (sis.index stream) (length (sis.buffer stream))))
247     (:charpos nil)
248     (:line-length nil)
249     (:get-command nil)
250 heller 1.22 (:element-type 'base-char)
251     (:close nil)))
252 heller 1.16
253 lgorrie 1.25
254 dbarlow 1.1 ;;;; Compilation Commands
255    
256 lgorrie 1.24 (defvar *previous-compiler-condition* nil
257     "Used to detect duplicates.")
258    
259     (defvar *previous-context* nil
260     "Previous compiler error context.")
261    
262 lgorrie 1.103 (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 heller 1.30 (defvar *buffer-start-position* nil)
267     (defvar *buffer-substring* nil)
268    
269 lgorrie 1.103 (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 lgorrie 1.25
302 lgorrie 1.24 ;;;;; Trapping notes
303 lgorrie 1.103 ;;;
304     ;;; We intercept conditions from the compiler and resignal them as
305     ;;; `SWANK:COMPILER-CONDITION's.
306 lgorrie 1.24
307     (defun handle-notification-condition (condition)
308 lgorrie 1.103 "Handle a condition caused by a compiler warning."
309 dbarlow 1.1 (unless (eq condition *previous-compiler-condition*)
310 heller 1.65 (let ((context (c::find-error-context nil)))
311 dbarlow 1.1 (setq *previous-compiler-condition* condition)
312     (setq *previous-context* context)
313 lgorrie 1.24 (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 heller 1.65 :short-message (brief-compiler-message-for-emacs condition)
321     :message (long-compiler-message-for-emacs condition context)
322 lgorrie 1.24 :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 heller 1.65 (defun brief-compiler-message-for-emacs (condition)
332 lgorrie 1.24 "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 heller 1.65 (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 lgorrie 1.24 (declare (type (or c::compiler-error-context null) error-context))
341 heller 1.30 (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 lgorrie 1.103 "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 heller 1.30
384 lgorrie 1.103 (defun unix-truename (pathname)
385     (ext:unix-namestring (truename pathname)))
386 dbarlow 1.1
387 lgorrie 1.25
388     ;;;; XREF
389 lgorrie 1.103 ;;;
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 dbarlow 1.1
401 heller 1.81 (defmacro defxref (name function)
402     `(defimplementation ,name (name)
403 heller 1.82 (xref-results (,function name))))
404 heller 1.81
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 dbarlow 1.1
410 lgorrie 1.103 ;;; More types of XREF information were added since 18e:
411     ;;;
412 lgorrie 1.10 #+cmu19
413 heller 1.32 (progn
414 heller 1.81 (defxref who-macroexpands xref:who-macroexpands)
415     ;; XXX
416     (defimplementation who-specializes (symbol)
417     (let* ((methods (xref::who-specializes (find-class symbol)))
418 heller 1.86 (locations (mapcar #'method-location methods)))
419 heller 1.81 (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 heller 1.30
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 lgorrie 1.99 `(:error ,(format nil "Unknown source location: ~S ~S ~S "
440 heller 1.30 name file source-path))))))
441    
442 lgorrie 1.25 (defun clear-xref-info (namestring)
443 heller 1.66 "Clear XREF notes pertaining to NAMESTRING.
444 lgorrie 1.25 This is a workaround for a CMUCL bug: XREF records are cumulative."
445 heller 1.65 (when c:*record-xref-info*
446 heller 1.66 (let ((filename (truename namestring)))
447 lgorrie 1.25 (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 heller 1.66 ;; XXX update during traversal?
455 lgorrie 1.25 (setf (gethash target db)
456 heller 1.66 (delete filename contexts
457     :key #'xref:xref-context-file
458     :test #'equalp)))
459 lgorrie 1.25 db)))))
460    
461    
462     ;;;; Find callers and callees
463 lgorrie 1.103 ;;;
464 dbarlow 1.1 ;;; 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 heller 1.30 "Return FUNCTION's callees as a list of functions."
479 dbarlow 1.1 (let ((callees '()))
480     (map-code-constants
481     (vm::find-code-object function)
482     (lambda (obj)
483     (when (kernel:fdefn-p obj)
484 heller 1.30 (push (kernel:fdefn-function obj) callees))))
485 dbarlow 1.1 callees))
486    
487 heller 1.19 (declaim (ext:maybe-inline map-allocated-code-components))
488 dbarlow 1.1 (defun map-allocated-code-components (spaces fn)
489     "Call FN for each allocated code component in one of SPACES. FN
490 heller 1.19 receives the object as argument. SPACES should be a list of the
491     symbols :dynamic, :static, or :read-only."
492 dbarlow 1.1 (dolist (space spaces)
493 heller 1.18 (declare (inline vm::map-allocated-objects))
494 dbarlow 1.1 (vm::map-allocated-objects
495     (lambda (obj header size)
496 heller 1.19 (declare (type fixnum size) (ignore size))
497 dbarlow 1.1 (when (= vm:code-header-type header)
498 heller 1.19 (funcall fn obj)))
499 dbarlow 1.1 space)))
500    
501 heller 1.19 (declaim (ext:maybe-inline map-caller-code-components))
502 dbarlow 1.1 (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 heller 1.19 (declare (inline map-allocated-code-components))
507 dbarlow 1.1 (map-allocated-code-components
508     spaces
509 heller 1.19 (lambda (obj)
510 dbarlow 1.1 (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 heller 1.30 "Return FUNCTION's callers. The result is a list of code-objects."
521 dbarlow 1.1 (let ((referrers '()))
522 heller 1.19 (declare (inline map-caller-code-components))
523 heller 1.30 (ext:gc :full t)
524     (map-caller-code-components function spaces
525     (lambda (code) (push code referrers)))
526 dbarlow 1.1 referrers))
527 heller 1.80
528 heller 1.30 (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 heller 1.80 (list (list name
541     (make-location
542     (list :file (unix-truename (c::debug-source-name first)))
543     (list :function-name name)))))))))
544 heller 1.30
545     (defun code-component-entry-points (code)
546 heller 1.80 "Return a list ((NAME LOCATION) ...) of function definitons for
547 heller 1.30 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 heller 1.80 collect (list (kernel:%function-name e)
553 heller 1.86 (function-location e)))
554 heller 1.30 :test #'equal))
555 dbarlow 1.1
556 heller 1.80 (defimplementation list-callers (symbol)
557     "Return a list ((NAME LOCATION) ...) of callers."
558     (let ((components (function-callers symbol))
559 heller 1.30 (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 heller 1.80 xrefs))
569 dbarlow 1.1
570 heller 1.80 (defimplementation list-callees (symbol)
571     (let ((fns (function-callees symbol)))
572     (mapcar (lambda (fn)
573     (list (kernel:%function-name fn)
574 heller 1.86 (function-location fn)))
575 heller 1.80 fns)))
576 dbarlow 1.1
577 lgorrie 1.42
578 lgorrie 1.103 ;;;; 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 dbarlow 1.1
593 lgorrie 1.35 (defvar *debug-definition-finding* nil
594 dbarlow 1.1 "When true don't handle errors while looking for definitions.
595     This is useful when debugging the definition-finding code.")
596    
597 lgorrie 1.99 (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 lgorrie 1.103 (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 lgorrie 1.99 (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 lgorrie 1.103 reliable when the exact source is available, so we cache it in case it
782 lgorrie 1.99 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 lgorrie 1.103 "Return the source code for FILENAME as written on DATE in a string.
795 lgorrie 1.99 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 lgorrie 1.100 (let ((source (read-file filename)))
806     (setf (gethash filename *source-file-cache*)
807     (make-source-cache-entry source date))
808     source)
809 lgorrie 1.99 nil)))))
810    
811 lgorrie 1.103
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 lgorrie 1.100
877 lgorrie 1.103 (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 heller 1.88
884 dbarlow 1.1 (defun function-first-code-location (function)
885 lgorrie 1.103 "Return the first code-location we can find for FUNCTION."
886 dbarlow 1.1 (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 lgorrie 1.103
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 heller 1.83
913 heller 1.4 (defun struct-closure-p (function)
914 lgorrie 1.103 "Is FUNCTION a closure created by defstruct?"
915 heller 1.4 (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 dbarlow 1.1
919 lgorrie 1.103 (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 heller 1.4 (defun struct-closure-dd (function)
926 lgorrie 1.103 "Return the defstruct-definition (dd) of FUNCTION."
927 dbarlow 1.1 (assert (= (kernel:get-type function) vm:closure-header-type))
928 heller 1.4 (flet ((find-layout (function)
929     (sys:find-if-in-closure
930     (lambda (x)
931 heller 1.18 (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 heller 1.4 function)))
937     (kernel:layout-info (find-layout function))))
938 lgorrie 1.103
939 heller 1.86 (defun dd-location (dd)
940 lgorrie 1.103 "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 dbarlow 1.1 (let ((constructor (or (kernel:dd-default-constructor dd)
948 heller 1.32 (car (kernel::dd-constructors dd)))))
949 lgorrie 1.103 (when (or (null constructor)
950     (and (consp constructor) (null (car constructor))))
951     (error "Cannot find structure's constructor: ~S"
952 heller 1.32 (kernel::dd-name dd)))
953 lgorrie 1.103 (coerce (if (consp constructor) (first constructor) constructor)
954     'function)))
955    
956     ;;;;;; Generic functions and methods
957 dbarlow 1.1
958 lgorrie 1.103 (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 heller 1.101
967 lgorrie 1.103 (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 heller 1.83
971 lgorrie 1.103 (defun method-definition (method)
972     (list (method-dspec method)
973     (method-location method)))
974 heller 1.83
975     (defun method-dspec (method)
976 lgorrie 1.103 "Return a human-readable \"definition specifier\" for METHOD."
977 heller 1.83 (let* ((gf (pcl:method-generic-function method))
978     (name (pcl:generic-function-name gf))
979 heller 1.92 (specializers (pcl:method-specializers method))
980     (qualifiers (pcl:method-qualifiers method)))
981     `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
982 heller 1.83
983 lgorrie 1.103 ;; 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 heller 1.83
988 lgorrie 1.103 (defun genericp (fn)
989     (typep fn 'generic-function))
990 dbarlow 1.1
991 lgorrie 1.105 ;;;;;; Types and classes
992    
993     (defun type-definitions (name)
994     "Return `deftype' locations for type NAME."
995     (maybe-make-definition (ext:info :type :expander name) 'deftype name))
996    
997 heller 1.88 (defun maybe-make-definition (function kind name)
998 lgorrie 1.105 "If FUNCTION is non-nil then return its definition location."
999 heller 1.87 (if function
1000 heller 1.88 (list (list `(,kind ,name) (function-location function)))))
1001 heller 1.87
1002 lgorrie 1.105 (defun class-definitions (name)
1003     "Return the definition locations for the class called NAME."
1004     (if (symbolp name)
1005     (let ((class (kernel::find-class name nil)))
1006     (etypecase class
1007     (null '())
1008     (kernel::structure-class
1009     (list (list `(defstruct ,name) (dd-location (find-dd name)))))
1010     #+(or)
1011     (conditions::condition-class
1012     (list (list `(define-condition ,name)
1013     (condition-class-location class))))
1014     (kernel::standard-class
1015     (list (list `(defclass ,name)
1016     (class-location (find-class name)))))
1017     ((or kernel::built-in-class
1018     conditions::condition-class
1019     kernel:funcallable-structure-class)
1020     (list (list `(kernel::define-type-class ,name)
1021     `(:error
1022     ,(format nil "No source info for ~A" name)))))))))
1023    
1024     (defun class-location (class)
1025     "Return the `defclass' location for CLASS."
1026     (definition-source-location class (pcl:class-name class)))
1027 heller 1.86
1028     (defun find-dd (name)
1029 lgorrie 1.105 "Find the defstruct-definition by the name of its structure-class."
1030 heller 1.86 (let ((layout (ext:info :type :compiler-layout name)))
1031     (if layout
1032     (kernel:layout-info layout))))
1033    
1034 heller 1.92 (defun condition-class-location (class)
1035     (let ((slots (conditions::condition-class-slots class))
1036     (name (conditions::condition-class-name class)))
1037     (cond ((null slots)
1038     `(:error ,(format nil "No location info for condition: ~A" name)))
1039     (t
1040 lgorrie 1.105 ;; Find the class via one of its slot-reader methods.
1041 heller 1.92 (let* ((slot (first slots))
1042     (gf (fdefinition
1043     (first (conditions::condition-slot-readers slot)))))
1044     (method-location
1045     (first
1046     (pcl:compute-applicable-methods-using-classes
1047     gf (list (find-class name))))))))))
1048    
1049 heller 1.93 (defun make-name-in-file-location (file string)
1050     (multiple-value-bind (filename c)
1051     (ignore-errors
1052     (unix-truename (merge-pathnames (make-pathname :type "lisp")
1053     file)))
1054     (cond (filename (make-location `(:file ,filename)
1055     `(:function-name ,string)))
1056     (t (list :error (princ-to-string c))))))
1057 heller 1.92
1058 heller 1.95 (defun source-location-form-numbers (location)
1059     (c::decode-form-numbers (c::form-numbers-form-numbers location)))
1060    
1061     (defun source-location-tlf-number (location)
1062     (nth-value 0 (source-location-form-numbers location)))
1063    
1064     (defun source-location-form-number (location)
1065     (nth-value 1 (source-location-form-numbers location)))
1066    
1067 heller 1.93 (defun resolve-file-source-location (location)
1068     (let ((filename (c::file-source-location-pathname location))
1069 heller 1.95 (tlf-number (source-location-tlf-number location))
1070     (form-number (source-location-form-number location)))
1071 heller 1.93 (with-open-file (s filename)
1072     (let ((pos (form-number-stream-position tlf-number form-number s)))
1073     (make-location `(:file ,(unix-truename filename))
1074     `(:position ,(1+ pos)))))))
1075    
1076 heller 1.95 (defun resolve-stream-source-location (location)
1077     (let ((info (c::stream-source-location-user-info location))
1078     (tlf-number (source-location-tlf-number location))
1079     (form-number (source-location-form-number location)))
1080 heller 1.93 ;; XXX duplication in frame-source-location
1081     (assert (info-from-emacs-buffer-p info))
1082     (destructuring-bind (&key emacs-buffer emacs-buffer-string
1083     emacs-buffer-offset) info
1084     (with-input-from-string (s emacs-buffer-string)
1085     (let ((pos (form-number-stream-position tlf-number form-number s)))
1086     (make-location `(:buffer ,emacs-buffer)
1087     `(:position ,(+ emacs-buffer-offset pos))))))))
1088    
1089 heller 1.102 ;; XXX predicates for 18e backward compatibilty. Remove them when
1090     ;; we're 19a only.
1091 heller 1.96 (defun file-source-location-p (object)
1092     (when (fboundp 'c::file-source-location-p)
1093     (c::file-source-location-p object)))
1094    
1095     (defun stream-source-location-p (object)
1096     (when (fboundp 'c::stream-source-location-p)
1097     (c::stream-source-location-p object)))
1098    
1099 heller 1.102 (defun source-location-p (object)
1100     (or (file-source-location-p object)
1101     (stream-source-location-p object)))
1102    
1103     (defun resolve-source-location (location)
1104     (etypecase location
1105     ((satisfies file-source-location-p)
1106     (resolve-file-source-location location))
1107     ((satisfies stream-source-location-p)
1108     (resolve-stream-source-location location))))
1109    
1110 heller 1.93 (defun definition-source-location (object name)
1111     (let ((source (pcl::definition-source object)))
1112     (etypecase source
1113     (null
1114     `(:error ,(format nil "No source info for: ~A" object)))
1115 heller 1.102 ((satisfies source-location-p)
1116     (resolve-source-location source))
1117 heller 1.93 (pathname
1118     (make-name-in-file-location source name))
1119     (cons
1120     (destructuring-bind ((dg name) pathname) source
1121     (declare (ignore dg))
1122     (etypecase pathname
1123     (pathname (make-name-in-file-location pathname (string name)))
1124     (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
1125 heller 1.86
1126 heller 1.88 (defun setf-definitions (name)
1127     (let ((function (or (ext:info :setf :inverse name)
1128     (ext:info :setf :expander name))))
1129 heller 1.87 (if function
1130 heller 1.88 (list (list `(setf ,name)
1131 heller 1.87 (function-location (coerce function 'function)))))))
1132    
1133 heller 1.102
1134     (defun variable-location (symbol)
1135     (multiple-value-bind (location foundp)
1136     ;; XXX for 18e compatibilty. rewrite this when we drop 18e
1137     ;; support.
1138     (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
1139     (if (and foundp location)
1140     (resolve-source-location location)
1141     `(:error ,(format nil "No source info for variable ~S" symbol)))))
1142    
1143     (defun variable-definitions (name)
1144     (if (symbolp name)
1145     (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
1146     (if recorded-p
1147     (list (list `(variable ,kind ,name)
1148     (variable-location name)))))))
1149    
1150 heller 1.87 (defun compiler-macro-definitions (symbol)
1151     (maybe-make-definition (compiler-macro-function symbol)
1152     'define-compiler-macro
1153     symbol))
1154    
1155 heller 1.88 (defun source-transform-definitions (name)
1156     (maybe-make-definition (ext:info :function :source-transform name)
1157 heller 1.87 'c:def-source-transform
1158 heller 1.88 name))
1159 heller 1.87
1160 heller 1.88 (defun function-info-definitions (name)
1161     (let ((info (ext:info :function :info name)))
1162 heller 1.87 (if info
1163     (append (loop for transform in (c::function-info-transforms info)
1164 heller 1.88 collect (list `(c:deftransform ,name
1165 heller 1.87 ,(c::type-specifier
1166     (c::transform-type transform)))
1167     (function-location (c::transform-function
1168     transform))))
1169     (maybe-make-definition (c::function-info-derive-type info)
1170 heller 1.88 'c::derive-type name)
1171 heller 1.87 (maybe-make-definition (c::function-info-optimizer info)
1172 heller 1.88 'c::optimizer name)
1173 heller 1.87 (maybe-make-definition (c::function-info-ltn-annotate info)
1174 heller 1.88 'c::ltn-annotate name)
1175 heller 1.87 (maybe-make-definition (c::function-info-ir2-convert info)
1176 heller 1.88 'c::ir2-convert name)
1177 heller 1.87 (loop for template in (c::function-info-templates info)
1178     collect (list `(c::vop ,(c::template-name template))
1179     (function-location
1180     (c::vop-info-generator-function
1181     template))))))))
1182    
1183 heller 1.88 (defun ir1-translator-definitions (name)
1184     (maybe-make-definition (ext:info :function :ir1-convert name)
1185     'c:def-ir1-translator name))
1186    
1187 lgorrie 1.25
1188     ;;;; Documentation.
1189 dbarlow 1.1
1190 lgorrie 1.56 (defimplementation describe-symbol-for-emacs (symbol)
1191 dbarlow 1.1 (let ((result '()))
1192 lgorrie 1.24 (flet ((doc (kind)
1193     (or (documentation symbol kind) :not-documented))
1194     (maybe-push (property value)
1195     (when value
1196     (setf result (list* property value result)))))
1197 dbarlow 1.1 (maybe-push
1198     :variable (multiple-value-bind (kind recorded-p)
1199     (ext:info variable kind symbol)
1200     (declare (ignore kind))
1201     (if (or (boundp symbol) recorded-p)
1202     (doc 'variable))))
1203     (maybe-push
1204 heller 1.27 :generic-function
1205     (if (and (fboundp symbol)
1206     (typep (fdefinition symbol) 'generic-function))
1207     (doc 'function)))
1208     (maybe-push
1209     :function (if (and (fboundp symbol)
1210     (not (typep (fdefinition symbol) 'generic-function)))
1211     (doc 'function)))
1212 dbarlow 1.1 (maybe-push
1213     :setf (if (or (ext:info setf inverse symbol)
1214     (ext:info setf expander symbol))
1215     (doc 'setf)))
1216     (maybe-push
1217     :type (if (ext:info type kind symbol)
1218     (doc 'type)))
1219     (maybe-push
1220     :class (if (find-class symbol nil)
1221     (doc 'class)))
1222 heller 1.18 (maybe-push
1223     :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
1224     (doc 'alien-type)))
1225     (maybe-push
1226     :alien-struct (if (ext:info alien-type struct symbol)
1227     (doc nil)))
1228     (maybe-push
1229     :alien-union (if (ext:info alien-type union symbol)
1230     (doc nil)))
1231     (maybe-push
1232     :alien-enum (if (ext:info alien-type enum symbol)
1233     (doc nil)))
1234 lgorrie 1.24 result)))
1235 dbarlow 1.1
1236 heller 1.80 (defimplementation describe-definition (symbol namespace)
1237 lgorrie 1.103 (describe (ecase namespace
1238     (:variable
1239     symbol)
1240     ((:function :generic-function)
1241     (symbol-function symbol))
1242     (:setf
1243     (or (ext:info setf inverse symbol)
1244     (ext:info setf expander symbol)))
1245     (:type
1246     (kernel:values-specifier-type symbol))
1247     (:class
1248     (find-class symbol))
1249     (:alien-struct
1250     (ext:info :alien-type :struct symbol))
1251     (:alien-union
1252     (ext:info :alien-type :union symbol))
1253     (:alien-enum
1254     (ext:info :alien-type :enum symbol))
1255     (:alien-type
1256     (ecase (ext:info :alien-type :kind symbol)
1257     (:primitive
1258     (let ((alien::*values-type-okay* t))
1259 heller 1.80 (funcall (ext:info :alien-type :translator symbol)
1260 lgorrie 1.103 (list symbol))))
1261     ((:defined)
1262     (ext:info :alien-type :definition symbol))
1263     (:unknown
1264     (return-from describe-definition
1265     (format nil "Unknown alien type: ~S" symbol))))))))
1266    
1267     ;;;;; Argument lists
1268    
1269     (defimplementation arglist (symbol)
1270     (let* ((fun (or (macro-function symbol)
1271     (symbol-function symbol)))
1272     (arglist
1273     (cond ((eval:interpreted-function-p fun)
1274     (eval:interpreted-function-arglist fun))
1275     ((pcl::generic-function-p fun)
1276     (pcl:generic-function-lambda-list fun))
1277     ((c::byte-function-or-closure-p fun)
1278     (byte-code-function-arglist fun))
1279     ((kernel:%function-arglist (kernel:%function-self fun))
1280 heller 1.104 (handler-case (read-arglist fun)
1281     (error () :not-available)))
1282 lgorrie 1.103 ;; this should work both for compiled-debug-function
1283     ;; and for interpreted-debug-function
1284     (t
1285     (handler-case (debug-function-arglist
1286     (di::function-debug-function fun))
1287     (di:unhandled-condition () :not-available))))))
1288     (check-type arglist (or list (member :not-available)))
1289     arglist))
1290 heller 1.18
1291 lgorrie 1.103 ;;; A simple case: the arglist is available as a string that we can
1292     ;;; `read'.
1293    
1294     (defun read-arglist (fn)
1295     "Parse the arglist-string of the function object FN."
1296     (let ((string (kernel:%function-arglist
1297     (kernel:%function-self fn)))
1298     (package (find-package
1299     (c::compiled-debug-info-package
1300     (kernel:%code-debug-info
1301     (vm::find-code-object fn))))))
1302     (with-standard-io-syntax
1303     (let ((*package* (or package *package*)))
1304     (read-from-string string)))))
1305    
1306     ;;; A harder case: an approximate arglist is derived from available
1307     ;;; debugging information.
1308 heller 1.93
1309 heller 1.92 (defun debug-function-arglist (debug-function)
1310 lgorrie 1.103 "Derive the argument list of DEBUG-FUNCTION from debug info."
1311 heller 1.92 (let ((args (di::debug-function-lambda-list debug-function))
1312     (required '())
1313     (optional '())
1314     (rest '())
1315     (key '()))
1316     ;; collect the names of debug-vars
1317 heller 1.91 (dolist (arg args)
1318     (etypecase arg
1319     (di::debug-variable
1320 heller 1.93 (push (di::debug-variable-symbol arg) required))
1321 lgorrie 1.103 ((member :deleted)
1322 heller 1.93 (push ':deleted required))
1323 heller 1.91 (cons
1324     (ecase (car arg)
1325 heller 1.92 (:keyword
1326     (push (second arg) key))
1327     (:optional
1328 heller 1.93 (push (debug-variable-symbol-or-deleted (second arg)) optional))
1329 heller 1.92 (:rest
1330 heller 1.93 (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
1331 heller 1.92 ;; intersperse lambda keywords as needed
1332     (append (nreverse required)
1333     (if optional (cons '&optional (nreverse optional)))
1334     (if rest (cons '&rest (nreverse rest)))
1335     (if key (cons '&key (nreverse key))))))
1336    
1337 lgorrie 1.103 (defun debug-variable-symbol-or-deleted (var)
1338     (etypecase var
1339     (di:debug-variable
1340     (di::debug-variable-symbol var))
1341     ((member :deleted)
1342     '#:deleted)))
1343    
1344 heller 1.92 (defun symbol-debug-function-arglist (fname)
1345     "Return FNAME's debug-function-arglist and %function-arglist.
1346     A utility for debugging DEBUG-FUNCTION-ARGLIST."
1347     (let ((fn (fdefinition fname)))
1348     (values (debug-function-arglist (di::function-debug-function fn))
1349     (kernel:%function-arglist (kernel:%function-self fn)))))
1350 heller 1.91
1351 lgorrie 1.103 ;;; Deriving arglists for byte-compiled functions:
1352     ;;;
1353     (defun byte-code-function-arglist (fn)
1354     ;; There doesn't seem to be much arglist information around for
1355     ;; byte-code functions. Use the arg-count and return something like
1356     ;; (arg0 arg1 ...)
1357     (etypecase fn
1358     (c::simple-byte-function
1359     (loop for i from 0 below (c::simple-byte-function-num-args fn)
1360     collect (make-arg-symbol i)))
1361     (c::hairy-byte-function
1362     (hairy-byte-function-arglist fn))
1363     (c::byte-closure
1364     (byte-code-function-arglist (c::byte-closure-function fn)))))
1365 heller 1.97
1366 heller 1.101 (defun make-arg-symbol (i)
1367     (make-symbol (format nil "~A~D" (string 'arg) i)))
1368    
1369 lgorrie 1.103 ;;; A "hairy" byte-function is one that takes a variable number of
1370     ;;; arguments. `hairy-byte-function' is a type from the bytecode
1371     ;;; interpreter.
1372     ;;;
1373 heller 1.101 (defun hairy-byte-function-arglist (fn)
1374     (let ((counter -1))
1375     (flet ((next-arg () (make-arg-symbol (incf counter))))
1376     (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
1377     keywords-p keywords) fn
1378     (let ((arglist '())
1379     (optional (- max-args min-args)))
1380     ;; XXX isn't there a better way to write this?
1381 lgorrie 1.103 ;; (Looks fine to me. -luke)
1382 heller 1.101 (dotimes (i min-args)
1383     (push (next-arg) arglist))
1384     (when (plusp optional)
1385     (push '&optional arglist)
1386     (dotimes (i optional)
1387     (push (next-arg) arglist)))
1388     (when rest-arg-p
1389     (push '&rest arglist)
1390     (push (next-arg) arglist))
1391     (when keywords-p
1392     (push '&key arglist)
1393     (loop for (key _ __) in keywords
1394     do (push key arglist))
1395     (when (eq keywords-p :allow-others)
1396     (push '&allow-other-keys arglist)))
1397     (nreverse arglist))))))
1398 lgorrie 1.25
1399    
1400     ;;;; Miscellaneous.
1401 dbarlow 1.1
1402 lgorrie 1.56 (defimplementation macroexpand-all (form)
1403 lgorrie 1.24 (walker:macroexpand-all form))
1404 dbarlow 1.1
1405 mbaringer 1.90 (defimplementation set-default-directory (directory)
1406 lgorrie 1.25 (setf (ext:default-directory) (namestring directory))
1407     ;; Setting *default-pathname-defaults* to an absolute directory
1408     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
1409     (setf *default-pathname-defaults* (pathname (ext:default-directory)))
1410     (namestring (ext:default-directory)))
1411    
1412 lgorrie 1.103 (defimplementation call-without-interrupts (fn)
1413     (sys:without-interrupts (funcall fn)))
1414 heller 1.19
1415 lgorrie 1.103 (defimplementation getpid ()
1416     (unix:unix-getpid))
1417 lgorrie 1.99
1418 lgorrie 1.103 (defimplementation lisp-implementation-type-name ()
1419     "cmucl")
1420 heller 1.92
1421 lgorrie 1.103 (defimplementation quit-lisp ()
1422     (ext::quit))
1423 heller 1.19
1424 lgorrie 1.103 ;;; source-path-{stream,file,string,etc}-position moved into
1425     ;;; swank-source-path-parser
1426 dbarlow 1.1
1427    
1428 lgorrie 1.25 ;;;; Debugging
1429 dbarlow 1.1
1430     (defvar *sldb-stack-top*)
1431    
1432 lgorrie 1.56 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1433 dbarlow 1.1 (unix:unix-sigsetmask 0)
1434 lgorrie 1.25 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
1435 heller 1.75 (debug:*stack-top-hint* nil))
1436 dbarlow 1.1 (handler-bind ((di:debug-condition
1437     (lambda (condition)
1438 lgorrie 1.25 (signal (make-condition
1439     'sldb-condition
1440     :original-condition condition)))))
1441     (funcall debugger-loop-fn))))
1442 dbarlow 1.1
1443     (defun nth-frame (index)
1444     (do ((frame *sldb-stack-top* (di:frame-down frame))
1445     (i index (1- i)))
1446     ((zerop i) frame)))
1447    
1448 heller 1.80 (defimplementation compute-backtrace (start end)
1449 dbarlow 1.1 (let ((end (or end most-positive-fixnum)))
1450     (loop for f = (nth-frame start) then (di:frame-down f)
1451     for i from start below end
1452     while f
1453 heller 1.80 collect f)))
1454 dbarlow 1.1
1455 heller 1.80 (defimplementation print-frame (frame stream)
1456     (let ((*standard-output* stream))
1457     (debug::print-frame-call frame :verbosity 1 :number nil)))
1458 dbarlow 1.1
1459 lgorrie 1.56 (defimplementation frame-source-location-for-emacs (index)
1460 heller 1.29 (code-location-source-location (di:frame-code-location (nth-frame index))))
1461 dbarlow 1.1
1462 lgorrie 1.56 (defimplementation eval-in-frame (form index)
1463 lgorrie 1.26 (di:eval-in-frame (nth-frame index) form))
1464 heller 1.19
1465 lgorrie 1.56 (defimplementation frame-locals (index)
1466 dbarlow 1.1 (let* ((frame (nth-frame index))
1467     (location (di:frame-code-location frame))
1468     (debug-function (di:frame-debug-function frame))
1469     (debug-variables (di::debug-function-debug-variables debug-function)))
1470 heller 1.43 (loop for v across debug-variables collect
1471 heller 1.80 (list :name (di:debug-variable-symbol v)
1472 heller 1.43 :id (di:debug-variable-id v)
1473 mbaringer 1.77 :value (ecase (di:debug-variable-validity v location)
1474     (:valid
1475     (di:debug-variable-value v frame))
1476     ((:invalid :unknown)
1477 heller 1.80 ':not-available))))))
1478 dbarlow 1.1
1479 lgorrie 1.56 (defimplementation frame-catch-tags (index)
1480 heller 1.80 (mapcar #'car (di:frame-catches (nth-frame index))))
1481 heller 1.33
1482     (defun set-step-breakpoints (frame)
1483     (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1484     (di:frame-code-location frame)))
1485     (error "Cannot step, in elsewhere code~%"))
1486     (let* ((code-location (di:frame-code-location frame))
1487 heller 1.36 (debug::*bad-code-location-types*
1488     (remove :call-site debug::*bad-code-location-types*))
1489 heller 1.33 (next (debug::next-code-locations code-location)))
1490     (cond (next
1491     (let ((steppoints '()))
1492     (flet ((hook (frame breakpoint)
1493     (let ((debug:*stack-top-hint* frame))
1494 heller 1.36 (mapc #'di:delete-breakpoint steppoints)
1495     (let ((cl (di::breakpoint-what breakpoint)))
1496     (break "Breakpoint: ~S ~S"
1497     (di:code-location-kind cl)
1498     (di::compiled-code-location-pc cl))))))
1499 heller 1.33 (dolist (code-location next)
1500     (let ((bp (di:make-breakpoint #'hook code-location
1501     :kind :code-location)))
1502     (di:activate-breakpoint bp)
1503     (push bp steppoints))))))
1504     (t
1505     (flet ((hook (frame breakpoint values cookie)
1506     (declare (ignore cookie))
1507 heller 1.36 (di:delete-breakpoint breakpoint)
1508 heller 1.33 (let ((debug:*stack-top-hint* frame))
1509     (break "Function-end: ~A ~A" breakpoint values))))
1510     (let* ((debug-function (di:frame-debug-function frame))
1511     (bp (di:make-breakpoint #'hook debug-function
1512     :kind :function-end)))
1513     (di:activate-breakpoint bp)))))))
1514    
1515 heller 1.80 ;; (defslimefun sldb-step (frame)
1516     ;; (cond ((find-restart 'continue *swank-debugger-condition*)
1517     ;; (set-step-breakpoints (nth-frame frame))
1518     ;; (continue *swank-debugger-condition*))
1519     ;; (t
1520     ;; (error "Cannot continue in from condition: ~A"
1521     ;; *swank-debugger-condition*))))
1522 dbarlow 1.1
1523 heller 1.58 (defun frame-cfp (frame)
1524     "Return the Control-Stack-Frame-Pointer for FRAME."
1525     (etypecase frame
1526     (di::compiled-frame (di::frame-pointer frame))
1527     ((or di::interpreted-frame null) -1)))
1528    
1529     (defun frame-ip (frame)
1530     "Return the (absolute) instruction pointer and the relative pc of FRAME."
1531     (if (not frame)
1532     -1
1533     (let ((debug-fun (di::frame-debug-function frame)))
1534     (etypecase debug-fun
1535     (di::compiled-debug-function
1536     (let* ((code-loc (di:frame-code-location frame))
1537     (component (di::compiled-debug-function-component debug-fun))
1538     (pc (di::compiled-code-location-pc code-loc))
1539     (ip (sys:without-gcing
1540     (sys:sap-int
1541     (sys:sap+ (kernel:code-instructions component) pc)))))
1542     (values ip pc)))
1543     ((or di::bogus-debug-function di::interpreted-debug-function)
1544     -1)))))
1545    
1546     (defun frame-registers (frame)
1547     "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1548     (let* ((cfp (frame-cfp frame))
1549     (csp (frame-cfp (di::frame-up frame)))
1550     (ip (frame-ip frame))
1551     (ocfp (frame-cfp (di::frame-down frame)))
1552     (lra (frame-ip (di::frame-down frame))))
1553     (values csp cfp ip ocfp lra)))
1554    
1555     (defun print-frame-registers (frame-number)
1556     (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1557     (flet ((fixnum (p) (etypecase p
1558     (integer p)
1559     (sys:system-area-pointer (sys:sap-int p)))))
1560     (apply #'format t "~
1561     CSP = ~X
1562     CFP = ~X
1563     IP = ~X
1564     OCFP = ~X
1565     LRA = ~X~%" (mapcar #'fixnum
1566     (multiple-value-list (frame-registers frame)))))))
1567    
1568 heller 1.82
1569 heller 1.81 (defimplementation disassemble-frame (frame-number)
1570     "Return a string with the disassembly of frames code."
1571     (print-frame-registers frame-number)
1572     (terpri)
1573     (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1574     (debug-fun (di::frame-debug-function frame)))
1575     (etypecase debug-fun
1576     (di::compiled-debug-function
1577     (let* ((component (di::compiled-debug-function-component debug-fun))
1578     (fun (di:debug-function-function debug-fun)))
1579     (if fun
1580     (disassemble fun)
1581     (disassem:disassemble-code-component component))))
1582     (di::bogus-debug-function
1583     (format t "~%[Disassembling bogus frames not implemented]")))))
1584 heller 1.58
1585 dbarlow 1.1
1586 lgorrie 1.25 ;;;; Inspecting
1587 dbarlow 1.1
1588     (defconstant +lowtag-symbols+
1589     '(vm:even-fixnum-type
1590     vm:function-pointer-type
1591     vm:other-immediate-0-type
1592     vm:list-pointer-type
1593     vm:odd-fixnum-type
1594     vm:instance-pointer-type
1595     vm:other-immediate-1-type
1596 lgorrie 1.103 vm:other-pointer-type)
1597     "Names of the constants that specify type tags.
1598     The `symbol-value' of each element is a type tag.")
1599 dbarlow 1.1
1600     (defconstant +header-type-symbols+
1601 heller 1.102 (flet ((suffixp (suffix string)
1602     (and (>= (length string) (length suffix))
1603     (string= string suffix :start1 (- (length string)
1604     (length suffix))))))
1605     ;; Is there a convinient place for all those constants?
1606 dbarlow 1.1 (remove-if-not
1607 heller 1.102 (lambda (x) (and (suffixp "-TYPE" (symbol-name x))
1608     (not (member x +lowtag-symbols+))
1609     (boundp x)
1610     (typep (symbol-value x) 'fixnum)))
1611 dbarlow 1.1 (append (apropos-list "-TYPE" "VM" t)
1612 heller 1.102 (apropos-list "-TYPE" "BIGNUM" t))))
1613     "A list of names of the type codes in boxed objects.")
1614 heller 1.62
1615     (defimplementation describe-primitive-type (object)
1616 dbarlow 1.1 (with-output-to-string (*standard-output*)
1617     (let* ((lowtag (kernel:get-lowtag object))
1618     (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1619 heller 1.76 (format t "lowtag: ~A" lowtag-symbol)
1620     (when (member lowtag (list vm:other-pointer-type
1621     vm:function-pointer-type
1622     vm:other-immediate-0-type
1623     vm:other-immediate-1-type
1624     ))
1625     (let* ((type (kernel:get-type object))
1626     (type-symbol (find type +header-type-symbols+
1627     :key #'symbol-value)))
1628     (format t ", type: ~A" type-symbol))))))
1629 dbarlow 1.1
1630 heller 1.62 (defimplementation inspected-parts (o)
1631 dbarlow 1.1 (cond ((di::indirect-value-cell-p o)
1632     (inspected-parts-of-value-cell o))
1633     (t
1634     (destructuring-bind (text labeledp . parts)
1635     (inspect::describe-parts o)
1636     (let ((parts (if labeledp
1637     (loop for (label . value) in parts
1638     collect (cons (string label) value))
1639     (loop for value in parts
1640     for i from 0
1641     collect (cons (format nil "~D" i) value)))))
1642     (values text parts))))))
1643    
1644 heller 1.55 (defun inspected-parts-of-value-cell (o)
1645     (values (format nil "~A~% is a value cell." o)
1646     (list (cons "Value" (c:value-cell-ref o)))))
1647    
1648 dbarlow 1.1 (defmethod inspected-parts ((o function))
1649     (let ((header (kernel:get-type o)))
1650     (cond ((= header vm:function-header-type)
1651     (values
1652     (format nil "~A~% is a function." o)
1653     (list (cons "Self" (kernel:%function-self o))
1654     (cons "Next" (kernel:%function-next o))
1655     (cons "Name" (kernel:%function-name o))
1656     (cons "Arglist" (kernel:%function-arglist o))
1657     (cons "Type" (kernel:%function-type o))
1658     (cons "Code Object" (kernel:function-code-header o)))))
1659     ((= header vm:closure-header-type)
1660     (values (format nil "~A~% is a closure." o)
1661     (list*
1662     (cons "Function" (kernel:%closure-function o))
1663     (loop for i from 0 below (- (kernel:get-closure-length o)
1664     (1- vm:closure-info-offset))
1665     collect (cons (format nil "~D" i)
1666     (kernel:%closure-index-ref o i))))))
1667     (t (call-next-method o)))))
1668    
1669     (defmethod inspected-parts ((o kernel:code-component))
1670     (values (format nil "~A~% is a code data-block." o)
1671     `(("First entry point" . ,(kernel:%code-entry-points o))
1672     ,@(loop for i from vm:code-constants-offset
1673     below (kernel:get-header-data o)
1674     collect (cons (format nil "Constant#~D" i)
1675     (kernel:code-header-ref o i)))
1676     ("Debug info" . ,(kernel:%code-debug-info o))
1677     ("Instructions" . ,(kernel:code-instructions o)))))
1678    
1679     (defmethod inspected-parts ((o kernel:fdefn))
1680     (values (format nil "~A~% is a fdefn object." o)
1681     `(("Name" . ,(kernel:fdefn-name o))
1682     ("Function" . ,(kernel:fdefn-function o)))))
1683 heller 1.58
1684    
1685     ;;;; Profiling
1686     (defimplementation profile (fname)
1687     (eval `(profile:profile ,fname)))
1688    
1689     (defimplementation unprofile (fname)
1690     (eval `(profile:unprofile ,fname)))
1691    
1692     (defimplementation unprofile-all ()
1693 lgorrie 1.105 (profile:unprofile)
1694 heller 1.58 "All functions unprofiled.")
1695    
1696     (defimplementation profile-report ()
1697 lgorrie 1.105 (profile:report-time))
1698 heller 1.58
1699     (defimplementation profile-reset ()
1700 lgorrie 1.105 (profile:reset-time)
1701 heller 1.58 "Reset profiling counters.")
1702    
1703     (defimplementation profiled-functions ()
1704     profile:*timed-functions*)
1705    
1706     (defimplementation profile-package (package callers methods)
1707 heller 1.80 (profile:profile-all :package package
1708 heller 1.58 :callers-p callers
1709 lgorrie 1.105 #-cmu18e :methods #-cmu18e methods))
1710 dbarlow 1.1
1711 lgorrie 1.42
1712     ;;;; Multiprocessing
1713    
1714 heller 1.91 #+mp
1715 lgorrie 1.42 (progn
1716 lgorrie 1.56 (defimplementation startup-multiprocessing ()
1717 lgorrie 1.49 ;; Threads magic: this never returns! But top-level becomes
1718     ;; available again.
1719 lgorrie 1.42 (mp::startup-idle-and-top-level-loops))
1720 heller 1.54
1721 heller 1.59 (defimplementation spawn (fn &key (name "Anonymous"))
1722 heller 1.54 (mp:make-process fn :name name))
1723 lgorrie 1.42
1724 heller 1.61 (defimplementation thread-name (thread)
1725     (mp:process-name thread))
1726 lgorrie 1.42
1727 heller 1.61 (defimplementation thread-status (thread)
1728     (mp:process-whostate thread))
1729 lgorrie 1.42
1730 heller 1.61 (defimplementation current-thread ()
1731     mp:*current-process*)
1732 lgorrie 1.42
1733 heller 1.61 (defimplementation all-threads ()
1734     (copy-list mp:*all-processes*))
1735 heller 1.62
1736     (defimplementation interrupt-thread (thread fn)
1737     (mp:process-interrupt thread fn))
1738    
1739 heller 1.73 (defimplementation kill-thread (thread)
1740     (mp:destroy-process thread))
1741    
1742 heller 1.62 (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
1743    
1744     (defstruct (mailbox (:conc-name mailbox.))
1745     (mutex (mp:make-lock "process mailbox"))
1746     (queue '() :type list))
1747    
1748     (defun mailbox (thread)
1749     "Return THREAD's mailbox."
1750     (mp:with-lock-held (*mailbox-lock*)
1751     (or (getf (mp:process-property-list thread) 'mailbox)
1752     (setf (getf (mp:process-property-list thread) 'mailbox)
1753     (make-mailbox)))))
1754    
1755     (defimplementation send (thread message)
1756     (let* ((mbox (mailbox thread))
1757     (mutex (mailbox.mutex mbox)))
1758     (mp:with-lock-held (mutex)
1759     (setf (mailbox.queue mbox)
1760     (nconc (mailbox.queue mbox) (list message))))))
1761    
1762     (defimplementation receive ()
1763     (let* ((mbox (mailbox mp:*current-process*))
1764     (mutex (mailbox.mutex mbox)))
1765     (mp:process-wait "receive" #'mailbox.queue mbox)
1766     (mp:with-lock-held (mutex)
1767     (pop (mailbox.queue mbox)))))
1768 heller 1.59
1769 lgorrie 1.103 ) ;; #+mp
1770    
1771     ;; Local Variables:
1772     ;; pbook-heading-regexp: "^;;;\\(;+\\)"
1773     ;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"
1774     ;; End:

  ViewVC Help
Powered by ViewVC 1.1.5