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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5