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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5