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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.102 - (show annotations)
Sat May 8 19:00:38 2004 UTC (9 years, 11 months ago) by heller
Branch: MAIN
Changes since 1.101: +48 -94 lines
*** empty log message ***
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2
3 (in-package :swank-backend)
4
5 (in-package :lisp)
6
7 ;; Fix for read-sequence in 18e
8 #+cmu18e
9 (progn
10 (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
11 (when s
12 (setf (symbol-value s) nil)))
13
14 (defun read-into-simple-string (s stream start end)
15 (declare (type simple-string s))
16 (declare (type stream stream))
17 (declare (type index start end))
18 (unless (subtypep (stream-element-type stream) 'character)
19 (error 'type-error
20 :datum (read-char stream nil #\Null)
21 :expected-type (stream-element-type stream)
22 :format-control "Trying to read characters from a binary stream."))
23 ;; Let's go as low level as it seems reasonable.
24 (let* ((numbytes (- end start))
25 (total-bytes 0))
26 ;; read-n-bytes may return fewer bytes than requested, so we need
27 ;; to keep trying.
28 (loop while (plusp numbytes) do
29 (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
30 (when (zerop bytes-read)
31 (return-from read-into-simple-string total-bytes))
32 (incf total-bytes bytes-read)
33 (incf start bytes-read)
34 (decf numbytes bytes-read)))
35 total-bytes))
36
37 (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
38 (when s
39 (setf (symbol-value s) t)))
40
41 )
42
43 (in-package :swank-backend)
44
45
46 ;;;; TCP server.
47
48 (defimplementation preferred-communication-style ()
49 :sigio)
50
51 (defimplementation create-socket (host port)
52 (ext:create-inet-listener port :stream
53 :reuse-address t
54 :host (resolve-hostname host)))
55
56 (defimplementation local-port (socket)
57 (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
58
59 (defimplementation close-socket (socket)
60 (ext:close-socket (socket-fd socket)))
61
62 (defimplementation accept-connection (socket)
63 #+mp (mp:process-wait-until-fd-usable socket :input)
64 (make-socket-io-stream (ext:accept-tcp-connection socket)))
65
66 (defvar *sigio-handlers* '()
67 "List of (key . (fn . args)) pairs to be called on SIGIO.")
68
69 (defun sigio-handler (signal code scp)
70 (declare (ignore signal code scp))
71 (mapc (lambda (handler) (funcall (cdr handler))) *sigio-handlers*))
72
73 (defun set-sigio-handler ()
74 (sys:enable-interrupt :sigio (lambda (signal code scp)
75 (sigio-handler signal code scp))))
76
77 (defun fcntl (fd command arg)
78 (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
79 (cond (ok)
80 (t (error "fcntl: ~A" (unix:get-unix-error-msg error))))))
81
82 (defimplementation add-sigio-handler (socket fn)
83 (set-sigio-handler)
84 (let ((fd (socket-fd socket)))
85 (format *debug-io* "; Adding input handler: ~S ~%" fd)
86 (fcntl fd unix:f-setown (unix:unix-getpid))
87 (fcntl fd unix:f-setfl unix:fasync)
88 (push (cons fd fn) *sigio-handlers*)))
89
90 (defimplementation remove-sigio-handlers (socket)
91 (let ((fd (socket-fd socket)))
92 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
93 (sys:invalidate-descriptor fd))
94 (close socket))
95
96 (defimplementation add-fd-handler (socket fn)
97 (let ((fd (socket-fd socket)))
98 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
99 (sys:add-fd-handler fd :input (lambda (_)
100 _
101 (funcall fn)))))
102
103 (defimplementation remove-fd-handlers (socket)
104 (sys:invalidate-descriptor (socket-fd socket)))
105
106 (defimplementation make-fn-streams (input-fn output-fn)
107 (let* ((output (make-slime-output-stream output-fn))
108 (input (make-slime-input-stream input-fn output)))
109 (values input output)))
110
111 ;;;;; Socket helpers.
112
113 (defun socket-fd (socket)
114 "Return the filedescriptor for the socket represented by SOCKET."
115 (etypecase socket
116 (fixnum socket)
117 (sys:fd-stream (sys:fd-stream-fd socket))))
118
119 (defun resolve-hostname (hostname)
120 "Return the IP address of HOSTNAME as an integer."
121 (let* ((hostent (ext:lookup-host-entry hostname))
122 (address (car (ext:host-entry-addr-list hostent))))
123 (ext:htonl address)))
124
125 (defun make-socket-io-stream (fd)
126 "Create a new input/output fd-stream for FD."
127 (sys:make-fd-stream fd :input t :output t :element-type 'base-char))
128
129 (defun set-fd-non-blocking (fd)
130 (flet ((fcntl (fd cmd arg)
131 (multiple-value-bind (flags errno) (unix:unix-fcntl fd cmd arg)
132 (or flags
133 (error "fcntl: ~A" (unix:get-unix-error-msg errno))))))
134 (let ((flags (fcntl fd unix:f-getfl 0)))
135 (fcntl fd unix:f-setfl (logior flags unix:o_nonblock)))))
136
137
138 ;;;; unix signals
139
140 (defmethod call-without-interrupts (fn)
141 (sys:without-interrupts (funcall fn)))
142
143 (defimplementation getpid ()
144 (unix:unix-getpid))
145
146 (defimplementation lisp-implementation-type-name ()
147 "cmucl")
148
149 (defimplementation quit-lisp ()
150 (ext::quit))
151
152
153 ;;;; Stream handling
154
155 (defstruct (slime-output-stream
156 (:include lisp::lisp-stream
157 (lisp::misc #'sos/misc)
158 (lisp::out #'sos/out)
159 (lisp::sout #'sos/sout))
160 (:conc-name sos.)
161 (:print-function %print-slime-output-stream)
162 (:constructor make-slime-output-stream (output-fn)))
163 (output-fn nil :type function)
164 (buffer (make-string 512) :type string)
165 (index 0 :type kernel:index)
166 (column 0 :type kernel:index))
167
168 (defun %print-slime-output-stream (s stream d)
169 (declare (ignore d))
170 (print-unreadable-object (s stream :type t :identity t)))
171
172 (defun sos/out (stream char)
173 (let ((buffer (sos.buffer stream))
174 (index (sos.index stream)))
175 (setf (schar buffer index) char)
176 (setf (sos.index stream) (1+ index))
177 (incf (sos.column stream))
178 (when (char= #\newline char)
179 (setf (sos.column stream) 0))
180 (when (= index (1- (length buffer)))
181 (force-output stream)))
182 char)
183
184 (defun sos/sout (stream string start end)
185 (loop for i from start below end
186 do (sos/out stream (aref string i))))
187
188 (defun sos/misc (stream operation &optional arg1 arg2)
189 (declare (ignore arg1 arg2))
190 (case operation
191 ((:force-output :finish-output)
192 (let ((end (sos.index stream)))
193 (unless (zerop end)
194 (funcall (sos.output-fn stream) (subseq (sos.buffer stream) 0 end))
195 (setf (sos.index stream) 0))))
196 (:charpos (sos.column stream))
197 (:line-length 75)
198 (:file-position nil)
199 (:element-type 'base-char)
200 (:get-command nil)
201 (:close nil)
202 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
203
204 (defstruct (slime-input-stream
205 (:include string-stream
206 (lisp::in #'sis/in)
207 (lisp::misc #'sis/misc))
208 (:conc-name sis.)
209 (:print-function %print-slime-output-stream)
210 (:constructor make-slime-input-stream (input-fn sos)))
211 (input-fn nil :type function)
212 ;; We know our sibling output stream, so that we can force it before
213 ;; requesting input.
214 (sos nil :type slime-output-stream)
215 (buffer "" :type string)
216 (index 0 :type kernel:index))
217
218 (defun sis/in (stream eof-errorp eof-value)
219 (declare (ignore eof-errorp eof-value))
220 (let ((index (sis.index stream))
221 (buffer (sis.buffer stream)))
222 (when (= index (length buffer))
223 (force-output (sis.sos stream))
224 (setf buffer (funcall (sis.input-fn stream)))
225 (setf (sis.buffer stream) buffer)
226 (setf index 0))
227 (prog1 (aref buffer index)
228 (setf (sis.index stream) (1+ index)))))
229
230 (defun sis/misc (stream operation &optional arg1 arg2)
231 (declare (ignore arg2))
232 (ecase operation
233 (:file-position nil)
234 (:file-length nil)
235 (:unread (setf (aref (sis.buffer stream)
236 (decf (sis.index stream)))
237 arg1))
238 (:clear-input
239 (setf (sis.index stream) 0
240 (sis.buffer stream) ""))
241 (:listen (< (sis.index stream) (length (sis.buffer stream))))
242 (:charpos nil)
243 (:line-length nil)
244 (:get-command nil)
245 (:element-type 'base-char)
246 (:close nil)))
247
248
249 ;;;; Compilation Commands
250
251 (defvar *previous-compiler-condition* nil
252 "Used to detect duplicates.")
253
254 (defvar *previous-context* nil
255 "Previous compiler error context.")
256
257 (defvar *buffer-name* nil)
258 (defvar *buffer-start-position* nil)
259 (defvar *buffer-substring* nil)
260
261
262 ;;;;; Trapping notes
263
264 (defun handle-notification-condition (condition)
265 "Handle a condition caused by a compiler warning.
266 This traps all compiler conditions at a lower-level than using
267 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
268 craft our own error messages, which can omit a lot of redundant
269 information."
270 (unless (eq condition *previous-compiler-condition*)
271 (let ((context (c::find-error-context nil)))
272 (setq *previous-compiler-condition* condition)
273 (setq *previous-context* context)
274 (signal-compiler-condition condition context))))
275
276 (defun signal-compiler-condition (condition context)
277 (signal (make-condition
278 'compiler-condition
279 :original-condition condition
280 :severity (severity-for-emacs condition)
281 :short-message (brief-compiler-message-for-emacs condition)
282 :message (long-compiler-message-for-emacs condition context)
283 :location (compiler-note-location context))))
284
285 (defun severity-for-emacs (condition)
286 "Return the severity of CONDITION."
287 (etypecase condition
288 (c::compiler-error :error)
289 (c::style-warning :note)
290 (c::warning :warning)))
291
292 (defun brief-compiler-message-for-emacs (condition)
293 "Briefly describe a compiler error for Emacs.
294 When Emacs presents the message it already has the source popped up
295 and the source form highlighted. This makes much of the information in
296 the error-context redundant."
297 (princ-to-string condition))
298
299 (defun long-compiler-message-for-emacs (condition error-context)
300 "Describe a compiler error for Emacs including context information."
301 (declare (type (or c::compiler-error-context null) error-context))
302 (multiple-value-bind (enclosing source)
303 (if error-context
304 (values (c::compiler-error-context-enclosing-source error-context)
305 (c::compiler-error-context-source error-context)))
306 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
307 enclosing source condition)))
308
309 (defun compiler-note-location (context)
310 (cond (context
311 (resolve-note-location
312 *buffer-name*
313 (c::compiler-error-context-file-name context)
314 (c::compiler-error-context-file-position context)
315 (reverse (c::compiler-error-context-original-source-path context))
316 (c::compiler-error-context-original-source context)))
317 (t
318 (resolve-note-location *buffer-name* nil nil nil nil))))
319
320 (defgeneric resolve-note-location (buffer file-name file-position
321 source-path source))
322
323 (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
324 (make-location
325 `(:file ,(unix-truename f))
326 `(:position ,(1+ (source-path-file-position path f)))))
327
328 (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
329 (make-location
330 `(:buffer ,b)
331 `(:position ,(+ *buffer-start-position*
332 (source-path-string-position path *buffer-substring*)))))
333
334 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
335 (make-location
336 `(:source-form ,source)
337 `(:position 1)))
338
339 (defmethod resolve-note-location (buffer
340 (file (eql nil))
341 (pos (eql nil))
342 (path (eql nil))
343 (source (eql nil)))
344 (list :error "No error location available"))
345
346 (defimplementation call-with-compilation-hooks (function)
347 (let ((*previous-compiler-condition* nil)
348 (*previous-context* nil)
349 (*print-readably* nil))
350 (handler-bind ((c::compiler-error #'handle-notification-condition)
351 (c::style-warning #'handle-notification-condition)
352 (c::warning #'handle-notification-condition))
353 (funcall function))))
354
355 (defimplementation swank-compile-file (filename load-p)
356 (clear-xref-info filename)
357 (with-compilation-hooks ()
358 (let ((*buffer-name* nil))
359 (compile-file filename :load load-p))))
360
361 (defimplementation swank-compile-string (string &key buffer position)
362 (with-compilation-hooks ()
363 (let ((*buffer-name* buffer)
364 (*buffer-start-position* position)
365 (*buffer-substring* string))
366 (with-input-from-string (stream string)
367 (ext:compile-from-stream
368 stream
369 :source-info `(:emacs-buffer ,buffer
370 :emacs-buffer-offset ,position
371 :emacs-buffer-string ,string))))))
372
373
374 ;;;; XREF
375
376 (defmacro defxref (name function)
377 `(defimplementation ,name (name)
378 (xref-results (,function name))))
379
380 (defxref who-calls xref:who-calls)
381 (defxref who-references xref:who-references)
382 (defxref who-binds xref:who-binds)
383 (defxref who-sets xref:who-sets)
384
385 #+cmu19
386 (progn
387 (defxref who-macroexpands xref:who-macroexpands)
388 ;; XXX
389 (defimplementation who-specializes (symbol)
390 (let* ((methods (xref::who-specializes (find-class symbol)))
391 (locations (mapcar #'method-location methods)))
392 (mapcar #'list methods locations))))
393
394 (defun xref-results (contexts)
395 (mapcar (lambda (xref)
396 (list (xref:xref-context-name xref)
397 (resolve-xref-location xref)))
398 contexts))
399
400 (defun resolve-xref-location (xref)
401 (let ((name (xref:xref-context-name xref))
402 (file (xref:xref-context-file xref))
403 (source-path (xref:xref-context-source-path xref)))
404 (cond ((and file source-path)
405 (let ((position (source-path-file-position source-path file)))
406 (make-location (list :file (unix-truename file))
407 (list :position (1+ position)))))
408 (file
409 (make-location (list :file (unix-truename file))
410 (list :function-name (string name))))
411 (t
412 `(:error ,(format nil "Unknown source location: ~S ~S ~S "
413 name file source-path))))))
414
415 (defun clear-xref-info (namestring)
416 "Clear XREF notes pertaining to NAMESTRING.
417 This is a workaround for a CMUCL bug: XREF records are cumulative."
418 (when c:*record-xref-info*
419 (let ((filename (truename namestring)))
420 (dolist (db (list xref::*who-calls*
421 #+cmu19 xref::*who-is-called*
422 #+cmu19 xref::*who-macroexpands*
423 xref::*who-references*
424 xref::*who-binds*
425 xref::*who-sets*))
426 (maphash (lambda (target contexts)
427 ;; XXX update during traversal?
428 (setf (gethash target db)
429 (delete filename contexts
430 :key #'xref:xref-context-file
431 :test #'equalp)))
432 db)))))
433
434 (defun unix-truename (pathname)
435 (ext:unix-namestring (truename pathname)))
436
437
438 ;;;; Find callers and callees
439
440 ;;; Find callers and callees by looking at the constant pool of
441 ;;; compiled code objects. We assume every fdefn object in the
442 ;;; constant pool corresponds to a call to that function. A better
443 ;;; strategy would be to use the disassembler to find actual
444 ;;; call-sites.
445
446 (declaim (inline map-code-constants))
447 (defun map-code-constants (code fn)
448 "Call FN for each constant in CODE's constant pool."
449 (check-type code kernel:code-component)
450 (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
451 do (funcall fn (kernel:code-header-ref code i))))
452
453 (defun function-callees (function)
454 "Return FUNCTION's callees as a list of functions."
455 (let ((callees '()))
456 (map-code-constants
457 (vm::find-code-object function)
458 (lambda (obj)
459 (when (kernel:fdefn-p obj)
460 (push (kernel:fdefn-function obj) callees))))
461 callees))
462
463 (declaim (ext:maybe-inline map-allocated-code-components))
464 (defun map-allocated-code-components (spaces fn)
465 "Call FN for each allocated code component in one of SPACES. FN
466 receives the object as argument. SPACES should be a list of the
467 symbols :dynamic, :static, or :read-only."
468 (dolist (space spaces)
469 (declare (inline vm::map-allocated-objects))
470 (vm::map-allocated-objects
471 (lambda (obj header size)
472 (declare (type fixnum size) (ignore size))
473 (when (= vm:code-header-type header)
474 (funcall fn obj)))
475 space)))
476
477 (declaim (ext:maybe-inline map-caller-code-components))
478 (defun map-caller-code-components (function spaces fn)
479 "Call FN for each code component with a fdefn for FUNCTION in its
480 constant pool."
481 (let ((function (coerce function 'function)))
482 (declare (inline map-allocated-code-components))
483 (map-allocated-code-components
484 spaces
485 (lambda (obj)
486 (map-code-constants
487 obj
488 (lambda (constant)
489 (when (and (kernel:fdefn-p constant)
490 (eq (kernel:fdefn-function constant)
491 function))
492 (funcall fn obj))))))))
493
494 (defun function-callers (function &optional (spaces '(:read-only :static
495 :dynamic)))
496 "Return FUNCTION's callers. The result is a list of code-objects."
497 (let ((referrers '()))
498 (declare (inline map-caller-code-components))
499 (ext:gc :full t)
500 (map-caller-code-components function spaces
501 (lambda (code) (push code referrers)))
502 referrers))
503
504 (defun debug-info-definitions (debug-info)
505 "Return the defintions for a debug-info. This should only be used
506 for code-object without entry points, i.e., byte compiled
507 code (are theree others?)"
508 ;; This mess has only been tested with #'ext::skip-whitespace, a
509 ;; byte-compiled caller of #'read-char .
510 (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
511 (let ((name (c::debug-info-name debug-info))
512 (source (c::debug-info-source debug-info)))
513 (destructuring-bind (first) source
514 (ecase (c::debug-source-from first)
515 (:file
516 (list (list name
517 (make-location
518 (list :file (unix-truename (c::debug-source-name first)))
519 (list :function-name name)))))))))
520
521 (defun code-component-entry-points (code)
522 "Return a list ((NAME LOCATION) ...) of function definitons for
523 the code omponent CODE."
524 (delete-duplicates
525 (loop for e = (kernel:%code-entry-points code)
526 then (kernel::%function-next e)
527 while e
528 collect (list (kernel:%function-name e)
529 (function-location e)))
530 :test #'equal))
531
532 (defimplementation list-callers (symbol)
533 "Return a list ((NAME LOCATION) ...) of callers."
534 (let ((components (function-callers symbol))
535 (xrefs '()))
536 (dolist (code components)
537 (let* ((entry (kernel:%code-entry-points code))
538 (defs (if entry
539 (code-component-entry-points code)
540 ;; byte compiled stuff
541 (debug-info-definitions
542 (kernel:%code-debug-info code)))))
543 (setq xrefs (nconc defs xrefs))))
544 xrefs))
545
546 (defimplementation list-callees (symbol)
547 (let ((fns (function-callees symbol)))
548 (mapcar (lambda (fn)
549 (list (kernel:%function-name fn)
550 (function-location fn)))
551 fns)))
552
553
554 ;;;; Definitions
555
556 (defvar *debug-definition-finding* nil
557 "When true don't handle errors while looking for definitions.
558 This is useful when debugging the definition-finding code.")
559
560 (defvar *source-snippet-size* 256
561 "Maximum number of characters in a snippet of source code.
562 Snippets at the beginning of definitions are used to tell Emacs what
563 the definitions looks like, so that it can accurately find them by
564 text search.")
565
566 (defvar *cache-sourcecode* t
567 "When true complete source files are cached.
568 The cache is used to keep known good copies of the source text which
569 correspond to the loaded code. Finding definitions is much more
570 reliable when the exact source is available, so we cache it incase it
571 gets edited on disk later.")
572
573 (defvar *source-file-cache* (make-hash-table :test 'equal)
574 "Cache of source file contents.
575 Maps from truename to source-cache-entry structure.")
576
577 (defstruct (source-cache-entry
578 (:conc-name source-cache-entry.)
579 (:constructor make-source-cache-entry (text date)))
580 text date)
581
582 (defun source-cache-get (filename date)
583 "Return the source code for FILENAME written on DATE as a string.
584 Return NIL if the right version cannot be found."
585 (let ((entry (gethash filename *source-file-cache*)))
586 (cond ((and entry (equal date (source-cache-entry.date entry)))
587 ;; Cache hit.
588 (source-cache-entry.text entry))
589 ((or (null entry)
590 (not (equal date (source-cache-entry.date entry))))
591 ;; Cache miss.
592 (if (equal (file-write-date filename) date)
593 ;; File on disk has the correct version.
594 (let ((source (read-file filename)))
595 (setf (gethash filename *source-file-cache*)
596 (make-source-cache-entry source date))
597 source)
598 nil)))))
599
600 (defun read-file (filename)
601 "Return the entire contents of FILENAME as a string."
602 (with-open-file (s filename :direction :input)
603 (let ((string (make-string (file-length s))))
604 (read-sequence string s)
605 string)))
606
607 (defmacro safe-definition-finding (&body body)
608 "Execute BODY ignoring errors. Return the source location returned
609 by BODY or if an error occurs a description of the error. The second
610 return value is the condition or nil."
611 `(flet ((body () ,@body))
612 (if *debug-definition-finding*
613 (body)
614 (handler-case (values (progn ,@body) nil)
615 (error (c) (values (list :error (princ-to-string c)) c))))))
616
617 (defun function-first-code-location (function)
618 (and (function-has-debug-function-p function)
619 (di:debug-function-start-location
620 (di:function-debug-function function))))
621
622 (defun function-has-debug-function-p (function)
623 (di:function-debug-function function))
624
625 (defun function-code-object= (closure function)
626 (and (eq (vm::find-code-object closure)
627 (vm::find-code-object function))
628 (not (eq closure function))))
629
630 (defun genericp (fn)
631 (typep fn 'generic-function))
632
633 (defun struct-closure-p (function)
634 (or (function-code-object= function #'kernel::structure-slot-accessor)
635 (function-code-object= function #'kernel::structure-slot-setter)
636 (function-code-object= function #'kernel::%defstruct)))
637
638 (defun struct-closure-dd (function)
639 (assert (= (kernel:get-type function) vm:closure-header-type))
640 (flet ((find-layout (function)
641 (sys:find-if-in-closure
642 (lambda (x)
643 (let ((value (if (di::indirect-value-cell-p x)
644 (c:value-cell-ref x)
645 x)))
646 (when (kernel::layout-p value)
647 (return-from find-layout value))))
648 function)))
649 (kernel:layout-info (find-layout function))))
650
651 (defun dd-location (dd)
652 (let ((constructor (or (kernel:dd-default-constructor dd)
653 (car (kernel::dd-constructors dd)))))
654 (when (or (not constructor) (and (consp constructor)
655 (not (car constructor))))
656 (error "Cannot locate struct without constructor: ~S"
657 (kernel::dd-name dd)))
658 (function-location
659 (coerce (if (consp constructor) (car constructor) constructor)
660 'function))))
661
662 (defun debug-info-function-name-location (debug-info)
663 "Return a function-name source-location for DEBUG-INFO."
664 (with-struct (c::debug-info- (fname name) source) debug-info
665 (with-struct (c::debug-source- info from name) (car source)
666 (ecase from
667 (:file
668 (make-location (list :file (namestring (truename name)))
669 (list :function-name fname)))
670 (:stream
671 (assert (debug-source-info-from-emacs-buffer-p (car source)))
672 (make-location (list :buffer (getf info :emacs-buffer))
673 (list :function-name fname)))
674 (:lisp
675 (make-location (list :source-form (princ-to-string (aref name 0)))
676 (list :position 1)))))))
677
678 (defun byte-function-location (fn)
679 (etypecase fn
680 ((or c::hairy-byte-function c::simple-byte-function)
681 (let* ((component (c::byte-function-component fn))
682 (debug-info (kernel:%code-debug-info component)))
683 (debug-info-function-name-location debug-info)))
684 (c::byte-closure
685 (byte-function-location (c::byte-closure-function fn)))))
686
687 (defun function-location (function)
688 "Return the source location for FUNCTION."
689 ;; First test if FUNCTION is a closure created by defstruct; if so
690 ;; extract the defstruct-description (dd) from the closure and find
691 ;; the constructor for the struct. Defstruct creates a defun for
692 ;; the default constructor and we use that as an approximation to
693 ;; the source location of the defstruct.
694 ;;
695 ;; For an ordinary function we return the source location of the
696 ;; first code-location we find.
697 (cond ((struct-closure-p function)
698 (safe-definition-finding
699 (dd-location (struct-closure-dd function))))
700 ((genericp function)
701 (gf-location function))
702 ((c::byte-function-or-closure-p function)
703 (byte-function-location function))
704 (t
705 (multiple-value-bind (code-location error)
706 (safe-definition-finding (function-first-code-location function))
707 (cond (error (list :error (princ-to-string error)))
708 (t (code-location-source-location code-location)))))))
709
710 ;; XXX maybe special case setters/getters
711 (defun method-location (method)
712 (function-location (or (pcl::method-fast-function method)
713 (pcl:method-function method))))
714
715 (defun method-dspec (method)
716 (let* ((gf (pcl:method-generic-function method))
717 (name (pcl:generic-function-name gf))
718 (specializers (pcl:method-specializers method))
719 (qualifiers (pcl:method-qualifiers method)))
720 `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
721
722 (defun method-definition (method)
723 (list (method-dspec method)
724 (method-location method)))
725
726 (defun gf-location (gf)
727 (definition-source-location gf (pcl::generic-function-name gf)))
728
729 (defun gf-method-definitions (gf)
730 (mapcar #'method-definition (pcl::generic-function-methods gf)))
731
732 (defun function-definitions (name)
733 "Return definitions for NAME in the \"function namespace\", i.e.,
734 regular functions, generic functions, methods and macros.
735 NAME can any valid function name (e.g, (setf car))."
736 (cond ((and (symbolp name) (macro-function name))
737 (list `((defmacro ,name)
738 ,(function-location (macro-function name)))))
739 ((and (symbolp name) (special-operator-p name))
740 (list `((:special-operator ,name)
741 (:error ,(format nil "Special operator: ~S" name)))))
742 ((and (ext:valid-function-name-p name)
743 (ext:info :function :definition name))
744 (let ((function (fdefinition name)))
745 (cond ((genericp function)
746 (cons (list `(defgeneric ,name)
747 (function-location function))
748 (gf-method-definitions function)))
749 (t (list (list `(function ,name)
750 (function-location function)))))))))
751
752 (defun maybe-make-definition (function kind name)
753 (if function
754 (list (list `(,kind ,name) (function-location function)))))
755
756 (defun type-definitions (name)
757 (maybe-make-definition (ext:info :type :expander name) 'deftype name))
758
759 (defun find-dd (name)
760 (let ((layout (ext:info :type :compiler-layout name)))
761 (if layout
762 (kernel:layout-info layout))))
763
764 (defun condition-class-location (class)
765 (let ((slots (conditions::condition-class-slots class))
766 (name (conditions::condition-class-name class)))
767 (cond ((null slots)
768 `(:error ,(format nil "No location info for condition: ~A" name)))
769 (t
770 (let* ((slot (first slots))
771 (gf (fdefinition
772 (first (conditions::condition-slot-readers slot)))))
773 (method-location
774 (first
775 (pcl:compute-applicable-methods-using-classes
776 gf (list (find-class name))))))))))
777
778 (defun class-location (class)
779 (definition-source-location class (pcl:class-name class)))
780
781 (defun make-name-in-file-location (file string)
782 (multiple-value-bind (filename c)
783 (ignore-errors
784 (unix-truename (merge-pathnames (make-pathname :type "lisp")
785 file)))
786 (cond (filename (make-location `(:file ,filename)
787 `(:function-name ,string)))
788 (t (list :error (princ-to-string c))))))
789
790 (defun source-location-form-numbers (location)
791 (c::decode-form-numbers (c::form-numbers-form-numbers location)))
792
793 (defun source-location-tlf-number (location)
794 (nth-value 0 (source-location-form-numbers location)))
795
796 (defun source-location-form-number (location)
797 (nth-value 1 (source-location-form-numbers location)))
798
799 (defun resolve-file-source-location (location)
800 (let ((filename (c::file-source-location-pathname location))
801 (tlf-number (source-location-tlf-number location))
802 (form-number (source-location-form-number location)))
803 (with-open-file (s filename)
804 (let ((pos (form-number-stream-position tlf-number form-number s)))
805 (make-location `(:file ,(unix-truename filename))
806 `(:position ,(1+ pos)))))))
807
808 (defun resolve-stream-source-location (location)
809 (let ((info (c::stream-source-location-user-info location))
810 (tlf-number (source-location-tlf-number location))
811 (form-number (source-location-form-number location)))
812 ;; XXX duplication in frame-source-location
813 (assert (info-from-emacs-buffer-p info))
814 (destructuring-bind (&key emacs-buffer emacs-buffer-string
815 emacs-buffer-offset) info
816 (with-input-from-string (s emacs-buffer-string)
817 (let ((pos (form-number-stream-position tlf-number form-number s)))
818 (make-location `(:buffer ,emacs-buffer)
819 `(:position ,(+ emacs-buffer-offset pos))))))))
820
821 ;; XXX predicates for 18e backward compatibilty. Remove them when
822 ;; we're 19a only.
823 (defun file-source-location-p (object)
824 (when (fboundp 'c::file-source-location-p)
825 (c::file-source-location-p object)))
826
827 (defun stream-source-location-p (object)
828 (when (fboundp 'c::stream-source-location-p)
829 (c::stream-source-location-p object)))
830
831 (defun source-location-p (object)
832 (or (file-source-location-p object)
833 (stream-source-location-p object)))
834
835 (defun resolve-source-location (location)
836 (etypecase location
837 ((satisfies file-source-location-p)
838 (resolve-file-source-location location))
839 ((satisfies stream-source-location-p)
840 (resolve-stream-source-location location))))
841
842 (defun definition-source-location (object name)
843 (let ((source (pcl::definition-source object)))
844 (etypecase source
845 (null
846 `(:error ,(format nil "No source info for: ~A" object)))
847 ((satisfies source-location-p)
848 (resolve-source-location source))
849 (pathname
850 (make-name-in-file-location source name))
851 (cons
852 (destructuring-bind ((dg name) pathname) source
853 (declare (ignore dg))
854 (etypecase pathname
855 (pathname (make-name-in-file-location pathname (string name)))
856 (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
857
858 (defun class-definitions (name)
859 (if (symbolp name)
860 (let ((class (kernel::find-class name nil)))
861 (etypecase class
862 (null '())
863 (kernel::structure-class
864 (list (list `(defstruct ,name) (dd-location (find-dd name)))))
865 #+(or)
866 (conditions::condition-class
867 (list (list `(define-condition ,name)
868 (condition-class-location class))))
869 (kernel::standard-class
870 (list (list `(defclass ,name)
871 (class-location (find-class name)))))
872 ((or kernel::built-in-class
873 conditions::condition-class
874 kernel:funcallable-structure-class)
875 (list (list `(kernel::define-type-class ,name)
876 `(:error
877 ,(format nil "No source info for ~A" name)))))))))
878
879 (defun setf-definitions (name)
880 (let ((function (or (ext:info :setf :inverse name)
881 (ext:info :setf :expander name))))
882 (if function
883 (list (list `(setf ,name)
884 (function-location (coerce function 'function)))))))
885
886
887 (defun variable-location (symbol)
888 (multiple-value-bind (location foundp)
889 ;; XXX for 18e compatibilty. rewrite this when we drop 18e
890 ;; support.
891 (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
892 (if (and foundp location)
893 (resolve-source-location location)
894 `(:error ,(format nil "No source info for variable ~S" symbol)))))
895
896 (defun variable-definitions (name)
897 (if (symbolp name)
898 (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
899 (if recorded-p
900 (list (list `(variable ,kind ,name)
901 (variable-location name)))))))
902
903 (defun compiler-macro-definitions (symbol)
904 (maybe-make-definition (compiler-macro-function symbol)
905 'define-compiler-macro
906 symbol))
907
908 (defun source-transform-definitions (name)
909 (maybe-make-definition (ext:info :function :source-transform name)
910 'c:def-source-transform
911 name))
912
913 (defun function-info-definitions (name)
914 (let ((info (ext:info :function :info name)))
915 (if info
916 (append (loop for transform in (c::function-info-transforms info)
917 collect (list `(c:deftransform ,name
918 ,(c::type-specifier
919 (c::transform-type transform)))
920 (function-location (c::transform-function
921 transform))))
922 (maybe-make-definition (c::function-info-derive-type info)
923 'c::derive-type name)
924 (maybe-make-definition (c::function-info-optimizer info)
925 'c::optimizer name)
926 (maybe-make-definition (c::function-info-ltn-annotate info)
927 'c::ltn-annotate name)
928 (maybe-make-definition (c::function-info-ir2-convert info)
929 'c::ir2-convert name)
930 (loop for template in (c::function-info-templates info)
931 collect (list `(c::vop ,(c::template-name template))
932 (function-location
933 (c::vop-info-generator-function
934 template))))))))
935
936 (defun ir1-translator-definitions (name)
937 (maybe-make-definition (ext:info :function :ir1-convert name)
938 'c:def-ir1-translator name))
939
940 (defimplementation find-definitions (name)
941 (append (function-definitions name)
942 (setf-definitions name)
943 (variable-definitions name)
944 (class-definitions name)
945 (type-definitions name)
946 (compiler-macro-definitions name)
947 (source-transform-definitions name)
948 (function-info-definitions name)
949 (ir1-translator-definitions name)))
950
951
952 ;;;; Documentation.
953
954 (defimplementation describe-symbol-for-emacs (symbol)
955 (let ((result '()))
956 (flet ((doc (kind)
957 (or (documentation symbol kind) :not-documented))
958 (maybe-push (property value)
959 (when value
960 (setf result (list* property value result)))))
961 (maybe-push
962 :variable (multiple-value-bind (kind recorded-p)
963 (ext:info variable kind symbol)
964 (declare (ignore kind))
965 (if (or (boundp symbol) recorded-p)
966 (doc 'variable))))
967 (maybe-push
968 :generic-function
969 (if (and (fboundp symbol)
970 (typep (fdefinition symbol) 'generic-function))
971 (doc 'function)))
972 (maybe-push
973 :function (if (and (fboundp symbol)
974 (not (typep (fdefinition symbol) 'generic-function)))
975 (doc 'function)))
976 (maybe-push
977 :setf (if (or (ext:info setf inverse symbol)
978 (ext:info setf expander symbol))
979 (doc 'setf)))
980 (maybe-push
981 :type (if (ext:info type kind symbol)
982 (doc 'type)))
983 (maybe-push
984 :class (if (find-class symbol nil)
985 (doc 'class)))
986 (maybe-push
987 :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
988 (doc 'alien-type)))
989 (maybe-push
990 :alien-struct (if (ext:info alien-type struct symbol)
991 (doc nil)))
992 (maybe-push
993 :alien-union (if (ext:info alien-type union symbol)
994 (doc nil)))
995 (maybe-push
996 :alien-enum (if (ext:info alien-type enum symbol)
997 (doc nil)))
998 result)))
999
1000 (defimplementation describe-definition (symbol namespace)
1001 (ecase namespace
1002 (:variable
1003 (describe symbol))
1004 ((:function :generic-function)
1005 (describe (symbol-function symbol)))
1006 (:setf
1007 (describe (or (ext:info setf inverse symbol))
1008 (ext:info setf expander symbol)))
1009 (:type
1010 (describe (kernel:values-specifier-type symbol)))
1011 (:class
1012 (describe (find-class symbol)))
1013 (:alien-type
1014 (ecase (ext:info :alien-type :kind symbol)
1015 (:primitive
1016 (describe (let ((alien::*values-type-okay* t))
1017 (funcall (ext:info :alien-type :translator symbol)
1018 (list symbol)))))
1019 ((:defined)
1020 (describe (ext:info :alien-type :definition symbol)))
1021 (:unknown
1022 (format nil "Unkown alien type: ~S" symbol))))
1023 (:alien-struct
1024 (describe (ext:info :alien-type :struct symbol)))
1025 (:alien-union
1026 (describe (ext:info :alien-type :union symbol)))
1027 (:alien-enum
1028 (describe (ext:info :alien-type :enum symbol)))))
1029
1030 (defun debug-variable-symbol-or-deleted (var)
1031 (etypecase var
1032 (di:debug-variable
1033 (di::debug-variable-symbol var))
1034 ((member :deleted)
1035 '#:deleted)))
1036
1037 (defun debug-function-arglist (debug-function)
1038 (let ((args (di::debug-function-lambda-list debug-function))
1039 (required '())
1040 (optional '())
1041 (rest '())
1042 (key '()))
1043 ;; collect the names of debug-vars
1044 (dolist (arg args)
1045 (etypecase arg
1046 (di::debug-variable
1047 (push (di::debug-variable-symbol arg) required))
1048 ((member :deleted)
1049 (push ':deleted required))
1050 (cons
1051 (ecase (car arg)
1052 (:keyword
1053 (push (second arg) key))
1054 (:optional
1055 (push (debug-variable-symbol-or-deleted (second arg)) optional))
1056 (:rest
1057 (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
1058 ;; intersperse lambda keywords as needed
1059 (append (nreverse required)
1060 (if optional (cons '&optional (nreverse optional)))
1061 (if rest (cons '&rest (nreverse rest)))
1062 (if key (cons '&key (nreverse key))))))
1063
1064 (defun symbol-debug-function-arglist (fname)
1065 "Return FNAME's debug-function-arglist and %function-arglist.
1066 A utility for debugging DEBUG-FUNCTION-ARGLIST."
1067 (let ((fn (fdefinition fname)))
1068 (values (debug-function-arglist (di::function-debug-function fn))
1069 (kernel:%function-arglist (kernel:%function-self fn)))))
1070
1071 (defun read-arglist (fn)
1072 "Parse the arglist-string of the function object FN."
1073 (let ((string (kernel:%function-arglist
1074 (kernel:%function-self fn)))
1075 (package (find-package
1076 (c::compiled-debug-info-package
1077 (kernel:%code-debug-info
1078 (vm::find-code-object fn))))))
1079 (with-standard-io-syntax
1080 (let ((*package* (or package *package*)))
1081 (read-from-string string)))))
1082
1083 (defun make-arg-symbol (i)
1084 (make-symbol (format nil "~A~D" (string 'arg) i)))
1085
1086 (defun hairy-byte-function-arglist (fn)
1087 (let ((counter -1))
1088 (flet ((next-arg () (make-arg-symbol (incf counter))))
1089 (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
1090 keywords-p keywords) fn
1091 (let ((arglist '())
1092 (optional (- max-args min-args)))
1093 ;; XXX isn't there a better way to write this?
1094 (dotimes (i min-args)
1095 (push (next-arg) arglist))
1096 (when (plusp optional)
1097 (push '&optional arglist)
1098 (dotimes (i optional)
1099 (push (next-arg) arglist)))
1100 (when rest-arg-p
1101 (push '&rest arglist)
1102 (push (next-arg) arglist))
1103 (when keywords-p
1104 (push '&key arglist)
1105 (loop for (key _ __) in keywords
1106 do (push key arglist))
1107 (when (eq keywords-p :allow-others)
1108 (push '&allow-other-keys arglist)))
1109 (nreverse arglist))))))
1110
1111 (defun byte-code-function-arglist (fn)
1112 ;; There doesn't seem to be much arglist information around for
1113 ;; byte-code functions. Use the arg-count and return something like
1114 ;; (arg0 arg1 ...)
1115 (etypecase fn
1116 (c::simple-byte-function
1117 (loop for i from 0 below (c::simple-byte-function-num-args fn)
1118 collect (make-arg-symbol i)))
1119 (c::hairy-byte-function
1120 (hairy-byte-function-arglist fn))
1121 (c::byte-closure
1122 (byte-code-function-arglist (c::byte-closure-function fn)))))
1123
1124 (defimplementation arglist (symbol)
1125 (let* ((fun (or (macro-function symbol)
1126 (symbol-function symbol)))
1127 (arglist
1128 (cond ((eval:interpreted-function-p fun)
1129 (eval:interpreted-function-arglist fun))
1130 ((pcl::generic-function-p fun)
1131 (pcl:generic-function-lambda-list fun))
1132 ((c::byte-function-or-closure-p fun)
1133 (byte-code-function-arglist fun))
1134 ((kernel:%function-arglist (kernel:%function-self fun))
1135 (read-arglist fun))
1136 ;; this should work both for
1137 ;; compiled-debug-function and for
1138 ;; interpreted-debug-function
1139 (t
1140 (handler-case (debug-function-arglist
1141 (di::function-debug-function fun))
1142 (di:unhandled-condition () :not-available))))))
1143 (check-type arglist (or list (member :not-available)))
1144 arglist))
1145
1146
1147 ;;;; Miscellaneous.
1148
1149 (defimplementation macroexpand-all (form)
1150 (walker:macroexpand-all form))
1151
1152 (defimplementation set-default-directory (directory)
1153 (setf (ext:default-directory) (namestring directory))
1154 ;; Setting *default-pathname-defaults* to an absolute directory
1155 ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
1156 (setf *default-pathname-defaults* (pathname (ext:default-directory)))
1157 (namestring (ext:default-directory)))
1158
1159 ;;; source-path-{stream,file,string,etc}-position moved into
1160 ;;; swank-source-path-parser
1161
1162 (defun code-location-stream-position (code-location stream)
1163 "Return the byte offset of CODE-LOCATION in STREAM. Extract the
1164 toplevel-form-number and form-number from CODE-LOCATION and use that
1165 to find the position of the corresponding form.
1166
1167 Finish with STREAM positioned at the start of the code location."
1168 (let* ((location (debug::maybe-block-start-location code-location))
1169 (tlf-offset (di:code-location-top-level-form-offset location))
1170 (form-number (di:code-location-form-number location)))
1171 (let ((pos (form-number-stream-position tlf-offset form-number stream)))
1172 (file-position stream pos)
1173 pos)))
1174
1175 (defun form-number-stream-position (tlf-number form-number stream)
1176 (let ((*read-suppress* t))
1177 (dotimes (i tlf-number) (read stream))
1178 (multiple-value-bind (tlf position-map) (read-and-record-source-map stream)
1179 (let* ((path-table (di:form-number-translations tlf 0))
1180 (source-path
1181 (if (<= (length path-table) form-number) ; source out of sync?
1182 (list 0) ; should probably signal a condition
1183 (reverse (cdr (aref path-table form-number))))))
1184 (source-path-source-position source-path tlf position-map)))))
1185
1186 (defun code-location-string-offset (code-location string)
1187 (with-input-from-string (s string)
1188 (code-location-stream-position code-location s)))
1189
1190 (defun code-location-file-position (code-location filename)
1191 (with-open-file (s filename :direction :input)
1192 (code-location-stream-position code-location s)))
1193
1194 (defun info-from-emacs-buffer-p (info)
1195 (and info
1196 (consp info)
1197 (eq :emacs-buffer (car info))))
1198
1199 (defun debug-source-info-from-emacs-buffer-p (debug-source)
1200 (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
1201
1202 (defun source-location-from-code-location (code-location)
1203 "Return the source location for CODE-LOCATION."
1204 (let ((debug-fun (di:code-location-debug-function code-location)))
1205 (when (di::bogus-debug-function-p debug-fun)
1206 (error "Bogus debug function: ~A" debug-fun)))
1207 (let* ((debug-source (di:code-location-debug-source code-location))
1208 (from (di:debug-source-from debug-source))
1209 (name (di:debug-source-name debug-source)))
1210 (ecase from
1211 (:file
1212 (let* ((code-date (di:debug-source-created debug-source))
1213 (source (source-cache-get name code-date)))
1214 (when (null source)
1215 ;; We don't have up-to-date sourcecode. Just read the
1216 ;; file that we have on disk.
1217 ;; XXX Maybe the right solution, but needs code cleanup anyway.
1218 (setf source (read-file name)))
1219 (make-location (list :file (unix-truename name)) nil)
1220 (with-input-from-string (s source)
1221 (make-location (list :file (unix-truename name))
1222 (list :position
1223 (1+ (code-location-stream-position
1224 code-location s)))
1225 `(:snippet ,(read-snippet s))))))
1226 (:stream
1227 (assert (debug-source-info-from-emacs-buffer-p debug-source))
1228 (let* ((info (c::debug-source-info debug-source))
1229 (string (getf info :emacs-buffer-string))
1230 (position (code-location-string-offset
1231 code-location
1232 string)))
1233 (make-location
1234 (list :buffer (getf info :emacs-buffer))
1235 (list :position (+ (getf info :emacs-buffer-offset) position))
1236 (list :snippet (with-input-from-string (s string)
1237 (file-position s position)
1238 (read-snippet s))))))
1239 (:lisp
1240 (make-location
1241 (list :source-form (with-output-to-string (*standard-output*)
1242 (debug::print-code-location-source-form
1243 code-location 100 t)))
1244 (list :position 1))))))
1245
1246 (defun code-location-source-location (code-location)
1247 "Safe wrapper around `code-location-from-source-location'."
1248 (safe-definition-finding
1249 (source-location-from-code-location code-location)))
1250
1251 (defun read-snippet (stream)
1252 (read-upto-n-chars stream *source-snippet-size*))
1253
1254 (defun read-upto-n-chars (stream n)
1255 "Return a string of upto N chars from STREAM."
1256 (let* ((string (make-string n))
1257 (chars (read-sequence string stream)))
1258 (subseq string 0 chars)))
1259
1260
1261 ;;;; Debugging
1262
1263 (defvar *sldb-stack-top*)
1264
1265 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1266 (unix:unix-sigsetmask 0)
1267 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
1268 (debug:*stack-top-hint* nil))
1269 (handler-bind ((di:debug-condition
1270 (lambda (condition)
1271 (signal (make-condition
1272 'sldb-condition
1273 :original-condition condition)))))
1274 (funcall debugger-loop-fn))))
1275
1276 (defun nth-frame (index)
1277 (do ((frame *sldb-stack-top* (di:frame-down frame))
1278 (i index (1- i)))
1279 ((zerop i) frame)))
1280
1281 (defimplementation compute-backtrace (start end)
1282 (let ((end (or end most-positive-fixnum)))
1283 (loop for f = (nth-frame start) then (di:frame-down f)
1284 for i from start below end
1285 while f
1286 collect f)))
1287
1288 (defimplementation print-frame (frame stream)
1289 (let ((*standard-output* stream))
1290 (debug::print-frame-call frame :verbosity 1 :number nil)))
1291
1292 (defimplementation frame-source-location-for-emacs (index)
1293 (code-location-source-location (di:frame-code-location (nth-frame index))))
1294
1295 (defimplementation eval-in-frame (form index)
1296 (di:eval-in-frame (nth-frame index) form))
1297
1298 (defimplementation frame-locals (index)
1299 (let* ((frame (nth-frame index))
1300 (location (di:frame-code-location frame))
1301 (debug-function (di:frame-debug-function frame))
1302 (debug-variables (di::debug-function-debug-variables debug-function)))
1303 (loop for v across debug-variables collect
1304 (list :name (di:debug-variable-symbol v)
1305 :id (di:debug-variable-id v)
1306 :value (ecase (di:debug-variable-validity v location)
1307 (:valid
1308 (di:debug-variable-value v frame))
1309 ((:invalid :unknown)
1310 ':not-available))))))
1311
1312 (defimplementation frame-catch-tags (index)
1313 (mapcar #'car (di:frame-catches (nth-frame index))))
1314
1315 (defun set-step-breakpoints (frame)
1316 (when (di:debug-block-elsewhere-p (di:code-location-debug-block
1317 (di:frame-code-location frame)))
1318 (error "Cannot step, in elsewhere code~%"))
1319 (let* ((code-location (di:frame-code-location frame))
1320 (debug::*bad-code-location-types*
1321 (remove :call-site debug::*bad-code-location-types*))
1322 (next (debug::next-code-locations code-location)))
1323 (cond (next
1324 (let ((steppoints '()))
1325 (flet ((hook (frame breakpoint)
1326 (let ((debug:*stack-top-hint* frame))
1327 (mapc #'di:delete-breakpoint steppoints)
1328 (let ((cl (di::breakpoint-what breakpoint)))
1329 (break "Breakpoint: ~S ~S"
1330 (di:code-location-kind cl)
1331 (di::compiled-code-location-pc cl))))))
1332 (dolist (code-location next)
1333 (let ((bp (di:make-breakpoint #'hook code-location
1334 :kind :code-location)))
1335 (di:activate-breakpoint bp)
1336 (push bp steppoints))))))
1337 (t
1338 (flet ((hook (frame breakpoint values cookie)
1339 (declare (ignore cookie))
1340 (di:delete-breakpoint breakpoint)
1341 (let ((debug:*stack-top-hint* frame))
1342 (break "Function-end: ~A ~A" breakpoint values))))
1343 (let* ((debug-function (di:frame-debug-function frame))
1344 (bp (di:make-breakpoint #'hook debug-function
1345 :kind :function-end)))
1346 (di:activate-breakpoint bp)))))))
1347
1348 ;; (defslimefun sldb-step (frame)
1349 ;; (cond ((find-restart 'continue *swank-debugger-condition*)
1350 ;; (set-step-breakpoints (nth-frame frame))
1351 ;; (continue *swank-debugger-condition*))
1352 ;; (t
1353 ;; (error "Cannot continue in from condition: ~A"
1354 ;; *swank-debugger-condition*))))
1355
1356 (defun frame-cfp (frame)
1357 "Return the Control-Stack-Frame-Pointer for FRAME."
1358 (etypecase frame
1359 (di::compiled-frame (di::frame-pointer frame))
1360 ((or di::interpreted-frame null) -1)))
1361
1362 (defun frame-ip (frame)
1363 "Return the (absolute) instruction pointer and the relative pc of FRAME."
1364 (if (not frame)
1365 -1
1366 (let ((debug-fun (di::frame-debug-function frame)))
1367 (etypecase debug-fun
1368 (di::compiled-debug-function
1369 (let* ((code-loc (di:frame-code-location frame))
1370 (component (di::compiled-debug-function-component debug-fun))
1371 (pc (di::compiled-code-location-pc code-loc))
1372 (ip (sys:without-gcing
1373 (sys:sap-int
1374 (sys:sap+ (kernel:code-instructions component) pc)))))
1375 (values ip pc)))
1376 ((or di::bogus-debug-function di::interpreted-debug-function)
1377 -1)))))
1378
1379 (defun frame-registers (frame)
1380 "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1381 (let* ((cfp (frame-cfp frame))
1382 (csp (frame-cfp (di::frame-up frame)))
1383 (ip (frame-ip frame))
1384 (ocfp (frame-cfp (di::frame-down frame)))
1385 (lra (frame-ip (di::frame-down frame))))
1386 (values csp cfp ip ocfp lra)))
1387
1388 (defun print-frame-registers (frame-number)
1389 (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1390 (flet ((fixnum (p) (etypecase p
1391 (integer p)
1392 (sys:system-area-pointer (sys:sap-int p)))))
1393 (apply #'format t "~
1394 CSP = ~X
1395 CFP = ~X
1396 IP = ~X
1397 OCFP = ~X
1398 LRA = ~X~%" (mapcar #'fixnum
1399 (multiple-value-list (frame-registers frame)))))))
1400
1401
1402 (defimplementation disassemble-frame (frame-number)
1403 "Return a string with the disassembly of frames code."
1404 (print-frame-registers frame-number)
1405 (terpri)
1406 (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1407 (debug-fun (di::frame-debug-function frame)))
1408 (etypecase debug-fun
1409 (di::compiled-debug-function
1410 (let* ((component (di::compiled-debug-function-component debug-fun))
1411 (fun (di:debug-function-function debug-fun)))
1412 (if fun
1413 (disassemble fun)
1414 (disassem:disassemble-code-component component))))
1415 (di::bogus-debug-function
1416 (format t "~%[Disassembling bogus frames not implemented]")))))
1417
1418
1419 ;;;; Inspecting
1420
1421 (defconstant +lowtag-symbols+
1422 '(vm:even-fixnum-type
1423 vm:function-pointer-type
1424 vm:other-immediate-0-type
1425 vm:list-pointer-type
1426 vm:odd-fixnum-type
1427 vm:instance-pointer-type
1428 vm:other-immediate-1-type
1429 vm:other-pointer-type))
1430
1431 (defconstant +header-type-symbols+
1432 (flet ((suffixp (suffix string)
1433 (and (>= (length string) (length suffix))
1434 (string= string suffix :start1 (- (length string)
1435 (length suffix))))))
1436 ;; Is there a convinient place for all those constants?
1437 (remove-if-not
1438 (lambda (x) (and (suffixp "-TYPE" (symbol-name x))
1439 (not (member x +lowtag-symbols+))
1440 (boundp x)
1441 (typep (symbol-value x) 'fixnum)))
1442 (append (apropos-list "-TYPE" "VM" t)
1443 (apropos-list "-TYPE" "BIGNUM" t))))
1444 "A list of names of the type codes in boxed objects.")
1445
1446 (defimplementation describe-primitive-type (object)
1447 (with-output-to-string (*standard-output*)
1448 (let* ((lowtag (kernel:get-lowtag object))
1449 (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1450 (format t "lowtag: ~A" lowtag-symbol)
1451 (when (member lowtag (list vm:other-pointer-type
1452 vm:function-pointer-type
1453 vm:other-immediate-0-type
1454 vm:other-immediate-1-type
1455 ))
1456 (let* ((type (kernel:get-type object))
1457 (type-symbol (find type +header-type-symbols+
1458 :key #'symbol-value)))
1459 (format t ", type: ~A" type-symbol))))))
1460
1461 (defimplementation inspected-parts (o)
1462 (cond ((di::indirect-value-cell-p o)
1463 (inspected-parts-of-value-cell o))
1464 (t
1465 (destructuring-bind (text labeledp . parts)
1466 (inspect::describe-parts o)
1467 (let ((parts (if labeledp
1468 (loop for (label . value) in parts
1469 collect (cons (string label) value))
1470 (loop for value in parts
1471 for i from 0
1472 collect (cons (format nil "~D" i) value)))))
1473 (values text parts))))))
1474
1475 (defun inspected-parts-of-value-cell (o)
1476 (values (format nil "~A~% is a value cell." o)
1477 (list (cons "Value" (c:value-cell-ref o)))))
1478
1479 (defmethod inspected-parts ((o function))
1480 (let ((header (kernel:get-type o)))
1481 (cond ((= header vm:function-header-type)
1482 (values
1483 (format nil "~A~% is a function." o)
1484 (list (cons "Self" (kernel:%function-self o))
1485 (cons "Next" (kernel:%function-next o))
1486 (cons "Name" (kernel:%function-name o))
1487 (cons "Arglist" (kernel:%function-arglist o))
1488 (cons "Type" (kernel:%function-type o))
1489 (cons "Code Object" (kernel:function-code-header o)))))
1490 ((= header vm:closure-header-type)
1491 (values (format nil "~A~% is a closure." o)
1492 (list*
1493 (cons "Function" (kernel:%closure-function o))
1494 (loop for i from 0 below (- (kernel:get-closure-length o)
1495 (1- vm:closure-info-offset))
1496 collect (cons (format nil "~D" i)
1497 (kernel:%closure-index-ref o i))))))
1498 (t (call-next-method o)))))
1499
1500 (defmethod inspected-parts ((o kernel:code-component))
1501 (values (format nil "~A~% is a code data-block." o)
1502 `(("First entry point" . ,(kernel:%code-entry-points o))
1503 ,@(loop for i from vm:code-constants-offset
1504 below (kernel:get-header-data o)
1505 collect (cons (format nil "Constant#~D" i)
1506 (kernel:code-header-ref o i)))
1507 ("Debug info" . ,(kernel:%code-debug-info o))
1508 ("Instructions" . ,(kernel:code-instructions o)))))
1509
1510 (defmethod inspected-parts ((o kernel:fdefn))
1511 (values (format nil "~A~% is a fdefn object." o)
1512 `(("Name" . ,(kernel:fdefn-name o))
1513 ("Function" . ,(kernel:fdefn-function o)))))
1514
1515
1516 ;;;; Profiling
1517 (defimplementation profile (fname)
1518 (eval `(profile:profile ,fname)))
1519
1520 (defimplementation unprofile (fname)
1521 (eval `(profile:unprofile ,fname)))
1522
1523 (defimplementation unprofile-all ()
1524 (eval '(profile:unprofile))
1525 "All functions unprofiled.")
1526
1527 (defimplementation profile-report ()
1528 (eval '(profile:report-time)))
1529
1530 (defimplementation profile-reset ()
1531 (eval '(profile:reset-time))
1532 "Reset profiling counters.")
1533
1534 (defimplementation profiled-functions ()
1535 profile:*timed-functions*)
1536
1537 (defimplementation profile-package (package callers methods)
1538 (profile:profile-all :package package
1539 :callers-p callers
1540 :methods methods))
1541
1542
1543 ;;;; Multiprocessing
1544
1545 #+mp
1546 (progn
1547 (defimplementation startup-multiprocessing ()
1548 ;; Threads magic: this never returns! But top-level becomes
1549 ;; available again.
1550 (mp::startup-idle-and-top-level-loops))
1551
1552 (defimplementation spawn (fn &key (name "Anonymous"))
1553 (mp:make-process fn :name name))
1554
1555 (defimplementation thread-name (thread)
1556 (mp:process-name thread))
1557
1558 (defimplementation thread-status (thread)
1559 (mp:process-whostate thread))
1560
1561 (defimplementation current-thread ()
1562 mp:*current-process*)
1563
1564 (defimplementation all-threads ()
1565 (copy-list mp:*all-processes*))
1566
1567 (defimplementation interrupt-thread (thread fn)
1568 (mp:process-interrupt thread fn))
1569
1570 (defimplementation kill-thread (thread)
1571 (mp:destroy-process thread))
1572
1573 (defvar *mailbox-lock* (mp:make-lock "mailbox lock"))
1574
1575 (defstruct (mailbox (:conc-name mailbox.))
1576 (mutex (mp:make-lock "process mailbox"))
1577 (queue '() :type list))
1578
1579 (defun mailbox (thread)
1580 "Return THREAD's mailbox."
1581 (mp:with-lock-held (*mailbox-lock*)
1582 (or (getf (mp:process-property-list thread) 'mailbox)
1583 (setf (getf (mp:process-property-list thread) 'mailbox)
1584 (make-mailbox)))))
1585
1586 (defimplementation send (thread message)
1587 (let* ((mbox (mailbox thread))
1588 (mutex (mailbox.mutex mbox)))
1589 (mp:with-lock-held (mutex)
1590 (setf (mailbox.queue mbox)
1591 (nconc (mailbox.queue mbox) (list message))))))
1592
1593 (defimplementation receive ()
1594 (let* ((mbox (mailbox mp:*current-process*))
1595 (mutex (mailbox.mutex mbox)))
1596 (mp:process-wait "receive" #'mailbox.queue mbox)
1597 (mp:with-lock-held (mutex)
1598 (pop (mailbox.queue mbox)))))
1599
1600 )

  ViewVC Help
Powered by ViewVC 1.1.5