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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5