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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5