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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5