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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (hide annotations)
Mon Dec 15 05:28:21 2003 UTC (10 years, 4 months ago) by lgorrie
Branch: MAIN
Changes since 1.41: +50 -0 lines
Implmemented the multiprocessing interface.
1 lgorrie 1.24 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2 dbarlow 1.1
3     (declaim (optimize debug))
4    
5     (in-package :swank)
6    
7 lgorrie 1.25 ;; Turn on xref. [should we?]
8     (setf c:*record-xref-info* t)
9    
10 heller 1.22 (defun without-interrupts* (body)
11     (sys:without-interrupts (funcall body)))
12    
13 dbarlow 1.1 (defun set-fd-non-blocking (fd)
14     (flet ((fcntl (fd cmd arg)
15     (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
16     (or flags
17     (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
18     (let ((flags (fcntl fd unix:F-GETFL 0)))
19     (fcntl fd unix:F-SETFL (logior flags unix:O_NONBLOCK)))))
20    
21 lgorrie 1.25
22     ;;;; TCP server.
23    
24 heller 1.28 (defun resolve-hostname (name)
25     (let* ((hostent (ext:lookup-host-entry name))
26     (address (car (ext:host-entry-addr-list hostent))))
27     (ext:htonl address)))
28    
29 heller 1.32 (defun create-swank-server (port &key (reuse-address t)
30 heller 1.36 (address "localhost")
31 heller 1.40 (announce #'simple-announce-function)
32     (background *start-swank-in-background*)
33     (close *close-swank-socket-after-setup*))
34 lgorrie 1.25 "Create a SWANK TCP server."
35 heller 1.28 (let* ((ip (resolve-hostname address))
36     (fd (ext:create-inet-listener port :stream
37     :reuse-address reuse-address
38     :host ip)))
39 heller 1.36 (funcall announce (nth-value 1 (ext::get-socket-host-and-port fd)))
40 heller 1.40 (accept-loop fd background close)))
41    
42     (defun emacs-io (fd)
43     "Create a new fd-stream for fd."
44     (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
45    
46     (defun add-input-handler (fd fn)
47     (system:add-fd-handler fd :input fn))
48    
49     (defun accept-loop (fd background close)
50     "Accept clients on the the server socket FD.
51     Use fd-handlers if BACKGROUND is non-nil. Close the server socket after the first client if CLOSE is non-nil, "
52     (cond (background
53     (add-input-handler
54     fd (lambda (fd) (accept-one-client fd background close))))
55     (close
56     (accept-one-client fd background close))
57     (t
58     (loop (accept-one-client fd background close)))))
59 lgorrie 1.25
60 heller 1.40 (defun accept-one-client (socket background close)
61     (let ((fd (ext:accept-tcp-connection socket)))
62     (when close
63     (sys:invalidate-descriptor socket)
64     (unix:unix-close socket))
65     (request-loop fd background)))
66    
67     (defun request-loop (fd background)
68     "Process all request from the socket FD."
69     (let* ((stream (emacs-io fd))
70     (out (if *use-dedicated-output-stream*
71     (open-stream-to-emacs stream)
72     (make-slime-output-stream)))
73     (in (make-slime-input-stream))
74     (io (make-two-way-stream in out)))
75     (cond (background
76     (add-input-handler
77     fd (lambda (fd)
78     (declare (ignore fd))
79     (serve-one-request stream out in io))))
80     (t (do () ((serve-one-request stream out in io)))))))
81    
82     (defun serve-one-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
83     "Read and process one request from a SWANK client.
84     The request is read from the socket as a sexp and then evaluated.
85     Return non-nil iff a reader-error occured."
86     (catch 'slime-toplevel
87     (with-simple-restart (abort "Return to Slime toplevel.")
88     (handler-case (read-from-emacs)
89     (slime-read-error (e)
90     (when *swank-debug-p*
91     (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
92     (sys:invalidate-descriptor (sys:fd-stream-fd *emacs-io*))
93     (close *emacs-io*)
94     (return-from serve-one-request t)))))
95     nil)
96 lgorrie 1.25
97 heller 1.40 (defun open-stream-to-emacs (*emacs-io*)
98 heller 1.28 "Return an output-stream to Emacs' output buffer."
99     (let* ((ip (resolve-hostname "localhost"))
100     (listener (ext:create-inet-listener 0 :stream :host ip))
101     (port (nth-value 1 (ext::get-socket-host-and-port listener))))
102     (unwind-protect
103     (progn
104     (eval-in-emacs `(slime-open-stream-to-lisp ,port))
105     (let ((fd (ext:accept-tcp-connection listener)))
106     (sys:make-fd-stream fd :output t)))
107     (ext:close-socket listener))))
108    
109 lgorrie 1.25
110     ;;;; Stream handling
111 dbarlow 1.1
112     (defstruct (slime-output-stream
113 heller 1.16 (:include lisp::lisp-stream
114     (lisp::misc #'sos/misc)
115     (lisp::out #'sos/out)
116     (lisp::sout #'sos/sout))
117 heller 1.17 (:conc-name sos.)
118     (:print-function %print-slime-output-stream))
119 heller 1.16 (buffer (make-string 512) :type string)
120     (index 0 :type kernel:index)
121     (column 0 :type kernel:index))
122    
123 heller 1.17 (defun %print-slime-output-stream (s stream d)
124     (declare (ignore d))
125     (print-unreadable-object (s stream :type t :identity t)))
126    
127 heller 1.16 (defun sos/out (stream char)
128     (let ((buffer (sos.buffer stream))
129     (index (sos.index stream)))
130     (setf (schar buffer index) char)
131     (setf (sos.index stream) (1+ index))
132     (incf (sos.column stream))
133 heller 1.21 (when (char= #\newline char)
134     (setf (sos.column stream) 0))
135     (when (= index (1- (length buffer)))
136     (force-output stream)))
137 heller 1.16 char)
138    
139     (defun sos/sout (stream string start end)
140     (loop for i from start below end
141     do (sos/out stream (aref string i))))
142    
143     (defun sos/misc (stream operation &optional arg1 arg2)
144     (declare (ignore arg1 arg2))
145 dbarlow 1.1 (case operation
146 heller 1.17 ((:force-output :finish-output)
147 heller 1.16 (let ((end (sos.index stream)))
148     (unless (zerop end)
149     (send-to-emacs `(:read-output ,(subseq (sos.buffer stream) 0 end)))
150     (setf (sos.index stream) 0))))
151     (:charpos (sos.column stream))
152     (:line-length 75)
153 dbarlow 1.1 (:file-position nil)
154 heller 1.16 (:element-type 'base-char)
155     (:get-command nil)
156 heller 1.22 (:close nil)
157 heller 1.16 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
158 dbarlow 1.1
159 heller 1.9 (defstruct (slime-input-stream
160 heller 1.16 (:include string-stream
161     (lisp::in #'sis/in)
162     (lisp::misc #'sis/misc))
163 heller 1.17 (:conc-name sis.)
164     (:print-function %print-slime-output-stream))
165 heller 1.16 (buffer "" :type string)
166     (index 0 :type kernel:index))
167    
168     (defun sis/in (stream eof-errorp eof-value)
169 heller 1.18 (declare (ignore eof-errorp eof-value))
170 heller 1.16 (let ((index (sis.index stream))
171     (buffer (sis.buffer stream)))
172     (when (= index (length buffer))
173     (setf buffer (slime-read-string))
174     (setf (sis.buffer stream) buffer)
175     (setf index 0))
176     (prog1 (aref buffer index)
177     (setf (sis.index stream) (1+ index)))))
178 heller 1.9
179 heller 1.16 (defun sis/misc (stream operation &optional arg1 arg2)
180 heller 1.14 (declare (ignore arg2))
181 heller 1.15 (ecase operation
182     (:file-position nil)
183 heller 1.16 (:file-length nil)
184     (:unread (setf (aref (sis.buffer stream)
185     (decf (sis.index stream)))
186     arg1))
187     (:clear-input (setf (sis.index stream) 0
188     (sis.buffer stream) ""))
189     (:listen (< (sis.index stream) (length (sis.buffer stream))))
190     (:charpos nil)
191     (:line-length nil)
192     (:get-command nil)
193 heller 1.22 (:element-type 'base-char)
194     (:close nil)))
195 heller 1.16
196 lgorrie 1.25
197 dbarlow 1.1 ;;;; Compilation Commands
198    
199 heller 1.19 (defvar *swank-source-info* nil
200     "Bound to a SOURCE-INFO object during compilation.")
201 dbarlow 1.1
202 lgorrie 1.24 (defvar *previous-compiler-condition* nil
203     "Used to detect duplicates.")
204    
205     (defvar *previous-context* nil
206     "Previous compiler error context.")
207    
208     (defvar *compiler-notes* '()
209     "List of compiler notes for the last compilation unit.")
210    
211 heller 1.30 (defvar *buffer-name* nil)
212     (defvar *buffer-start-position* nil)
213     (defvar *buffer-substring* nil)
214     (defvar *compile-filename* nil)
215    
216 lgorrie 1.25
217 lgorrie 1.24 ;;;;; Trapping notes
218    
219     (defun handle-notification-condition (condition)
220 dbarlow 1.1 "Handle a condition caused by a compiler warning.
221     This traps all compiler conditions at a lower-level than using
222     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
223     craft our own error messages, which can omit a lot of redundant
224     information."
225     (unless (eq condition *previous-compiler-condition*)
226     (let ((context (or (c::find-error-context nil) *previous-context*)))
227     (setq *previous-compiler-condition* condition)
228     (setq *previous-context* context)
229 lgorrie 1.24 (signal-compiler-condition condition context))))
230    
231     (defun signal-compiler-condition (condition context)
232     (signal (make-condition
233     'compiler-condition
234     :original-condition condition
235     :severity (severity-for-emacs condition)
236     :message (brief-compiler-message-for-emacs condition context)
237     :location (compiler-note-location context))))
238    
239     (defun severity-for-emacs (condition)
240     "Return the severity of CONDITION."
241     (etypecase condition
242     (c::compiler-error :error)
243     (c::style-warning :note)
244     (c::warning :warning)))
245    
246     (defun brief-compiler-message-for-emacs (condition error-context)
247     "Briefly describe a compiler error for Emacs.
248     When Emacs presents the message it already has the source popped up
249     and the source form highlighted. This makes much of the information in
250     the error-context redundant."
251     (declare (type (or c::compiler-error-context null) error-context))
252 heller 1.30 (multiple-value-bind (enclosing source)
253     (if error-context
254     (values (c::compiler-error-context-enclosing-source error-context)
255     (c::compiler-error-context-source error-context)))
256     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
257     enclosing source condition)))
258    
259 heller 1.31
260 heller 1.30 (defun compiler-note-location (context)
261     (cond (context
262     (resolve-note-location
263     *buffer-name*
264     (c::compiler-error-context-file-name context)
265     (c::compiler-error-context-file-position context)
266     (reverse (c::compiler-error-context-original-source-path context))
267     (c::compiler-error-context-original-source context)))
268     (t
269     (resolve-note-location *buffer-name* nil nil nil nil))))
270    
271     (defgeneric resolve-note-location (buffer file-name file-position
272     source-path source))
273    
274     (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
275     (make-location
276     `(:file ,(unix-truename f))
277     `(:position ,(1+ (source-path-file-position path f)))))
278    
279     (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
280     (make-location
281     `(:buffer ,b)
282     `(:position ,(+ *buffer-start-position*
283     (source-path-string-position path *buffer-substring*)))))
284    
285 heller 1.32 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
286     (make-location
287     `(:source-form ,source)
288     `(:position 1)))
289    
290 heller 1.30 (defmethod resolve-note-location (buffer
291     (file (eql nil))
292     (pos (eql nil))
293     (path (eql nil))
294     (source (eql nil)))
295     (cond (buffer
296     (make-location (list :buffer buffer)
297     (list :position *buffer-start-position*)))
298     (*compile-file-truename*
299     (make-location (list :file (namestring *compile-file-truename*))
300     (list :position 0)))
301     (*compile-filename*
302 dbarlow 1.38 ;; XXX is this _ever_ used? By what? *compile-file-truename*
303     ;; should be set by the implementation inside any call to compile-file
304 heller 1.30 (make-location (list :file *compile-filename*) (list :position 0)))
305     (t
306     (list :error "No error location available"))))
307 dbarlow 1.1
308 dbarlow 1.38 (defmethod call-with-compilation-hooks (function)
309     (let ((*previous-compiler-condition* nil)
310     (*previous-context* nil)
311     (*print-readably* nil))
312 lgorrie 1.24 (handler-bind ((c::compiler-error #'handle-notification-condition)
313     (c::style-warning #'handle-notification-condition)
314     (c::warning #'handle-notification-condition))
315 dbarlow 1.38 (funcall function))))
316 lgorrie 1.24
317     (defmethod compile-file-for-emacs (filename load-p)
318     (clear-xref-info filename)
319     (with-compilation-hooks ()
320 heller 1.30 (let ((*buffer-name* nil)
321     (*compile-filename* filename))
322 heller 1.40 (multiple-value-bind (fasl-file warnings-p failure-p)
323     (compile-file filename)
324     (declare (ignore warnings-p))
325     (when (and load-p (not failure-p))
326     (load fasl-file))))))
327 lgorrie 1.24
328     (defmethod compile-string-for-emacs (string &key buffer position)
329     (with-compilation-hooks ()
330     (let ((*package* *buffer-package*)
331 heller 1.30 (*compile-filename* nil)
332     (*buffer-name* buffer)
333     (*buffer-start-position* position)
334     (*buffer-substring* string))
335 lgorrie 1.24 (with-input-from-string (stream string)
336     (ext:compile-from-stream
337     stream
338     :source-info `(:emacs-buffer ,buffer
339     :emacs-buffer-offset ,position
340     :emacs-buffer-string ,string))))))
341 dbarlow 1.1
342 heller 1.41 (defmethod compile-system-for-emacs (system-name)
343     (with-compilation-hooks ()
344     (cond ((ext:featurep :asdf)
345     (let ((operate (find-symbol (string :operate) :asdf))
346     (load-op (find-symbol (string :load-op) :asdf)))
347     (funcall operate load-op system-name)))
348     (t (error "ASDF not loaded")))))
349    
350 lgorrie 1.25
351     ;;;; XREF
352 dbarlow 1.1
353 heller 1.30 (defun lookup-xrefs (finder name)
354     (xref-results-for-emacs (funcall finder (from-string name))))
355    
356 dbarlow 1.1 (defslimefun who-calls (function-name)
357     "Return the places where FUNCTION-NAME is called."
358 heller 1.30 (lookup-xrefs #'xref:who-calls function-name))
359 dbarlow 1.1
360     (defslimefun who-references (variable)
361     "Return the places where the global variable VARIABLE is referenced."
362 heller 1.30 (lookup-xrefs #'xref:who-references variable))
363 dbarlow 1.1
364     (defslimefun who-binds (variable)
365     "Return the places where the global variable VARIABLE is bound."
366 heller 1.30 (lookup-xrefs #'xref:who-binds variable))
367 dbarlow 1.1
368     (defslimefun who-sets (variable)
369     "Return the places where the global variable VARIABLE is set."
370 heller 1.30 (lookup-xrefs #'xref:who-sets variable))
371 dbarlow 1.1
372 lgorrie 1.10 #+cmu19
373 heller 1.32 (progn
374     (defslimefun who-macroexpands (macro)
375     "Return the places where MACRO is expanded."
376     (lookup-xrefs #'xref:who-macroexpands macro))
377    
378     (defslimefun who-specializes (class)
379     "Return the methods with specializers for CLASS."
380     (let* ((methods (xref::who-specializes (find-class (from-string class))))
381     (locations (mapcar #'method-source-location methods)))
382     (group-xrefs (mapcar (lambda (m l)
383     (cons (let ((*print-pretty* nil))
384     (to-string m))
385     l))
386     methods locations))))
387     )
388 heller 1.30
389     (defun resolve-xref-location (xref)
390     (let ((name (xref:xref-context-name xref))
391     (file (xref:xref-context-file xref))
392     (source-path (xref:xref-context-source-path xref)))
393     (cond ((and file source-path)
394     (let ((position (source-path-file-position source-path file)))
395     (make-location (list :file (unix-truename file))
396     (list :position (1+ position)))))
397     (file
398     (make-location (list :file (unix-truename file))
399     (list :function-name (string name))))
400     (t
401     `(:error ,(format nil "Unkown source location: ~S ~S ~S "
402     name file source-path))))))
403    
404 dbarlow 1.1
405     (defun xref-results-for-emacs (contexts)
406     "Prepare a list of xref contexts for Emacs.
407 heller 1.29 The result is a list of xrefs:
408     group ::= (FILENAME . ({reference}+))
409     reference ::= (FUNCTION-SPECIFIER . SOURCE-LOCATION)"
410     (let ((xrefs '()))
411     (dolist (cxt contexts)
412 heller 1.30 (let ((name (xref:xref-context-name cxt)))
413 heller 1.29 (push (cons (to-string name)
414 heller 1.30 (resolve-xref-location cxt))
415 heller 1.29 xrefs)))
416     (group-xrefs xrefs)))
417    
418    
419     (defun location-buffer= (location1 location2)
420     (equalp location1 location2))
421    
422 dbarlow 1.1 (defun file-xrefs-for-emacs (unix-filename contexts)
423     "Return a summary of the references from a particular file.
424     The result is a list of the form (FILENAME ((REFERRER SOURCE-PATH) ...))"
425     (list unix-filename
426     (loop for context in (sort-contexts-by-source-path contexts)
427     collect (list (let ((*print-pretty* nil))
428     (to-string (xref:xref-context-name context)))
429     (xref:xref-context-source-path context)))))
430    
431     (defun sort-contexts-by-source-path (contexts)
432     "Sort xref contexts by lexical position of source-paths.
433     It is assumed that all contexts belong to the same file."
434     (sort contexts #'source-path< :key #'xref:xref-context-source-path))
435    
436     (defun source-path< (path1 path2)
437     "Return true if PATH1 is lexically before PATH2."
438     (and (every #'< path1 path2)
439     (< (length path1) (length path2))))
440    
441 lgorrie 1.25 (defun clear-xref-info (namestring)
442     "Clear XREF notes pertaining to FILENAME.
443     This is a workaround for a CMUCL bug: XREF records are cumulative."
444     (let ((filename (parse-namestring namestring)))
445     (when c:*record-xref-info*
446     (dolist (db (list xref::*who-calls*
447     #+cmu19 xref::*who-is-called*
448     #+cmu19 xref::*who-macroexpands*
449     xref::*who-references*
450     xref::*who-binds*
451     xref::*who-sets*))
452     (maphash (lambda (target contexts)
453     (setf (gethash target db)
454     (delete-if
455     (lambda (ctx)
456     (xref-context-derived-from-p ctx filename))
457     contexts)))
458     db)))))
459    
460     (defun xref-context-derived-from-p (context filename)
461     (let ((xref-file (xref:xref-context-file context)))
462     (and xref-file (pathname= filename xref-file))))
463    
464     (defun pathname= (&rest pathnames)
465     "True if PATHNAMES refer to the same file."
466     (apply #'string= (mapcar #'unix-truename pathnames)))
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     (defslimefun 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.18
582 dbarlow 1.1 (defslimefun list-callees (symbol-name)
583 heller 1.30 (let ((fns (function-callees (from-string symbol-name))))
584     (group-xrefs (mapcar (lambda (fn)
585     (cons (to-string (kernel:%function-name fn))
586     (function-source-location fn)))
587     fns))))
588 dbarlow 1.1
589 lgorrie 1.42
590 dbarlow 1.1 ;;;; Definitions
591    
592 lgorrie 1.35 (defvar *debug-definition-finding* nil
593 dbarlow 1.1 "When true don't handle errors while looking for definitions.
594     This is useful when debugging the definition-finding code.")
595    
596 heller 1.29 (defmacro safe-definition-finding (&body body)
597     "Execute BODY ignoring errors. Return a the source location
598     returned by BODY or if an error occurs a description of the error.
599     The second return value is the condition or nil."
600     `(flet ((body () ,@body))
601     (if *debug-definition-finding*
602     (body)
603     (handler-case (values (progn ,@body) nil)
604     (error (c) (values (list :error (princ-to-string c)) c))))))
605    
606 dbarlow 1.1 (defun function-first-code-location (function)
607     (and (function-has-debug-function-p function)
608     (di:debug-function-start-location
609     (di:function-debug-function function))))
610    
611     (defun function-has-debug-function-p (function)
612     (di:function-debug-function function))
613    
614     (defun function-code-object= (closure function)
615     (and (eq (vm::find-code-object closure)
616     (vm::find-code-object function))
617     (not (eq closure function))))
618    
619 heller 1.4 (defun struct-closure-p (function)
620     (or (function-code-object= function #'kernel::structure-slot-accessor)
621     (function-code-object= function #'kernel::structure-slot-setter)
622     (function-code-object= function #'kernel::%defstruct)))
623 dbarlow 1.1
624 heller 1.4 (defun struct-closure-dd (function)
625 dbarlow 1.1 (assert (= (kernel:get-type function) vm:closure-header-type))
626 heller 1.4 (flet ((find-layout (function)
627     (sys:find-if-in-closure
628     (lambda (x)
629 heller 1.18 (let ((value (if (di::indirect-value-cell-p x)
630     (c:value-cell-ref x)
631     x)))
632     (when (kernel::layout-p value)
633     (return-from find-layout value))))
634 heller 1.4 function)))
635     (kernel:layout-info (find-layout function))))
636    
637 dbarlow 1.1 (defun dd-source-location (dd)
638     (let ((constructor (or (kernel:dd-default-constructor dd)
639 heller 1.32 (car (kernel::dd-constructors dd)))))
640     (when (or (not constructor) (and (consp constructor)
641     (not (car constructor))))
642     (error "Cannot locate struct without constructor: ~S"
643     (kernel::dd-name dd)))
644     (function-source-location
645     (coerce (if (consp constructor) (car constructor) constructor)
646     'function))))
647 dbarlow 1.1
648 heller 1.27 (defun genericp (fn)
649     (typep fn 'generic-function))
650    
651     (defun gf-definition-location (gf)
652     (flet ((guess-source-file (faslfile)
653     (unix-truename
654     (merge-pathnames (make-pathname :type "lisp")
655     faslfile))))
656     (let ((def-source (pcl::definition-source gf))
657     (name (string (pcl:generic-function-name gf))))
658     (etypecase def-source
659 heller 1.30 (pathname (make-location
660     `(:file ,(guess-source-file def-source))
661     `(:function-name ,name)))
662 heller 1.27 (cons
663     (destructuring-bind ((dg name) pathname) def-source
664     (declare (ignore dg))
665 heller 1.30 (etypecase pathname
666     (pathname
667     (make-location `(:file ,(guess-source-file pathname))
668     `(:function-name ,(string name)))))))))))
669 heller 1.27
670     (defun method-source-location (method)
671     (function-source-location (or (pcl::method-fast-function method)
672     (pcl:method-function method))))
673    
674     (defun gf-method-locations (gf)
675     (let ((ms (pcl::generic-function-methods gf)))
676     (mapcar #'method-source-location ms)))
677    
678     (defun gf-source-locations (gf)
679     (list* (gf-definition-location gf)
680     (gf-method-locations gf)))
681    
682 heller 1.29 (defun function-source-locations (function)
683     "Return a list of source locations for FUNCTION."
684 dbarlow 1.1 ;; First test if FUNCTION is a closure created by defstruct; if so
685     ;; extract the defstruct-description (dd) from the closure and find
686     ;; the constructor for the struct. Defstruct creates a defun for
687     ;; the default constructor and we use that as an approximation to
688     ;; the source location of the defstruct.
689     ;;
690     ;; For an ordinary function we return the source location of the
691     ;; first code-location we find.
692 heller 1.4 (cond ((struct-closure-p function)
693 heller 1.29 (list
694     (safe-definition-finding
695     (dd-source-location (struct-closure-dd function)))))
696 heller 1.27 ((genericp function)
697 heller 1.29 (gf-source-locations function))
698 heller 1.27 (t
699 heller 1.29 (list
700     (multiple-value-bind (code-location error)
701     (safe-definition-finding (function-first-code-location function))
702     (cond (error (list :error (princ-to-string error)))
703     (t (code-location-source-location code-location))))))))
704    
705     (defun function-source-location (function)
706     (destructuring-bind (first) (function-source-locations function)
707     first))
708 dbarlow 1.1
709 heller 1.34 (defmethod find-function-locations (symbol-name)
710 heller 1.29 "Return a list of source-locations for SYMBOL-NAME's functions."
711     (multiple-value-bind (symbol foundp) (find-symbol-designator symbol-name)
712     (cond ((not foundp)
713     (list (list :error (format nil "Unkown symbol: ~A" symbol-name))))
714     ((macro-function symbol)
715     (function-source-locations (macro-function symbol)))
716     ((special-operator-p symbol)
717 heller 1.31 (list (list :error (format nil "~A is a special-operator" symbol))))
718 heller 1.29 ((fboundp symbol)
719     (function-source-locations (coerce symbol 'function)))
720     (t (list (list :error
721     (format nil "Symbol not fbound: ~A" symbol-name))))
722     )))
723    
724 lgorrie 1.25
725     ;;;; Documentation.
726 dbarlow 1.1
727 lgorrie 1.24 (defmethod describe-symbol-for-emacs (symbol)
728 dbarlow 1.1 (let ((result '()))
729 lgorrie 1.24 (flet ((doc (kind)
730     (or (documentation symbol kind) :not-documented))
731     (maybe-push (property value)
732     (when value
733     (setf result (list* property value result)))))
734 dbarlow 1.1 (maybe-push
735     :variable (multiple-value-bind (kind recorded-p)
736     (ext:info variable kind symbol)
737     (declare (ignore kind))
738     (if (or (boundp symbol) recorded-p)
739     (doc 'variable))))
740     (maybe-push
741 heller 1.27 :generic-function
742     (if (and (fboundp symbol)
743     (typep (fdefinition symbol) 'generic-function))
744     (doc 'function)))
745     (maybe-push
746     :function (if (and (fboundp symbol)
747     (not (typep (fdefinition symbol) 'generic-function)))
748     (doc 'function)))
749 dbarlow 1.1 (maybe-push
750     :setf (if (or (ext:info setf inverse symbol)
751     (ext:info setf expander symbol))
752     (doc 'setf)))
753     (maybe-push
754     :type (if (ext:info type kind symbol)
755     (doc 'type)))
756     (maybe-push
757     :class (if (find-class symbol nil)
758     (doc 'class)))
759 heller 1.18 (maybe-push
760     :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
761     (doc 'alien-type)))
762     (maybe-push
763     :alien-struct (if (ext:info alien-type struct symbol)
764     (doc nil)))
765     (maybe-push
766     :alien-union (if (ext:info alien-type union symbol)
767     (doc nil)))
768     (maybe-push
769     :alien-enum (if (ext:info alien-type enum symbol)
770     (doc nil)))
771 lgorrie 1.24 result)))
772 dbarlow 1.1
773     (defslimefun describe-setf-function (symbol-name)
774 dbarlow 1.3 (print-description-to-string
775 dbarlow 1.1 (or (ext:info setf inverse (from-string symbol-name))
776     (ext:info setf expander (from-string symbol-name)))))
777    
778     (defslimefun describe-type (symbol-name)
779 dbarlow 1.3 (print-description-to-string
780 dbarlow 1.1 (kernel:values-specifier-type (from-string symbol-name))))
781    
782     (defslimefun describe-class (symbol-name)
783 dbarlow 1.3 (print-description-to-string (find-class (from-string symbol-name) nil)))
784 dbarlow 1.1
785 heller 1.18 (defslimefun describe-alien-type (symbol-name)
786     (let ((name (from-string symbol-name)))
787     (ecase (ext:info :alien-type :kind name)
788     (:primitive
789     (print-description-to-string
790     (let ((alien::*values-type-okay* t))
791     (funcall (ext:info :alien-type :translator name) (list name)))))
792     ((:defined)
793     (print-description-to-string (ext:info :alien-type :definition name)))
794     (:unknown
795     (format nil "Unkown alien type: ~A" symbol-name)))))
796    
797     (defmacro %describe-alien (symbol-name namespace)
798     `(print-description-to-string
799     (ext:info :alien-type ,namespace (from-string ,symbol-name))))
800    
801     (defslimefun describe-alien-struct (symbol-name)
802     (%describe-alien symbol-name :struct))
803    
804     (defslimefun describe-alien-union (symbol-name)
805     (%describe-alien symbol-name :union))
806    
807     (defslimefun describe-alien-enum (symbol-name)
808     (%describe-alien symbol-name :enum))
809    
810 lgorrie 1.25 (defmethod arglist-string (fname)
811     "Return a string describing the argument list for FNAME.
812     The result has the format \"(...)\"."
813     (declare (type string fname))
814     (multiple-value-bind (function condition)
815     (ignore-errors (values (find-symbol-designator fname *buffer-package*)))
816     (when condition
817     (return-from arglist-string (format nil "(-- ~A)" condition)))
818     (let ((arglist
819     (if (not (or (fboundp function)
820     (functionp function)))
821     "(-- <Unknown-Function>)"
822     (let* ((fun (or (macro-function function)
823     (symbol-function function)))
824     (df (di::function-debug-function fun))
825     (arglist (kernel:%function-arglist fun)))
826     (cond ((eval:interpreted-function-p fun)
827     (eval:interpreted-function-arglist fun))
828     ((pcl::generic-function-p fun)
829     (pcl::gf-pretty-arglist fun))
830     (arglist arglist)
831     ;; this should work both for
832     ;; compiled-debug-function and for
833     ;; interpreted-debug-function
834     (df (di::debug-function-lambda-list df))
835     (t "(<arglist-unavailable>)"))))))
836     (if (stringp arglist)
837     arglist
838     (to-string arglist)))))
839    
840    
841     ;;;; Miscellaneous.
842 dbarlow 1.1
843 lgorrie 1.24 (defmethod macroexpand-all (form)
844     (walker:macroexpand-all form))
845 dbarlow 1.1
846 heller 1.37 (in-package :c)
847    
848     (defun swank::expand-ir1-top-level (form)
849     "A scaled down version of the first pass of the compiler."
850     (with-compilation-unit ()
851     (let* ((*lexical-environment*
852     (make-lexenv :default (make-null-environment)
853     :cookie *default-cookie*
854     :interface-cookie *default-interface-cookie*))
855     (*source-info* (make-lisp-source-info form))
856     (*block-compile* nil)
857     (*block-compile-default* nil))
858     (with-ir1-namespace
859     (clear-stuff)
860     (find-source-paths form 0)
861     (ir1-top-level form '(0) t)))))
862    
863     (in-package :swank)
864    
865     (defslimefun print-ir1-converted-blocks (form)
866     (with-output-to-string (*standard-output*)
867     (c::print-all-blocks (expand-ir1-top-level (from-string form)))))
868 lgorrie 1.25
869     (defslimefun set-default-directory (directory)
870     (setf (ext:default-directory) (namestring directory))
871     ;; Setting *default-pathname-defaults* to an absolute directory
872     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
873     (setf *default-pathname-defaults* (pathname (ext:default-directory)))
874     (namestring (ext:default-directory)))
875    
876 dbarlow 1.39 ;;; source-path-{stream,file,string,etc}-position moved into
877     ;;; swank-source-path-parser
878 heller 1.19
879     (defun code-location-stream-position (code-location stream)
880     "Return the byte offset of CODE-LOCATION in STREAM. Extract the
881     toplevel-form-number and form-number from CODE-LOCATION and use that
882     to find the position of the corresponding form."
883     (let* ((location (debug::maybe-block-start-location code-location))
884     (tlf-offset (di:code-location-top-level-form-offset location))
885     (form-number (di:code-location-form-number location))
886     (*read-suppress* t))
887     (dotimes (i tlf-offset) (read stream))
888     (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
889     (let* ((path-table (di:form-number-translations tlf 0))
890 heller 1.30 (source-path
891     (if (<= (length path-table) form-number) ; source out of sync?
892     (list 0) ; should probably signal a condition
893     (reverse (cdr (aref path-table form-number))))))
894 heller 1.19 (source-path-source-position source-path tlf position-map)))))
895    
896     (defun code-location-string-offset (code-location string)
897     (with-input-from-string (s string)
898     (code-location-stream-position code-location s)))
899    
900     (defun code-location-file-position (code-location filename)
901     (with-open-file (s filename :direction :input)
902     (code-location-stream-position code-location s)))
903    
904     (defun debug-source-info-from-emacs-buffer-p (debug-source)
905     (let ((info (c::debug-source-info debug-source)))
906     (and info
907     (consp info)
908     (eq :emacs-buffer (car info)))))
909    
910 heller 1.30 (defun source-location-from-code-location (code-location)
911 heller 1.29 "Return the source location for CODE-LOCATION."
912 heller 1.30 (let ((debug-fun (di:code-location-debug-function code-location)))
913     (when (di::bogus-debug-function-p debug-fun)
914     (error "Bogus debug function: ~A" debug-fun)))
915 heller 1.19 (let* ((debug-source (di:code-location-debug-source code-location))
916 heller 1.30 (from (di:debug-source-from debug-source))
917     (name (di:debug-source-name debug-source)))
918 heller 1.19 (ecase from
919 heller 1.32 (:file
920     (make-location (list :file (unix-truename name))
921     (list :position (1+ (code-location-file-position
922     code-location name)))))
923 heller 1.19 (:stream
924     (assert (debug-source-info-from-emacs-buffer-p debug-source))
925     (let ((info (c::debug-source-info debug-source)))
926 heller 1.32 (make-location
927     (list :buffer (getf info :emacs-buffer))
928     (list :position (+ (getf info :emacs-buffer-offset)
929     (code-location-string-offset
930     code-location
931     (getf info :emacs-buffer-string)))))))
932 heller 1.19 (:lisp
933 heller 1.32 (make-location
934     (list :source-form (with-output-to-string (*standard-output*)
935     (debug::print-code-location-source-form
936     code-location 100 t)))
937     (list :position 1))))))
938 heller 1.19
939 heller 1.29 (defun code-location-source-location (code-location)
940     "Safe wrapper around `code-location-from-source-location'."
941     (safe-definition-finding
942 heller 1.30 (source-location-from-code-location code-location)))
943 dbarlow 1.1
944 lgorrie 1.25 (defslimefun getpid ()
945     (unix:unix-getpid))
946    
947 dbarlow 1.1
948 lgorrie 1.25 ;;;; Debugging
949 dbarlow 1.1
950     (defvar *sldb-stack-top*)
951     (defvar *sldb-restarts*)
952    
953 lgorrie 1.25 (defmethod call-with-debugging-environment (debugger-loop-fn)
954 dbarlow 1.1 (unix:unix-sigsetmask 0)
955 lgorrie 1.25 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
956 dbarlow 1.1 (*sldb-restarts* (compute-restarts *swank-debugger-condition*))
957     (debug:*stack-top-hint* nil)
958     (*debugger-hook* nil)
959     (*readtable* (or debug:*debug-readtable* *readtable*))
960     (*print-level* debug:*debug-print-level*)
961 heller 1.30 (*print-length* debug:*debug-print-length*)
962     (*print-readably* nil))
963 dbarlow 1.1 (handler-bind ((di:debug-condition
964     (lambda (condition)
965 lgorrie 1.25 (signal (make-condition
966     'sldb-condition
967     :original-condition condition)))))
968     (funcall debugger-loop-fn))))
969 dbarlow 1.1
970     (defun format-restarts-for-emacs ()
971     "Return a list of restarts for *swank-debugger-condition* in a
972     format suitable for Emacs."
973     (loop for restart in *sldb-restarts*
974     collect (list (princ-to-string (restart-name restart))
975     (princ-to-string restart))))
976    
977     (defun format-condition-for-emacs ()
978     (format nil "~A~% [Condition of type ~S]"
979     (debug::safe-condition-message *swank-debugger-condition*)
980     (type-of *swank-debugger-condition*)))
981    
982     (defun nth-frame (index)
983     (do ((frame *sldb-stack-top* (di:frame-down frame))
984     (i index (1- i)))
985     ((zerop i) frame)))
986    
987     (defun nth-restart (index)
988     (nth index *sldb-restarts*))
989    
990     (defun format-frame-for-emacs (frame)
991 heller 1.33 (with-output-to-string (*standard-output*)
992     (let ((*print-pretty* *sldb-pprint-frames*))
993     (debug::print-frame-call frame :verbosity 1 :number t))))
994 dbarlow 1.1
995     (defun compute-backtrace (start end)
996     "Return a list of frames starting with frame number START and
997     continuing to frame number END or, if END is nil, the last frame on the
998     stack."
999     (let ((end (or end most-positive-fixnum)))
1000     (loop for f = (nth-frame start) then (di:frame-down f)
1001     for i from start below end
1002     while f
1003 heller 1.33 collect (cons i f))))
1004 dbarlow 1.1
1005 lgorrie 1.26 (defmethod backtrace (start end)
1006 heller 1.33 (loop for (n . frame) in (compute-backtrace start end)
1007     collect (list n (format-frame-for-emacs frame))))
1008 dbarlow 1.1
1009 lgorrie 1.25 (defmethod debugger-info-for-emacs (start end)
1010 dbarlow 1.1 (list (format-condition-for-emacs)
1011     (format-restarts-for-emacs)
1012 lgorrie 1.26 (backtrace start end)))
1013 dbarlow 1.1
1014 lgorrie 1.26 (defmethod frame-source-location-for-emacs (index)
1015 heller 1.29 (code-location-source-location (di:frame-code-location (nth-frame index))))
1016 dbarlow 1.1
1017 lgorrie 1.26 (defmethod eval-in-frame (form index)
1018     (di:eval-in-frame (nth-frame index) form))
1019 heller 1.19
1020     (defslimefun pprint-eval-string-in-frame (string index)
1021 heller 1.23 (swank-pprint
1022     (multiple-value-list
1023     (di:eval-in-frame (nth-frame index) (from-string string)))))
1024 dbarlow 1.1
1025 heller 1.13 (defslimefun inspect-in-frame (string index)
1026     (reset-inspector)
1027     (inspect-object (di:eval-in-frame (nth-frame index) (from-string string))))
1028    
1029 lgorrie 1.26 (defmethod frame-locals (index)
1030 dbarlow 1.1 (let* ((frame (nth-frame index))
1031     (location (di:frame-code-location frame))
1032     (debug-function (di:frame-debug-function frame))
1033     (debug-variables (di::debug-function-debug-variables debug-function)))
1034     (loop for v across debug-variables
1035 heller 1.37 for symbol = (di:debug-variable-symbol v)
1036     for id = (di:debug-variable-id v)
1037     for validy = (di:debug-variable-validity v location)
1038     collect (list :symbol symbol :id id
1039 dbarlow 1.1 :value-string
1040 heller 1.37 (ecase validy
1041     (:valid (to-string (di:debug-variable-value v frame)))
1042     ((:invalid :unknown) "<not-available>"))))))
1043 dbarlow 1.1
1044 lgorrie 1.26 (defmethod frame-catch-tags (index)
1045 dbarlow 1.1 (loop for (tag . code-location) in (di:frame-catches (nth-frame index))
1046 heller 1.29 collect `(,tag . ,(code-location-source-location code-location))))
1047 dbarlow 1.1
1048     (defslimefun invoke-nth-restart (index)
1049 heller 1.31 (invoke-restart-interactively (nth-restart index)))
1050 dbarlow 1.1
1051     (defslimefun sldb-abort ()
1052     (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
1053 heller 1.33
1054     (defun set-step-breakpoints (frame)
1055     (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1056     (di:frame-code-location frame)))
1057     (error "Cannot step, in elsewhere code~%"))
1058     (let* ((code-location (di:frame-code-location frame))
1059 heller 1.36 (debug::*bad-code-location-types*
1060     (remove :call-site debug::*bad-code-location-types*))
1061 heller 1.33 (next (debug::next-code-locations code-location)))
1062     (cond (next
1063     (let ((steppoints '()))
1064     (flet ((hook (frame breakpoint)
1065     (let ((debug:*stack-top-hint* frame))
1066 heller 1.36 (mapc #'di:delete-breakpoint steppoints)
1067     (let ((cl (di::breakpoint-what breakpoint)))
1068     (break "Breakpoint: ~S ~S"
1069     (di:code-location-kind cl)
1070     (di::compiled-code-location-pc cl))))))
1071 heller 1.33 (dolist (code-location next)
1072     (let ((bp (di:make-breakpoint #'hook code-location
1073     :kind :code-location)))
1074     (di:activate-breakpoint bp)
1075     (push bp steppoints))))))
1076     (t
1077     (flet ((hook (frame breakpoint values cookie)
1078     (declare (ignore cookie))
1079 heller 1.36 (di:delete-breakpoint breakpoint)
1080 heller 1.33 (let ((debug:*stack-top-hint* frame))
1081     (break "Function-end: ~A ~A" breakpoint values))))
1082     (let* ((debug-function (di:frame-debug-function frame))
1083     (bp (di:make-breakpoint #'hook debug-function
1084     :kind :function-end)))
1085     (di:activate-breakpoint bp)))))))
1086    
1087     (defslimefun sldb-step (frame)
1088     (cond ((find-restart 'continue *swank-debugger-condition*)
1089     (set-step-breakpoints (nth-frame frame))
1090     (continue *swank-debugger-condition*))
1091     (t
1092     (error "Cannot continue in from condition: ~A"
1093     *swank-debugger-condition*))))
1094 dbarlow 1.1
1095 heller 1.36 (defslimefun sldb-disassemble (frame-number)
1096     "Return a string with the disassembly of frames code."
1097     ;; this could need some refactoring.
1098     (let* ((frame (nth-frame frame-number))
1099     (real-frame (di::frame-real-frame frame))
1100     (frame-pointer (di::frame-pointer real-frame))
1101     (debug-fun (di:frame-debug-function real-frame)))
1102     (with-output-to-string (*standard-output*)
1103 heller 1.37 (format t "Frame: ~S~%~:[Real Frame: ~S~%~;~]Frame Pointer: ~S~%"
1104 heller 1.36 frame (eq frame real-frame) real-frame frame-pointer)
1105     (etypecase debug-fun
1106     (di::compiled-debug-function
1107     (let* ((code-loc (di:frame-code-location frame))
1108     (component (di::compiled-debug-function-component debug-fun))
1109     (pc (di::compiled-code-location-pc code-loc))
1110     (ip (sys:sap-int
1111     (sys:sap+ (kernel:code-instructions component) pc)))
1112     (kind (if (di:code-location-unknown-p code-loc)
1113     :unkown
1114     (di:code-location-kind code-loc)))
1115     (fun (di:debug-function-function debug-fun)))
1116 heller 1.37 (format t "Instruction pointer: #x~X [pc: ~S kind: ~S]~%~%~%"
1117 heller 1.36 ip pc kind)
1118     (if fun
1119 heller 1.37 (disassemble fun)
1120     (disassem:disassemble-code-component component))))
1121 heller 1.36 (di::bogus-debug-function
1122     (format t "~%[Disassembling bogus frames not implemented]"))))))
1123 dbarlow 1.1
1124 lgorrie 1.25 ;;;; Inspecting
1125 dbarlow 1.1
1126     (defvar *inspectee*)
1127     (defvar *inspectee-parts*)
1128     (defvar *inspector-stack* '())
1129     (defvar *inspector-history* (make-array 10 :adjustable t :fill-pointer 0))
1130     (defvar *inspect-length* 30)
1131    
1132     (defun reset-inspector ()
1133     (setq *inspectee* nil)
1134     (setq *inspectee-parts* nil)
1135     (setq *inspector-stack* nil)
1136     (setf (fill-pointer *inspector-history*) 0))
1137    
1138     (defslimefun init-inspector (string)
1139     (reset-inspector)
1140     (inspect-object (eval (from-string string))))
1141    
1142     (defun print-part-to-string (value)
1143     (let ((*print-pretty* nil))
1144     (let ((string (to-string value))
1145     (pos (position value *inspector-history*)))
1146     (if pos
1147     (format nil "#~D=~A" pos string)
1148     string))))
1149    
1150     (defun inspect-object (object)
1151     (push (setq *inspectee* object) *inspector-stack*)
1152     (unless (find object *inspector-history*)
1153     (vector-push-extend object *inspector-history*))
1154     (multiple-value-bind (text parts) (inspected-parts object)
1155     (setq *inspectee-parts* parts)
1156     (list :text text
1157     :type (to-string (type-of object))
1158     :primitive-type (describe-primitive-type object)
1159     :parts (loop for (label . value) in parts
1160     collect (cons label
1161     (print-part-to-string value))))))
1162     (defconstant +lowtag-symbols+
1163     '(vm:even-fixnum-type
1164     vm:function-pointer-type
1165     vm:other-immediate-0-type
1166     vm:list-pointer-type
1167     vm:odd-fixnum-type
1168     vm:instance-pointer-type
1169     vm:other-immediate-1-type
1170     vm:other-pointer-type))
1171    
1172     (defconstant +header-type-symbols+
1173     ;; Is there a convinient place for all those constants?
1174     (flet ((tail-comp (string tail)
1175     (and (>= (length string) (length tail))
1176     (string= string tail :start1 (- (length string)
1177     (length tail))))))
1178     (remove-if-not
1179     (lambda (x) (and (tail-comp (symbol-name x) "-TYPE")
1180     (not (member x +lowtag-symbols+))
1181     (boundp x)
1182     (typep (symbol-value x) 'fixnum)))
1183     (append (apropos-list "-TYPE" "VM" t)
1184     (apropos-list "-TYPE" "BIGNUM" t)))))
1185    
1186     (defun describe-primitive-type (object)
1187     (with-output-to-string (*standard-output*)
1188     (let* ((lowtag (kernel:get-lowtag object))
1189     (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1190     (format t "[lowtag: ~A" lowtag-symbol)
1191     (cond ((member lowtag (list vm:other-pointer-type
1192     vm:function-pointer-type
1193     vm:other-immediate-0-type
1194     vm:other-immediate-1-type
1195     ))
1196     (let* ((type (kernel:get-type object))
1197     (type-symbol (find type +header-type-symbols+
1198     :key #'symbol-value)))
1199     (format t ", type: ~A]" type-symbol)))
1200     (t (format t "]"))))))
1201    
1202     (defun nth-part (index)
1203     (cdr (nth index *inspectee-parts*)))
1204    
1205     (defslimefun inspect-nth-part (index)
1206     (inspect-object (nth-part index)))
1207    
1208     (defslimefun inspector-pop ()
1209     "Drop the inspector stack and inspect the second element. Return
1210     nil if there's no second element."
1211     (cond ((cdr *inspector-stack*)
1212     (pop *inspector-stack*)
1213     (inspect-object (pop *inspector-stack*)))
1214     (t nil)))
1215    
1216     (defslimefun inspector-next ()
1217     "Inspect the next element in the *inspector-history*."
1218     (let ((position (position *inspectee* *inspector-history*)))
1219     (cond ((= (1+ position) (length *inspector-history*))
1220     nil)
1221     (t (inspect-object (aref *inspector-history* (1+ position)))))))
1222    
1223     (defslimefun quit-inspector ()
1224     (reset-inspector)
1225     nil)
1226    
1227     (defslimefun describe-inspectee ()
1228     "Describe the currently inspected object."
1229 heller 1.4 (print-description-to-string *inspectee*))
1230 dbarlow 1.1
1231     (defgeneric inspected-parts (object)
1232     (:documentation
1233     "Return a short description and a list of (label . value) pairs."))
1234    
1235     (defmethod inspected-parts (o)
1236     (cond ((di::indirect-value-cell-p o)
1237     (inspected-parts-of-value-cell o))
1238     (t
1239     (destructuring-bind (text labeledp . parts)
1240     (inspect::describe-parts o)
1241     (let ((parts (if labeledp
1242     (loop for (label . value) in parts
1243     collect (cons (string label) value))
1244     (loop for value in parts
1245     for i from 0
1246     collect (cons (format nil "~D" i) value)))))
1247     (values text parts))))))
1248    
1249     (defun inspected-parts-of-value-cell (o)
1250     (values (format nil "~A~% is a value cell." o)
1251     (list (cons "Value" (c:value-cell-ref o)))))
1252    
1253     ;; borrowed from sbcl
1254     (defmethod inspected-parts ((object cons))
1255     (if (consp (cdr object))
1256     (inspected-parts-of-nontrivial-list object)
1257     (inspected-parts-of-simple-cons object)))
1258    
1259     (defun inspected-parts-of-simple-cons (object)
1260     (values "The object is a CONS."
1261     (list (cons (string 'car) (car object))
1262     (cons (string 'cdr) (cdr object)))))
1263    
1264     (defun inspected-parts-of-nontrivial-list (object)
1265     (let ((length 0)
1266     (in-list object)
1267     (reversed-elements nil))
1268     (flet ((done (description-format)
1269     (return-from inspected-parts-of-nontrivial-list
1270     (values (format nil description-format length)
1271     (nreverse reversed-elements)))))
1272     (loop
1273     (cond ((null in-list)
1274     (done "The object is a proper list of length ~S.~%"))
1275     ((>= length *inspect-length*)
1276     (push (cons (string 'rest) in-list) reversed-elements)
1277     (done "The object is a long list (more than ~S elements).~%"))
1278     ((consp in-list)
1279     (push (cons (format nil "~D" length) (pop in-list))
1280     reversed-elements)
1281     (incf length))
1282     (t
1283     (push (cons (string 'rest) in-list) reversed-elements)
1284     (done "The object is an improper list of length ~S.~%")))))))
1285    
1286     (defmethod inspected-parts ((o function))
1287     (let ((header (kernel:get-type o)))
1288     (cond ((= header vm:function-header-type)
1289     (values
1290     (format nil "~A~% is a function." o)
1291     (list (cons "Self" (kernel:%function-self o))
1292     (cons "Next" (kernel:%function-next o))
1293     (cons "Name" (kernel:%function-name o))
1294     (cons "Arglist" (kernel:%function-arglist o))
1295     (cons "Type" (kernel:%function-type o))
1296     (cons "Code Object" (kernel:function-code-header o)))))
1297     ((= header vm:closure-header-type)
1298     (values (format nil "~A~% is a closure." o)
1299     (list*
1300     (cons "Function" (kernel:%closure-function o))
1301     (loop for i from 0 below (- (kernel:get-closure-length o)
1302     (1- vm:closure-info-offset))
1303     collect (cons (format nil "~D" i)
1304     (kernel:%closure-index-ref o i))))))
1305     (t (call-next-method o)))))
1306    
1307     (defmethod inspected-parts ((o kernel:code-component))
1308     (values (format nil "~A~% is a code data-block." o)
1309     `(("First entry point" . ,(kernel:%code-entry-points o))
1310     ,@(loop for i from vm:code-constants-offset
1311     below (kernel:get-header-data o)
1312     collect (cons (format nil "Constant#~D" i)
1313     (kernel:code-header-ref o i)))
1314     ("Debug info" . ,(kernel:%code-debug-info o))
1315     ("Instructions" . ,(kernel:code-instructions o)))))
1316    
1317     (defmethod inspected-parts ((o kernel:fdefn))
1318     (values (format nil "~A~% is a fdefn object." o)
1319     `(("Name" . ,(kernel:fdefn-name o))
1320     ("Function" . ,(kernel:fdefn-function o)))))
1321    
1322 lgorrie 1.42
1323     ;;;; Multiprocessing
1324    
1325     #+MP
1326     (progn
1327     (defvar *I/O-lock* (mp:make-lock "SWANK I/O lock"))
1328     (defvar *conversation-lock* (mp:make-lock "SWANK conversation lock"))
1329    
1330     (defvar *known-processes* '() ; FIXME: leakage. -luke
1331     "List of processes that have been assigned IDs.
1332     The ID is the position in the list.")
1333    
1334     (defmethod startup-multiprocessing ()
1335     (mp::startup-idle-and-top-level-loops))
1336    
1337     (defmethod thread-id ()
1338     (mp:without-scheduling
1339     (or (find-thread-id)
1340     (prog1 (length *known-processes*)
1341     (setq *known-processes*
1342     (append *known-processes* (list (mp:current-process))))))))
1343    
1344     (defun find-thread-id (&optional (process (mp:current-process)))
1345     (position process *known-processes*))
1346    
1347     (defun lookup-thread (thread-id)
1348     (or (nth thread-id *known-processes*)
1349     (error "Unknown Thread-ID: ~S" thread-id)))
1350    
1351     (defmethod thread-name (thread-id)
1352     (mp:process-name (lookup-thread thread-id)))
1353    
1354     (defmethod call-with-I/O-lock (function)
1355     (mp:with-lock-held (*I/O-lock*)
1356     (funcall function)))
1357    
1358     (defmethod call-with-conversation-lock (function)
1359     (mp:with-lock-held (*conversation-lock*)
1360     (funcall function)))
1361    
1362     (defmethod wait-goahead ()
1363     (mp:disable-process (mp:current-process))
1364     (mp:process-yield))
1365    
1366     (defmethod give-goahead (thread-id)
1367     (mp:enable-process (lookup-thread thread-id))))
1368    
1369    
1370     ;;;; Epilogue
1371 dbarlow 1.1 ;;; Local Variables:
1372     ;;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)" (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
1373     ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5