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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5