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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5