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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.70 - (hide annotations)
Tue Feb 24 23:31:34 2004 UTC (10 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.69: +5 -4 lines
* slime.el: Various bits of support for maintaining multiple SLIME
connections to different Lisp implementations simultaneously.

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

  ViewVC Help
Powered by ViewVC 1.1.5