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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.69 - (hide annotations)
Mon Feb 23 07:21:07 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.68: +3 -1 lines
* swank.lisp (format-arglist): Bind *PRINT-PRETTY* to NIL.
(eval-in-emacs): Fix typo in docstring.

* swank-cmucl.lisp (arglist-string): Bind *PRINT-PRETTY* to NIL.
1 lgorrie 1.24 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2 dbarlow 1.1
3 heller 1.59 (declaim (optimize (debug 2)))
4 dbarlow 1.1
5     (in-package :swank)
6    
7 heller 1.67 (in-package :lisp)
8    
9     ;; Fix for read-sequence in 18e
10     #+cmu18e
11     (progn
12     (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
13     (when s
14     (setf (symbol-value s) nil)))
15    
16     (defun read-into-simple-string (s stream start end)
17     (declare (type simple-string s))
18     (declare (type stream stream))
19     (declare (type index start end))
20     (unless (subtypep (stream-element-type stream) 'character)
21     (error 'type-error
22     :datum (read-char stream nil #\Null)
23     :expected-type (stream-element-type stream)
24     :format-control "Trying to read characters from a binary stream."))
25     ;; Let's go as low level as it seems reasonable.
26     (let* ((numbytes (- end start))
27     (bytes-read (system:read-n-bytes stream s start numbytes t)))
28     (if (< bytes-read numbytes)
29     (+ start bytes-read)
30     end)))
31    
32     (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
33     (when s
34     (setf (symbol-value s) t)))
35    
36     )
37    
38     (in-package :swank)
39    
40 lgorrie 1.25
41     ;;;; TCP server.
42    
43 heller 1.59 (setq *swank-in-background* :sigio)
44 heller 1.48
45 heller 1.63 (defimplementation create-socket (host port)
46 heller 1.64 (ext:create-inet-listener port :stream
47 heller 1.63 :reuse-address t
48     :host (resolve-hostname host)))
49 heller 1.47
50 lgorrie 1.56 (defimplementation local-port (socket)
51 heller 1.47 (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
52    
53 lgorrie 1.56 (defimplementation close-socket (socket)
54 heller 1.47 (ext:close-socket (socket-fd socket)))
55    
56 lgorrie 1.56 (defimplementation accept-connection (socket)
57 heller 1.59 #+MP (mp:process-wait-until-fd-usable socket :input)
58 heller 1.47 (make-socket-io-stream (ext:accept-tcp-connection socket)))
59    
60 heller 1.59 (defvar *sigio-handlers* '()
61     "List of (key . (fn . args)) pairs to be called on SIGIO.")
62    
63     (defun sigio-handler (signal code scp)
64 heller 1.65 (declare (ignore signal code scp))
65 heller 1.68 (mapc (lambda (handler) (funcall (cdr handler))) *sigio-handlers*))
66 heller 1.59
67     (defun set-sigio-handler ()
68     (sys:enable-interrupt unix:SIGIO (lambda (signal code scp)
69     (sigio-handler signal code scp))))
70    
71 heller 1.68 (defun fcntl (fd command arg)
72     (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
73     (cond (ok)
74     (t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
75    
76     (defimplementation add-sigio-handler (socket fn)
77     (set-sigio-handler)
78 heller 1.59 (let ((fd (socket-fd socket)))
79 heller 1.68 (format *debug-io* "; Adding input handler: ~S ~%" fd)
80     (fcntl fd unix:f-setown (unix:unix-getpid))
81     (fcntl fd unix:f-setfl unix:FASYNC)
82     (push (cons fd fn) *sigio-handlers*)))
83 lgorrie 1.45
84 heller 1.68 (defimplementation remove-sigio-handlers (socket)
85 heller 1.59 (let ((fd (socket-fd socket)))
86 heller 1.68 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
87     (sys:invalidate-descriptor fd))
88 heller 1.50 (close socket))
89    
90 heller 1.68 (defimplementation add-fd-handler (socket fn)
91     (let ((fd (socket-fd socket)))
92     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
93     (sys:add-fd-handler fd :input (lambda (_)
94     _
95     (funcall fn)))))
96    
97     (defimplementation remove-fd-handlers (socket)
98     (sys:invalidate-descriptor (socket-fd socket)))
99    
100 lgorrie 1.56 (defimplementation make-fn-streams (input-fn output-fn)
101 lgorrie 1.45 (let* ((output (make-slime-output-stream output-fn))
102     (input (make-slime-input-stream input-fn output)))
103     (values input output)))
104 lgorrie 1.25
105 lgorrie 1.44 ;;;;; Socket helpers.
106    
107 heller 1.47 (defun socket-fd (socket)
108     "Return the filedescriptor for the socket represented by SOCKET."
109     (etypecase socket
110     (fixnum socket)
111     (sys:fd-stream (sys:fd-stream-fd socket))))
112 lgorrie 1.44
113     (defun resolve-hostname (hostname)
114     "Return the IP address of HOSTNAME as an integer."
115     (let* ((hostent (ext:lookup-host-entry hostname))
116     (address (car (ext:host-entry-addr-list hostent))))
117     (ext:htonl address)))
118    
119 lgorrie 1.45 (defun make-socket-io-stream (fd)
120 lgorrie 1.44 "Create a new input/output fd-stream for FD."
121     (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
122    
123 lgorrie 1.49 (defun set-fd-non-blocking (fd)
124     (flet ((fcntl (fd cmd arg)
125     (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
126     (or flags
127     (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
128     (let ((flags (fcntl fd unix:F-GETFL 0)))
129     (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
130    
131 lgorrie 1.25
132 heller 1.54 ;;;; Unix signals
133    
134     (defmethod call-without-interrupts (fn)
135 heller 1.59 (sys:without-interrupts (funcall fn))
136     ;;(funcall fn)
137     )
138 heller 1.54
139     (defmethod getpid ()
140     (unix:unix-getpid))
141    
142    
143 lgorrie 1.25 ;;;; Stream handling
144 dbarlow 1.1
145     (defstruct (slime-output-stream
146 lgorrie 1.45 (:include lisp::lisp-stream
147     (lisp::misc #'sos/misc)
148     (lisp::out #'sos/out)
149     (lisp::sout #'sos/sout))
150     (:conc-name sos.)
151     (:print-function %print-slime-output-stream)
152     (:constructor make-slime-output-stream (output-fn)))
153     (output-fn nil :type function)
154 heller 1.16 (buffer (make-string 512) :type string)
155     (index 0 :type kernel:index)
156     (column 0 :type kernel:index))
157    
158 heller 1.17 (defun %print-slime-output-stream (s stream d)
159     (declare (ignore d))
160     (print-unreadable-object (s stream :type t :identity t)))
161    
162 heller 1.16 (defun sos/out (stream char)
163     (let ((buffer (sos.buffer stream))
164     (index (sos.index stream)))
165     (setf (schar buffer index) char)
166     (setf (sos.index stream) (1+ index))
167     (incf (sos.column stream))
168 heller 1.21 (when (char= #\newline char)
169     (setf (sos.column stream) 0))
170     (when (= index (1- (length buffer)))
171     (force-output stream)))
172 heller 1.16 char)
173    
174     (defun sos/sout (stream string start end)
175     (loop for i from start below end
176     do (sos/out stream (aref string i))))
177 lgorrie 1.45
178 heller 1.16 (defun sos/misc (stream operation &optional arg1 arg2)
179     (declare (ignore arg1 arg2))
180 dbarlow 1.1 (case operation
181 heller 1.17 ((:force-output :finish-output)
182 heller 1.16 (let ((end (sos.index stream)))
183     (unless (zerop end)
184 lgorrie 1.45 (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end))
185     (setf (sos.index stream) 0))))
186 heller 1.16 (:charpos (sos.column stream))
187     (:line-length 75)
188 dbarlow 1.1 (:file-position nil)
189 heller 1.16 (:element-type 'base-char)
190     (:get-command nil)
191 heller 1.22 (:close nil)
192 heller 1.16 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
193 dbarlow 1.1
194 heller 1.9 (defstruct (slime-input-stream
195 lgorrie 1.45 (:include string-stream
196     (lisp::in #'sis/in)
197     (lisp::misc #'sis/misc))
198     (:conc-name sis.)
199     (:print-function %print-slime-output-stream)
200     (:constructor make-slime-input-stream (input-fn sos)))
201     (input-fn nil :type function)
202     ;; We know our sibling output stream, so that we can force it before
203     ;; requesting input.
204     (sos nil :type slime-output-stream)
205     (buffer "" :type string)
206     (index 0 :type kernel:index))
207 heller 1.16
208     (defun sis/in (stream eof-errorp eof-value)
209 heller 1.18 (declare (ignore eof-errorp eof-value))
210 heller 1.16 (let ((index (sis.index stream))
211     (buffer (sis.buffer stream)))
212     (when (= index (length buffer))
213 lgorrie 1.45 (force-output (sis.sos stream))
214     (setf buffer (funcall (sis.input-fn stream)))
215 heller 1.16 (setf (sis.buffer stream) buffer)
216     (setf index 0))
217     (prog1 (aref buffer index)
218     (setf (sis.index stream) (1+ index)))))
219 heller 1.9
220 heller 1.16 (defun sis/misc (stream operation &optional arg1 arg2)
221 heller 1.14 (declare (ignore arg2))
222 heller 1.15 (ecase operation
223     (:file-position nil)
224 heller 1.16 (:file-length nil)
225     (:unread (setf (aref (sis.buffer stream)
226     (decf (sis.index stream)))
227     arg1))
228 heller 1.57 (:clear-input
229     (setf (sis.index stream) 0
230 heller 1.16 (sis.buffer stream) ""))
231     (:listen (< (sis.index stream) (length (sis.buffer stream))))
232     (:charpos nil)
233     (:line-length nil)
234     (:get-command nil)
235 heller 1.22 (:element-type 'base-char)
236     (:close nil)))
237 heller 1.16
238 lgorrie 1.25
239 dbarlow 1.1 ;;;; Compilation Commands
240    
241 heller 1.19 (defvar *swank-source-info* nil
242     "Bound to a SOURCE-INFO object during compilation.")
243 dbarlow 1.1
244 lgorrie 1.24 (defvar *previous-compiler-condition* nil
245     "Used to detect duplicates.")
246    
247     (defvar *previous-context* nil
248     "Previous compiler error context.")
249    
250     (defvar *compiler-notes* '()
251     "List of compiler notes for the last compilation unit.")
252    
253 heller 1.30 (defvar *buffer-name* nil)
254     (defvar *buffer-start-position* nil)
255     (defvar *buffer-substring* nil)
256     (defvar *compile-filename* 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     (cond (buffer
342     (make-location (list :buffer buffer)
343     (list :position *buffer-start-position*)))
344     (*compile-file-truename*
345     (make-location (list :file (namestring *compile-file-truename*))
346 heller 1.68 (list :position 0)))
347     (*compile-filename*
348     (make-location (list :file *compile-filename*)
349 heller 1.30 (list :position 0)))
350     (t
351     (list :error "No error location available"))))
352 dbarlow 1.1
353 lgorrie 1.56 (defimplementation call-with-compilation-hooks (function)
354 dbarlow 1.38 (let ((*previous-compiler-condition* nil)
355     (*previous-context* nil)
356     (*print-readably* nil))
357 lgorrie 1.24 (handler-bind ((c::compiler-error #'handle-notification-condition)
358     (c::style-warning #'handle-notification-condition)
359     (c::warning #'handle-notification-condition))
360 dbarlow 1.38 (funcall function))))
361 lgorrie 1.24
362 lgorrie 1.56 (defimplementation compile-file-for-emacs (filename load-p)
363 lgorrie 1.24 (clear-xref-info filename)
364     (with-compilation-hooks ()
365 heller 1.30 (let ((*buffer-name* nil)
366     (*compile-filename* filename))
367 heller 1.40 (multiple-value-bind (fasl-file warnings-p failure-p)
368     (compile-file filename)
369     (declare (ignore warnings-p))
370     (when (and load-p (not failure-p))
371     (load fasl-file))))))
372 lgorrie 1.24
373 lgorrie 1.56 (defimplementation compile-string-for-emacs (string &key buffer position)
374 lgorrie 1.24 (with-compilation-hooks ()
375     (let ((*package* *buffer-package*)
376 heller 1.30 (*compile-filename* nil)
377     (*buffer-name* buffer)
378     (*buffer-start-position* position)
379     (*buffer-substring* string))
380 lgorrie 1.24 (with-input-from-string (stream string)
381     (ext:compile-from-stream
382     stream
383     :source-info `(:emacs-buffer ,buffer
384     :emacs-buffer-offset ,position
385     :emacs-buffer-string ,string))))))
386 dbarlow 1.1
387 lgorrie 1.25
388     ;;;; XREF
389 dbarlow 1.1
390 heller 1.30 (defun lookup-xrefs (finder name)
391     (xref-results-for-emacs (funcall finder (from-string name))))
392    
393 heller 1.57 (defimplementation who-calls (function-name)
394 heller 1.30 (lookup-xrefs #'xref:who-calls function-name))
395 dbarlow 1.1
396 heller 1.57 (defimplementation who-references (variable)
397 heller 1.30 (lookup-xrefs #'xref:who-references variable))
398 dbarlow 1.1
399 heller 1.57 (defimplementation who-binds (variable)
400 heller 1.30 (lookup-xrefs #'xref:who-binds variable))
401 dbarlow 1.1
402 heller 1.57 (defimplementation who-sets (variable)
403 heller 1.30 (lookup-xrefs #'xref:who-sets variable))
404 dbarlow 1.1
405 lgorrie 1.10 #+cmu19
406 heller 1.32 (progn
407 heller 1.57 (defimplementation who-macroexpands (macro)
408 heller 1.32 (lookup-xrefs #'xref:who-macroexpands macro))
409    
410 heller 1.57 (defimplementation who-specializes (class)
411 heller 1.32 (let* ((methods (xref::who-specializes (find-class (from-string class))))
412     (locations (mapcar #'method-source-location methods)))
413     (group-xrefs (mapcar (lambda (m l)
414     (cons (let ((*print-pretty* nil))
415     (to-string m))
416     l))
417 heller 1.57 methods locations)))))
418 heller 1.30
419     (defun resolve-xref-location (xref)
420     (let ((name (xref:xref-context-name xref))
421     (file (xref:xref-context-file xref))
422     (source-path (xref:xref-context-source-path xref)))
423     (cond ((and file source-path)
424     (let ((position (source-path-file-position source-path file)))
425     (make-location (list :file (unix-truename file))
426     (list :position (1+ position)))))
427     (file
428     (make-location (list :file (unix-truename file))
429     (list :function-name (string name))))
430     (t
431     `(:error ,(format nil "Unkown source location: ~S ~S ~S "
432     name file source-path))))))
433    
434 dbarlow 1.1
435     (defun xref-results-for-emacs (contexts)
436     "Prepare a list of xref contexts for Emacs.
437 heller 1.29 The result is a list of xrefs:
438     group ::= (FILENAME . ({reference}+))
439     reference ::= (FUNCTION-SPECIFIER . SOURCE-LOCATION)"
440     (let ((xrefs '()))
441     (dolist (cxt contexts)
442 heller 1.30 (let ((name (xref:xref-context-name cxt)))
443 heller 1.29 (push (cons (to-string name)
444 heller 1.30 (resolve-xref-location cxt))
445 heller 1.29 xrefs)))
446     (group-xrefs xrefs)))
447    
448 lgorrie 1.25 (defun clear-xref-info (namestring)
449 heller 1.66 "Clear XREF notes pertaining to NAMESTRING.
450 lgorrie 1.25 This is a workaround for a CMUCL bug: XREF records are cumulative."
451 heller 1.65 (when c:*record-xref-info*
452 heller 1.66 (let ((filename (truename namestring)))
453 lgorrie 1.25 (dolist (db (list xref::*who-calls*
454     #+cmu19 xref::*who-is-called*
455     #+cmu19 xref::*who-macroexpands*
456     xref::*who-references*
457     xref::*who-binds*
458     xref::*who-sets*))
459     (maphash (lambda (target contexts)
460 heller 1.66 ;; XXX update during traversal?
461 lgorrie 1.25 (setf (gethash target db)
462 heller 1.66 (delete filename contexts
463     :key #'xref:xref-context-file
464     :test #'equalp)))
465 lgorrie 1.25 db)))))
466    
467     (defun unix-truename (pathname)
468     (ext:unix-namestring (truename pathname)))
469    
470    
471     ;;;; Find callers and callees
472    
473 dbarlow 1.1 ;;; Find callers and callees by looking at the constant pool of
474     ;;; compiled code objects. We assume every fdefn object in the
475     ;;; constant pool corresponds to a call to that function. A better
476     ;;; strategy would be to use the disassembler to find actual
477     ;;; call-sites.
478    
479     (declaim (inline map-code-constants))
480     (defun map-code-constants (code fn)
481     "Call FN for each constant in CODE's constant pool."
482     (check-type code kernel:code-component)
483     (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
484     do (funcall fn (kernel:code-header-ref code i))))
485    
486     (defun function-callees (function)
487 heller 1.30 "Return FUNCTION's callees as a list of functions."
488 dbarlow 1.1 (let ((callees '()))
489     (map-code-constants
490     (vm::find-code-object function)
491     (lambda (obj)
492     (when (kernel:fdefn-p obj)
493 heller 1.30 (push (kernel:fdefn-function obj) callees))))
494 dbarlow 1.1 callees))
495    
496 heller 1.19 (declaim (ext:maybe-inline map-allocated-code-components))
497 dbarlow 1.1 (defun map-allocated-code-components (spaces fn)
498     "Call FN for each allocated code component in one of SPACES. FN
499 heller 1.19 receives the object as argument. SPACES should be a list of the
500     symbols :dynamic, :static, or :read-only."
501 dbarlow 1.1 (dolist (space spaces)
502 heller 1.18 (declare (inline vm::map-allocated-objects))
503 dbarlow 1.1 (vm::map-allocated-objects
504     (lambda (obj header size)
505 heller 1.19 (declare (type fixnum size) (ignore size))
506 dbarlow 1.1 (when (= vm:code-header-type header)
507 heller 1.19 (funcall fn obj)))
508 dbarlow 1.1 space)))
509    
510 heller 1.19 (declaim (ext:maybe-inline map-caller-code-components))
511 dbarlow 1.1 (defun map-caller-code-components (function spaces fn)
512     "Call FN for each code component with a fdefn for FUNCTION in its
513     constant pool."
514     (let ((function (coerce function 'function)))
515 heller 1.19 (declare (inline map-allocated-code-components))
516 dbarlow 1.1 (map-allocated-code-components
517     spaces
518 heller 1.19 (lambda (obj)
519 dbarlow 1.1 (map-code-constants
520     obj
521     (lambda (constant)
522     (when (and (kernel:fdefn-p constant)
523     (eq (kernel:fdefn-function constant)
524     function))
525     (funcall fn obj))))))))
526    
527     (defun function-callers (function &optional (spaces '(:read-only :static
528     :dynamic)))
529 heller 1.30 "Return FUNCTION's callers. The result is a list of code-objects."
530 dbarlow 1.1 (let ((referrers '()))
531 heller 1.19 (declare (inline map-caller-code-components))
532 heller 1.30 (ext:gc :full t)
533     (map-caller-code-components function spaces
534     (lambda (code) (push code referrers)))
535 dbarlow 1.1 referrers))
536 heller 1.30
537     (defun debug-info-definitions (debug-info)
538     "Return the defintions for a debug-info. This should only be used
539     for code-object without entry points, i.e., byte compiled
540     code (are theree others?)"
541     ;; This mess has only been tested with #'ext::skip-whitespace, a
542     ;; byte-compiled caller of #'read-char .
543     (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
544     (let ((name (c::debug-info-name debug-info))
545     (source (c::debug-info-source debug-info)))
546     (destructuring-bind (first) source
547     (ecase (c::debug-source-from first)
548     (:file
549     (list
550     (cons name
551     (make-location
552     (list :file (unix-truename (c::debug-source-name first)))
553     (list :function-name name)))))))))
554    
555     (defun code-component-entry-points (code)
556     "Return a list ((NAME . LOCATION) ...) of function definitons for
557     the code omponent CODE."
558     (delete-duplicates
559     (loop for e = (kernel:%code-entry-points code)
560     then (kernel::%function-next e)
561     while e
562     collect (cons (to-string (kernel:%function-name e))
563     (function-source-location e)))
564     :test #'equal))
565 dbarlow 1.1
566 heller 1.57 (defimplementation list-callers (symbol-name)
567 heller 1.30 "Return a list ((FILE . ((NAME . LOCATION) ...)) ...) of callers."
568     (let ((components (function-callers (from-string symbol-name)))
569     (xrefs '()))
570     (dolist (code components)
571     (let* ((entry (kernel:%code-entry-points code))
572     (defs (if entry
573     (code-component-entry-points code)
574     ;; byte compiled stuff
575     (debug-info-definitions
576     (kernel:%code-debug-info code)))))
577     (setq xrefs (nconc defs xrefs))))
578     (group-xrefs xrefs)))
579 dbarlow 1.1
580 heller 1.57 (defimplementation list-callees (symbol-name)
581 heller 1.30 (let ((fns (function-callees (from-string symbol-name))))
582     (group-xrefs (mapcar (lambda (fn)
583     (cons (to-string (kernel:%function-name fn))
584     (function-source-location fn)))
585     fns))))
586 dbarlow 1.1
587 lgorrie 1.42
588 dbarlow 1.1 ;;;; Definitions
589    
590 lgorrie 1.35 (defvar *debug-definition-finding* nil
591 dbarlow 1.1 "When true don't handle errors while looking for definitions.
592     This is useful when debugging the definition-finding code.")
593    
594 heller 1.29 (defmacro safe-definition-finding (&body body)
595 heller 1.43 "Execute BODY ignoring errors. Return the source location returned
596     by BODY or if an error occurs a description of the error. The second
597     return value is the condition or nil."
598 heller 1.29 `(flet ((body () ,@body))
599     (if *debug-definition-finding*
600     (body)
601     (handler-case (values (progn ,@body) nil)
602     (error (c) (values (list :error (princ-to-string c)) c))))))
603    
604 dbarlow 1.1 (defun function-first-code-location (function)
605     (and (function-has-debug-function-p function)
606     (di:debug-function-start-location
607     (di:function-debug-function function))))
608    
609     (defun function-has-debug-function-p (function)
610     (di:function-debug-function function))
611    
612     (defun function-code-object= (closure function)
613     (and (eq (vm::find-code-object closure)
614     (vm::find-code-object function))
615     (not (eq closure function))))
616    
617 heller 1.4 (defun struct-closure-p (function)
618     (or (function-code-object= function #'kernel::structure-slot-accessor)
619     (function-code-object= function #'kernel::structure-slot-setter)
620     (function-code-object= function #'kernel::%defstruct)))
621 dbarlow 1.1
622 heller 1.4 (defun struct-closure-dd (function)
623 dbarlow 1.1 (assert (= (kernel:get-type function) vm:closure-header-type))
624 heller 1.4 (flet ((find-layout (function)
625     (sys:find-if-in-closure
626     (lambda (x)
627 heller 1.18 (let ((value (if (di::indirect-value-cell-p x)
628     (c:value-cell-ref x)
629     x)))
630     (when (kernel::layout-p value)
631     (return-from find-layout value))))
632 heller 1.4 function)))
633     (kernel:layout-info (find-layout function))))
634    
635 dbarlow 1.1 (defun dd-source-location (dd)
636     (let ((constructor (or (kernel:dd-default-constructor dd)
637 heller 1.32 (car (kernel::dd-constructors dd)))))
638     (when (or (not constructor) (and (consp constructor)
639     (not (car constructor))))
640     (error "Cannot locate struct without constructor: ~S"
641     (kernel::dd-name dd)))
642     (function-source-location
643     (coerce (if (consp constructor) (car constructor) constructor)
644     'function))))
645 dbarlow 1.1
646 heller 1.27 (defun genericp (fn)
647     (typep fn 'generic-function))
648    
649     (defun gf-definition-location (gf)
650     (flet ((guess-source-file (faslfile)
651     (unix-truename
652     (merge-pathnames (make-pathname :type "lisp")
653     faslfile))))
654     (let ((def-source (pcl::definition-source gf))
655     (name (string (pcl:generic-function-name gf))))
656     (etypecase def-source
657 heller 1.30 (pathname (make-location
658     `(:file ,(guess-source-file def-source))
659     `(:function-name ,name)))
660 heller 1.27 (cons
661     (destructuring-bind ((dg name) pathname) def-source
662     (declare (ignore dg))
663 heller 1.30 (etypecase pathname
664     (pathname
665     (make-location `(:file ,(guess-source-file pathname))
666 heller 1.60 `(:function-name ,(string name))))
667     (null `(:error ,(format nil "Cannot resolve: ~S" def-source)))
668     )))))))
669 heller 1.27
670     (defun method-source-location (method)
671     (function-source-location (or (pcl::method-fast-function method)
672     (pcl:method-function method))))
673    
674     (defun gf-method-locations (gf)
675     (let ((ms (pcl::generic-function-methods gf)))
676     (mapcar #'method-source-location ms)))
677    
678     (defun gf-source-locations (gf)
679     (list* (gf-definition-location gf)
680     (gf-method-locations gf)))
681    
682 heller 1.29 (defun function-source-locations (function)
683     "Return a list of source locations for FUNCTION."
684 dbarlow 1.1 ;; First test if FUNCTION is a closure created by defstruct; if so
685     ;; extract the defstruct-description (dd) from the closure and find
686     ;; the constructor for the struct. Defstruct creates a defun for
687     ;; the default constructor and we use that as an approximation to
688     ;; the source location of the defstruct.
689     ;;
690     ;; For an ordinary function we return the source location of the
691     ;; first code-location we find.
692 heller 1.4 (cond ((struct-closure-p function)
693 heller 1.29 (list
694     (safe-definition-finding
695     (dd-source-location (struct-closure-dd function)))))
696 heller 1.27 ((genericp function)
697 heller 1.29 (gf-source-locations function))
698 heller 1.27 (t
699 heller 1.29 (list
700     (multiple-value-bind (code-location error)
701     (safe-definition-finding (function-first-code-location function))
702     (cond (error (list :error (princ-to-string error)))
703     (t (code-location-source-location code-location))))))))
704    
705     (defun function-source-location (function)
706     (destructuring-bind (first) (function-source-locations function)
707     first))
708 dbarlow 1.1
709 lgorrie 1.56 (defimplementation find-function-locations (symbol-name)
710 heller 1.29 "Return a list of source-locations for SYMBOL-NAME's functions."
711     (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
712     (cond ((not foundp)
713     (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
714     ((macro-function symbol)
715     (function-source-locations (macro-function symbol)))
716     ((special-operator-p symbol)
717 heller 1.31 (list (list :error (format nil "~A is a special-operator" symbol))))
718 heller 1.29 ((fboundp symbol)
719     (function-source-locations (coerce symbol 'function)))
720     (t (list (list :error
721     (format nil "Symbol not fbound: ~A" symbol-name))))
722     )))
723    
724 lgorrie 1.25
725     ;;;; Documentation.
726 dbarlow 1.1
727 lgorrie 1.56 (defimplementation describe-symbol-for-emacs (symbol)
728 dbarlow 1.1 (let ((result '()))
729 lgorrie 1.24 (flet ((doc (kind)
730     (or (documentation symbol kind) :not-documented))
731     (maybe-push (property value)
732     (when value
733     (setf result (list* property value result)))))
734 dbarlow 1.1 (maybe-push
735     :variable (multiple-value-bind (kind recorded-p)
736     (ext:info variable kind symbol)
737     (declare (ignore kind))
738     (if (or (boundp symbol) recorded-p)
739     (doc 'variable))))
740     (maybe-push
741 heller 1.27 :generic-function
742     (if (and (fboundp symbol)
743     (typep (fdefinition symbol) 'generic-function))
744     (doc 'function)))
745     (maybe-push
746     :function (if (and (fboundp symbol)
747     (not (typep (fdefinition symbol) 'generic-function)))
748     (doc 'function)))
749 dbarlow 1.1 (maybe-push
750     :setf (if (or (ext:info setf inverse symbol)
751     (ext:info setf expander symbol))
752     (doc 'setf)))
753     (maybe-push
754     :type (if (ext:info type kind symbol)
755     (doc 'type)))
756     (maybe-push
757     :class (if (find-class symbol nil)
758     (doc 'class)))
759 heller 1.18 (maybe-push
760     :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
761     (doc 'alien-type)))
762     (maybe-push
763     :alien-struct (if (ext:info alien-type struct symbol)
764     (doc nil)))
765     (maybe-push
766     :alien-union (if (ext:info alien-type union symbol)
767     (doc nil)))
768     (maybe-push
769     :alien-enum (if (ext:info alien-type enum symbol)
770     (doc nil)))
771 lgorrie 1.24 result)))
772 dbarlow 1.1
773 heller 1.18 (defmacro %describe-alien (symbol-name namespace)
774     `(print-description-to-string
775     (ext:info :alien-type ,namespace (from-string ,symbol-name))))
776    
777 lgorrie 1.56 (defimplementation describe-definition (symbol-name type)
778     (case type
779     (:variable
780     (describe-symbol symbol-name))
781     ((:function :generic-function)
782     (describe-function symbol-name))
783     (:setf
784     (print-description-to-string
785     (or (ext:info setf inverse (from-string symbol-name))
786     (ext:info setf expander (from-string symbol-name)))))
787     (:type
788     (print-description-to-string
789     (kernel:values-specifier-type (from-string symbol-name))))
790     (:class
791     (print-description-to-string (find-class (from-string symbol-name) nil)))
792     (:alien-type
793     (let ((name (from-string symbol-name)))
794     (ecase (ext:info :alien-type :kind name)
795     (:primitive
796     (print-description-to-string
797     (let ((alien::*values-type-okay* t))
798     (funcall (ext:info :alien-type :translator name) (list name)))))
799     ((:defined)
800     (print-description-to-string (ext:info :alien-type
801     :definition name)))
802     (:unknown
803     (format nil "Unkown alien type: ~A" symbol-name)))))
804     (:alien-struct
805     (%describe-alien symbol-name :struct))
806     (:alien-union
807     (%describe-alien symbol-name :union))
808     (:alien-enum
809     (%describe-alien symbol-name :enum))))
810 heller 1.18
811 lgorrie 1.56 (defimplementation arglist-string (fname)
812 lgorrie 1.25 "Return a string describing the argument list for FNAME.
813     The result has the format \"(...)\"."
814     (declare (type string fname))
815 heller 1.54 (multiple-value-bind (function package) (find-symbol-designator fname)
816     (unless package
817     (return-from arglist-string (format nil "(-- Unkown symbol: ~A)" fname)))
818 lgorrie 1.25 (let ((arglist
819     (if (not (or (fboundp function)
820     (functionp function)))
821     "(-- <Unknown-Function>)"
822     (let* ((fun (or (macro-function function)
823     (symbol-function function)))
824     (df (di::function-debug-function fun))
825 heller 1.54 (arglist (kernel:%function-arglist
826     (kernel:%function-self fun))))
827 lgorrie 1.25 (cond ((eval:interpreted-function-p fun)
828     (eval:interpreted-function-arglist fun))
829     ((pcl::generic-function-p fun)
830 heller 1.54 (pcl:generic-function-lambda-list fun))
831 lgorrie 1.25 (arglist arglist)
832     ;; this should work both for
833     ;; compiled-debug-function and for
834     ;; interpreted-debug-function
835     (df (di::debug-function-lambda-list df))
836     (t "(<arglist-unavailable>)"))))))
837 heller 1.53 (etypecase arglist
838     (string arglist)
839 heller 1.69 (cons (let ((*print-case* :downcase)
840     (*print-pretty* nil))
841     (princ-to-string arglist)))
842 heller 1.53 (null "()")))))
843 lgorrie 1.25
844    
845     ;;;; Miscellaneous.
846 dbarlow 1.1
847 lgorrie 1.56 (defimplementation macroexpand-all (form)
848 lgorrie 1.24 (walker:macroexpand-all form))
849 dbarlow 1.1
850 heller 1.37 (in-package :c)
851    
852     (defun swank::expand-ir1-top-level (form)
853     "A scaled down version of the first pass of the compiler."
854     (with-compilation-unit ()
855     (let* ((*lexical-environment*
856     (make-lexenv :default (make-null-environment)
857     :cookie *default-cookie*
858     :interface-cookie *default-interface-cookie*))
859     (*source-info* (make-lisp-source-info form))
860     (*block-compile* nil)
861     (*block-compile-default* nil))
862     (with-ir1-namespace
863     (clear-stuff)
864     (find-source-paths form 0)
865     (ir1-top-level form '(0) t)))))
866    
867     (in-package :swank)
868    
869     (defslimefun print-ir1-converted-blocks (form)
870     (with-output-to-string (*standard-output*)
871     (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
872 lgorrie 1.25
873 heller 1.58 (defslimefun print-compilation-trace (form)
874     (with-output-to-string (*standard-output*)
875     (with-input-from-string (s form)
876     (let ((*package* *buffer-package*))
877     (ext:compile-from-stream s
878     :verbose t
879     :progress t
880     :trace-stream *standard-output*)))))
881    
882 lgorrie 1.25 (defslimefun set-default-directory (directory)
883     (setf (ext:default-directory) (namestring directory))
884     ;; Setting *default-pathname-defaults* to an absolute directory
885     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
886     (setf *default-pathname-defaults* (pathname (ext:default-directory)))
887     (namestring (ext:default-directory)))
888    
889 dbarlow 1.39 ;;; source-path-{stream,file,string,etc}-position moved into
890     ;;; swank-source-path-parser
891 heller 1.19
892     (defun code-location-stream-position (code-location stream)
893     "Return the byte offset of CODE-LOCATION in STREAM. Extract the
894     toplevel-form-number and form-number from CODE-LOCATION and use that
895     to find the position of the corresponding form."
896     (let* ((location (debug::maybe-block-start-location code-location))
897     (tlf-offset (di:code-location-top-level-form-offset location))
898     (form-number (di:code-location-form-number location))
899     (*read-suppress* t))
900     (dotimes (i tlf-offset) (read stream))
901     (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
902     (let* ((path-table (di:form-number-translations tlf 0))
903 heller 1.30 (source-path
904     (if (<= (length path-table) form-number) ; source out of sync?
905     (list 0) ; should probably signal a condition
906     (reverse (cdr (aref path-table form-number))))))
907 heller 1.19 (source-path-source-position source-path tlf position-map)))))
908    
909     (defun code-location-string-offset (code-location string)
910     (with-input-from-string (s string)
911     (code-location-stream-position code-location s)))
912    
913     (defun code-location-file-position (code-location filename)
914     (with-open-file (s filename :direction :input)
915     (code-location-stream-position code-location s)))
916    
917     (defun debug-source-info-from-emacs-buffer-p (debug-source)
918     (let ((info (c::debug-source-info debug-source)))
919     (and info
920     (consp info)
921     (eq :emacs-buffer (car info)))))
922    
923 heller 1.30 (defun source-location-from-code-location (code-location)
924 heller 1.29 "Return the source location for CODE-LOCATION."
925 heller 1.30 (let ((debug-fun (di:code-location-debug-function code-location)))
926     (when (di::bogus-debug-function-p debug-fun)
927     (error "Bogus debug function: ~A" debug-fun)))
928 heller 1.19 (let* ((debug-source (di:code-location-debug-source code-location))
929 heller 1.30 (from (di:debug-source-from debug-source))
930     (name (di:debug-source-name debug-source)))
931 heller 1.19 (ecase from
932 heller 1.32 (:file
933     (make-location (list :file (unix-truename name))
934     (list :position (1+ (code-location-file-position
935     code-location name)))))
936 heller 1.19 (:stream
937     (assert (debug-source-info-from-emacs-buffer-p debug-source))
938     (let ((info (c::debug-source-info debug-source)))
939 heller 1.32 (make-location
940     (list :buffer (getf info :emacs-buffer))
941     (list :position (+ (getf info :emacs-buffer-offset)
942     (code-location-string-offset
943     code-location
944     (getf info :emacs-buffer-string)))))))
945 heller 1.19 (:lisp
946 heller 1.32 (make-location
947     (list :source-form (with-output-to-string (*standard-output*)
948     (debug::print-code-location-source-form
949     code-location 100 t)))
950     (list :position 1))))))
951 heller 1.19
952 heller 1.29 (defun code-location-source-location (code-location)
953     "Safe wrapper around `code-location-from-source-location'."
954     (safe-definition-finding
955 heller 1.30 (source-location-from-code-location code-location)))
956 dbarlow 1.1
957    
958 lgorrie 1.25 ;;;; Debugging
959 dbarlow 1.1
960     (defvar *sldb-stack-top*)
961     (defvar *sldb-restarts*)
962    
963 lgorrie 1.56 (defimplementation call-with-debugging-environment (debugger-loop-fn)
964 dbarlow 1.1 (unix:unix-sigsetmask 0)
965 lgorrie 1.25 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
966 dbarlow 1.1 (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
967     (debug:*stack-top-hint* nil)
968     (*debugger-hook* nil)
969     (*readtable* (or debug:*debug-readtable* *readtable*))
970     (*print-level* debug:*debug-print-level*)
971 heller 1.30 (*print-length* debug:*debug-print-length*)
972     (*print-readably* nil))
973 dbarlow 1.1 (handler-bind ((di:debug-condition
974     (lambda (condition)
975 lgorrie 1.25 (signal (make-condition
976     'sldb-condition
977     :original-condition condition)))))
978     (funcall debugger-loop-fn))))
979 dbarlow 1.1
980     (defun format-restarts-for-emacs ()
981     "Return a list of restarts for *swank-debugger-condition* in a
982     format suitable for Emacs."
983     (loop for restart in *sldb-restarts*
984     collect (list (princ-to-string (restart-name restart))
985     (princ-to-string restart))))
986    
987     (defun nth-frame (index)
988     (do ((frame *sldb-stack-top* (di:frame-down frame))
989     (i index (1- i)))
990     ((zerop i) frame)))
991    
992     (defun nth-restart (index)
993     (nth index *sldb-restarts*))
994    
995 heller 1.43 (defun format-frame-for-emacs (number frame)
996     (print-with-frame-label
997     number (lambda (*standard-output*)
998     (debug::print-frame-call frame :verbosity 1 :number nil))))
999 dbarlow 1.1
1000     (defun compute-backtrace (start end)
1001     "Return a list of frames starting with frame number START and
1002     continuing to frame number END or, if END is nil, the last frame on the
1003     stack."
1004     (let ((end (or end most-positive-fixnum)))
1005     (loop for f = (nth-frame start) then (di:frame-down f)
1006     for i from start below end
1007     while f
1008 heller 1.33 collect (cons i f))))
1009 dbarlow 1.1
1010 lgorrie 1.56 (defimplementation backtrace (start end)
1011 heller 1.33 (loop for (n . frame) in (compute-backtrace start end)
1012 heller 1.43 collect (list n (format-frame-for-emacs n frame))))
1013 dbarlow 1.1
1014 lgorrie 1.56 (defimplementation debugger-info-for-emacs (start end)
1015 heller 1.43 (list (debugger-condition-for-emacs)
1016 dbarlow 1.1 (format-restarts-for-emacs)
1017 lgorrie 1.26 (backtrace start end)))
1018 dbarlow 1.1
1019 lgorrie 1.56 (defimplementation frame-source-location-for-emacs (index)
1020 heller 1.29 (code-location-source-location (di:frame-code-location (nth-frame index))))
1021 dbarlow 1.1
1022 lgorrie 1.56 (defimplementation eval-in-frame (form index)
1023 lgorrie 1.26 (di:eval-in-frame (nth-frame index) form))
1024 heller 1.19
1025     (defslimefun pprint-eval-string-in-frame (string index)
1026 heller 1.23 (swank-pprint
1027     (multiple-value-list
1028     (di:eval-in-frame (nth-frame index) (from-string string)))))
1029 dbarlow 1.1
1030 heller 1.13 (defslimefun inspect-in-frame (string index)
1031     (reset-inspector)
1032     (inspect-object (di:eval-in-frame (nth-frame index) (from-string string))))
1033    
1034 lgorrie 1.56 (defimplementation frame-locals (index)
1035 dbarlow 1.1 (let* ((frame (nth-frame index))
1036     (location (di:frame-code-location frame))
1037     (debug-function (di:frame-debug-function frame))
1038     (debug-variables (di::debug-function-debug-variables debug-function)))
1039 heller 1.43 (loop for v across debug-variables collect
1040     (list :name (to-string (di:debug-variable-symbol v))
1041     :id (di:debug-variable-id v)
1042     :value-string (ecase (di:debug-variable-validity v location)
1043     (:valid
1044     (to-string (di:debug-variable-value v frame)))
1045     ((:invalid :unknown)
1046     "<not-available>"))))))
1047 dbarlow 1.1
1048 lgorrie 1.56 (defimplementation frame-catch-tags (index)
1049 dbarlow 1.1 (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
1050 heller 1.29 collect `(,tag . ,(code-location-source-location code-location))))
1051 dbarlow 1.1
1052     (defslimefun invoke-nth-restart (index)
1053 heller 1.31 (invoke-restart-interactively (nth-restart index)))
1054 dbarlow 1.1
1055     (defslimefun sldb-abort ()
1056     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1057 heller 1.33
1058     (defun set-step-breakpoints (frame)
1059     (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1060     (di:frame-code-location frame)))
1061     (error "Cannot step, in elsewhere code~%"))
1062     (let* ((code-location (di:frame-code-location frame))
1063 heller 1.36 (debug::*bad-code-location-types*
1064     (remove :call-site debug::*bad-code-location-types*))
1065 heller 1.33 (next (debug::next-code-locations code-location)))
1066     (cond (next
1067     (let ((steppoints '()))
1068     (flet ((hook (frame breakpoint)
1069     (let ((debug:*stack-top-hint* frame))
1070 heller 1.36 (mapc #'di:delete-breakpoint steppoints)
1071     (let ((cl (di::breakpoint-what breakpoint)))
1072     (break "Breakpoint: ~S ~S"
1073     (di:code-location-kind cl)
1074     (di::compiled-code-location-pc cl))))))
1075 heller 1.33 (dolist (code-location next)
1076     (let ((bp (di:make-breakpoint #'hook code-location
1077     :kind :code-location)))
1078     (di:activate-breakpoint bp)
1079     (push bp steppoints))))))
1080     (t
1081     (flet ((hook (frame breakpoint values cookie)
1082     (declare (ignore cookie))
1083 heller 1.36 (di:delete-breakpoint breakpoint)
1084 heller 1.33 (let ((debug:*stack-top-hint* frame))
1085     (break "Function-end: ~A ~A" breakpoint values))))
1086     (let* ((debug-function (di:frame-debug-function frame))
1087     (bp (di:make-breakpoint #'hook debug-function
1088     :kind :function-end)))
1089     (di:activate-breakpoint bp)))))))
1090    
1091     (defslimefun sldb-step (frame)
1092     (cond ((find-restart 'continue *swank-debugger-condition*)
1093     (set-step-breakpoints (nth-frame frame))
1094     (continue *swank-debugger-condition*))
1095     (t
1096     (error "Cannot continue in from condition: ~A"
1097     *swank-debugger-condition*))))
1098 dbarlow 1.1
1099 heller 1.58 (defun frame-cfp (frame)
1100     "Return the Control-Stack-Frame-Pointer for FRAME."
1101     (etypecase frame
1102     (di::compiled-frame (di::frame-pointer frame))
1103     ((or di::interpreted-frame null) -1)))
1104    
1105     (defun frame-ip (frame)
1106     "Return the (absolute) instruction pointer and the relative pc of FRAME."
1107     (if (not frame)
1108     -1
1109     (let ((debug-fun (di::frame-debug-function frame)))
1110     (etypecase debug-fun
1111     (di::compiled-debug-function
1112     (let* ((code-loc (di:frame-code-location frame))
1113     (component (di::compiled-debug-function-component debug-fun))
1114     (pc (di::compiled-code-location-pc code-loc))
1115     (ip (sys:without-gcing
1116     (sys:sap-int
1117     (sys:sap+ (kernel:code-instructions component) pc)))))
1118     (values ip pc)))
1119     ((or di::bogus-debug-function di::interpreted-debug-function)
1120     -1)))))
1121    
1122     (defun frame-registers (frame)
1123     "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1124     (let* ((cfp (frame-cfp frame))
1125     (csp (frame-cfp (di::frame-up frame)))
1126     (ip (frame-ip frame))
1127     (ocfp (frame-cfp (di::frame-down frame)))
1128     (lra (frame-ip (di::frame-down frame))))
1129     (values csp cfp ip ocfp lra)))
1130    
1131     (defun print-frame-registers (frame-number)
1132     (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1133     (flet ((fixnum (p) (etypecase p
1134     (integer p)
1135     (sys:system-area-pointer (sys:sap-int p)))))
1136     (apply #'format t "~
1137     CSP = ~X
1138     CFP = ~X
1139     IP = ~X
1140     OCFP = ~X
1141     LRA = ~X~%" (mapcar #'fixnum
1142     (multiple-value-list (frame-registers frame)))))))
1143    
1144 heller 1.36 (defslimefun sldb-disassemble (frame-number)
1145     "Return a string with the disassembly of frames code."
1146     (with-output-to-string (*standard-output*)
1147 heller 1.58 (print-frame-registers frame-number)
1148     (terpri)
1149     (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1150     (debug-fun (di::frame-debug-function frame)))
1151     (etypecase debug-fun
1152     (di::compiled-debug-function
1153     (let* ((component (di::compiled-debug-function-component debug-fun))
1154     (fun (di:debug-function-function debug-fun)))
1155     (if fun
1156     (disassemble fun)
1157     (disassem:disassemble-code-component component))))
1158     (di::bogus-debug-function
1159     (format t "~%[Disassembling bogus frames not implemented]"))))))
1160    
1161     #+(or)
1162     (defun print-binding-stack ()
1163 heller 1.60 (flet ((bsp- (p) (sys:sap+ p (- (* vm:binding-size vm:word-bytes))))
1164     (frob (p offset) (kernel:make-lisp-obj (sys:sap-ref-32 p offset))))
1165     (do ((bsp (bsp- (kernel:binding-stack-pointer-sap)) (bsp- bsp))
1166     (start (sys:int-sap (lisp::binding-stack-start))))
1167     ((sys:sap= bsp start))
1168     (format t "~X: ~S = ~S~%"
1169     (sys:sap-int bsp)
1170     (frob bsp (* vm:binding-symbol-slot vm:word-bytes))
1171     (frob bsp (* vm:binding-value-slot vm:word-bytes))))))
1172 heller 1.58
1173     ;; (print-binding-stack)
1174    
1175     #+(or)
1176     (defun print-catch-blocks ()
1177     (do ((b (di::descriptor-sap lisp::*current-catch-block*)
1178     (sys:sap-ref-sap b (* vm:catch-block-previous-catch-slot
1179     vm:word-bytes))))
1180     (nil)
1181     (let ((int (sys:sap-int b)))
1182     (when (zerop int) (return))
1183     (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
1184     (let ((uwp (ref vm:catch-block-current-uwp-slot))
1185     (cfp (ref vm:catch-block-current-cont-slot))
1186     (tag (ref vm:catch-block-tag-slot))
1187     )
1188     (format t "~X: uwp = ~8X cfp = ~8X tag = ~X~%"
1189     int uwp cfp (kernel:make-lisp-obj tag)))))))
1190    
1191 heller 1.60 ;; (print-catch-blocks)
1192 heller 1.58
1193     #+(or)
1194     (defun print-unwind-blocks ()
1195     (do ((b (di::descriptor-sap lisp::*current-unwind-protect-block*)
1196     (sys:sap-ref-sap b (* vm:unwind-block-current-uwp-slot
1197     vm:word-bytes))))
1198     (nil)
1199     (let ((int (sys:sap-int b)))
1200     (when (zerop int) (return))
1201     (flet ((ref (offset) (sys:sap-ref-32 b (* offset vm:word-bytes))))
1202     (let ((cfp (ref vm:unwind-block-current-cont-slot)))
1203     (format t "~X: cfp = ~X~%" int cfp))))))
1204    
1205     ;; (print-unwind-blocks)
1206    
1207 dbarlow 1.1
1208 lgorrie 1.25 ;;;; Inspecting
1209 dbarlow 1.1
1210     (defconstant +lowtag-symbols+
1211     '(vm:even-fixnum-type
1212     vm:function-pointer-type
1213     vm:other-immediate-0-type
1214     vm:list-pointer-type
1215     vm:odd-fixnum-type
1216     vm:instance-pointer-type
1217     vm:other-immediate-1-type
1218     vm:other-pointer-type))
1219    
1220     (defconstant +header-type-symbols+
1221     ;; Is there a convinient place for all those constants?
1222     (flet ((tail-comp (string tail)
1223     (and (>= (length string) (length tail))
1224     (string= string tail :start1 (- (length string)
1225     (length tail))))))
1226     (remove-if-not
1227     (lambda (x) (and (tail-comp (symbol-name x) "-TYPE")
1228     (not (member x +lowtag-symbols+))
1229     (boundp x)
1230     (typep (symbol-value x) 'fixnum)))
1231     (append (apropos-list "-TYPE" "VM" t)
1232     (apropos-list "-TYPE" "BIGNUM" t)))))
1233    
1234 heller 1.62
1235     (defimplementation describe-primitive-type (object)
1236 dbarlow 1.1 (with-output-to-string (*standard-output*)
1237     (let* ((lowtag (kernel:get-lowtag object))
1238     (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1239     (format t "[lowtag: ~A" lowtag-symbol)
1240     (cond ((member lowtag (list vm:other-pointer-type
1241     vm:function-pointer-type
1242     vm:other-immediate-0-type
1243     vm:other-immediate-1-type
1244     ))
1245     (let* ((type (kernel:get-type object))
1246     (type-symbol (find type +header-type-symbols+
1247     :key #'symbol-value)))
1248     (format t ", type: ~A]" type-symbol)))
1249     (t (format t "]"))))))
1250    
1251 heller 1.62 (defimplementation inspected-parts (o)
1252 dbarlow 1.1 (cond ((di::indirect-value-cell-p o)
1253     (inspected-parts-of-value-cell o))
1254     (t
1255     (destructuring-bind (text labeledp . parts)
1256     (inspect::describe-parts o)
1257     (let ((parts (if labeledp
1258     (loop for (label . value) in parts
1259     collect (cons (string label) value))
1260     (loop for value in parts
1261     for i from 0
1262     collect (cons (format nil "~D" i) value)))))
1263     (values text parts))))))
1264    
1265 heller 1.55 (defun inspected-parts-of-value-cell (o)
1266     (values (format nil "~A~% is a value cell." o)
1267     (list (cons "Value" (c:value-cell-ref o)))))
1268    
1269 dbarlow 1.1 (defmethod inspected-parts ((o function))
1270     (let ((header (kernel:get-type o)))
1271     (cond ((= header vm:function-header-type)
1272     (values
1273     (format nil "~A~% is a function." o)
1274     (list (cons "Self" (kernel:%function-self o))
1275     (cons "Next" (kernel:%function-next o))
1276     (cons "Name" (kernel:%function-name o))
1277     (cons "Arglist" (kernel:%function-arglist o))
1278     (cons "Type" (kernel:%function-type o))
1279     (cons "Code Object" (kernel:function-code-header o)))))
1280     ((= header vm:closure-header-type)
1281     (values (format nil "~A~% is a closure." o)
1282     (list*
1283     (cons "Function" (kernel:%closure-function o))
1284     (loop for i from 0 below (- (kernel:get-closure-length o)
1285     (1- vm:closure-info-offset))
1286     collect (cons (format nil "~D" i)
1287     (kernel:%closure-index-ref o i))))))
1288     (t (call-next-method o)))))
1289    
1290     (defmethod inspected-parts ((o kernel:code-component))
1291     (values (format nil "~A~% is a code data-block." o)
1292     `(("First entry point" . ,(kernel:%code-entry-points o))
1293     ,@(loop for i from vm:code-constants-offset
1294     below (kernel:get-header-data o)
1295     collect (cons (format nil "Constant#~D" i)
1296     (kernel:code-header-ref o i)))
1297     ("Debug info" . ,(kernel:%code-debug-info o))
1298     ("Instructions" . ,(kernel:code-instructions o)))))
1299    
1300     (defmethod inspected-parts ((o kernel:fdefn))
1301     (values (format nil "~A~% is a fdefn object." o)
1302     `(("Name" . ,(kernel:fdefn-name o))
1303     ("Function" . ,(kernel:fdefn-function o)))))
1304 heller 1.58
1305    
1306     ;;;; Profiling
1307     (defimplementation profile (fname)
1308     (eval `(profile:profile ,fname)))
1309    
1310     (defimplementation unprofile (fname)
1311     (eval `(profile:unprofile ,fname)))
1312    
1313     (defimplementation unprofile-all ()
1314     (profile:unprofile)
1315     "All functions unprofiled.")
1316    
1317     (defimplementation profile-report ()
1318     (profile:report-time))
1319    
1320     (defimplementation profile-reset ()
1321     (profile:reset-time)
1322     "Reset profiling counters.")
1323    
1324     (defimplementation profiled-functions ()
1325     profile:*timed-functions*)
1326    
1327     (defimplementation profile-package (package callers methods)
1328     (profile:profile-all :package package
1329     :callers-p callers
1330     :methods methods))
1331 dbarlow 1.1
1332 lgorrie 1.42
1333     ;;;; Multiprocessing
1334    
1335     #+MP
1336     (progn
1337 lgorrie 1.56 (defimplementation startup-multiprocessing ()
1338 lgorrie 1.49 (setq *swank-in-background* :spawn)
1339     ;; Threads magic: this never returns! But top-level becomes
1340     ;; available again.
1341 lgorrie 1.42 (mp::startup-idle-and-top-level-loops))
1342 heller 1.54
1343 heller 1.59 (defimplementation spawn (fn &key (name "Anonymous"))
1344 heller 1.54 (mp:make-process fn :name name))
1345 lgorrie 1.42
1346 heller 1.61 (defimplementation thread-name (thread)
1347     (mp:process-name thread))
1348 lgorrie 1.42
1349 heller 1.61 (defimplementation thread-status (thread)
1350     (mp:process-whostate thread))
1351 lgorrie 1.42
1352 heller 1.61 (defimplementation current-thread ()
1353     mp:*current-process*)
1354 lgorrie 1.42
1355 heller 1.61 (defimplementation all-threads ()
1356     (copy-list mp:*all-processes*))
1357 heller 1.62
1358     (defimplementation interrupt-thread (thread fn)
1359     (mp:process-interrupt thread fn))
1360    
1361     (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
1362    
1363     (defstruct (mailbox (:conc-name mailbox.))
1364     (mutex (mp:make-lock "process mailbox"))
1365     (queue '() :type list))
1366    
1367     (defun mailbox (thread)
1368     "Return THREAD's mailbox."
1369     (mp:with-lock-held (*mailbox-lock*)
1370     (or (getf (mp:process-property-list thread) 'mailbox)
1371     (setf (getf (mp:process-property-list thread) 'mailbox)
1372     (make-mailbox)))))
1373    
1374     (defimplementation send (thread message)
1375     (let* ((mbox (mailbox thread))
1376     (mutex (mailbox.mutex mbox)))
1377     (mp:with-lock-held (mutex)
1378     (setf (mailbox.queue mbox)
1379     (nconc (mailbox.queue mbox) (list message))))))
1380    
1381     (defimplementation receive ()
1382     (let* ((mbox (mailbox mp:*current-process*))
1383     (mutex (mailbox.mutex mbox)))
1384     (mp:process-wait "receive" #'mailbox.queue mbox)
1385     (mp:with-lock-held (mutex)
1386     (pop (mailbox.queue mbox)))))
1387 heller 1.59
1388     )
1389 lgorrie 1.42
1390    
1391     ;;;; Epilogue
1392 dbarlow 1.1 ;;; Local Variables:
1393     ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1394     ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5