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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.92 - (hide annotations)
Tue Mar 30 23:03:11 2004 UTC (10 years ago) by heller
Branch: MAIN
Changes since 1.91: +97 -24 lines
(method-dspec): Include the specializers.

(class-definitions): Renamed from struct-definitions.  Try to locate
condition-classes and PCL classes (in the future).

(debug-function-arglist): Insert &optional, &key, &rest in the right
places.

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

  ViewVC Help
Powered by ViewVC 1.1.5