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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.133 - (show annotations)
Wed Jun 1 12:22:45 2005 UTC (8 years, 10 months ago) by heller
Branch: MAIN
Changes since 1.132: +16 -9 lines
Distinguish macro and special operators from functions.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4 ;;;
5 ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties are
8 ;;; disclaimed.
9
10 ;;; Requires the SB-INTROSPECT contrib.
11
12 ;;; Administrivia
13
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require 'sb-bsd-sockets)
16 (require 'sb-introspect)
17 (require 'sb-posix))
18
19 (in-package :swank-backend)
20 (declaim (optimize (debug 2)))
21
22 (import
23 '(sb-gray:fundamental-character-output-stream
24 sb-gray:stream-write-char
25 sb-gray:stream-line-length
26 sb-gray:stream-force-output
27 sb-gray:fundamental-character-input-stream
28 sb-gray:stream-read-char
29 sb-gray:stream-listen
30 sb-gray:stream-unread-char
31 sb-gray:stream-clear-input
32 sb-gray:stream-line-column
33 sb-gray:stream-line-length))
34
35 ;;; swank-mop
36
37 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
38
39 (defun swank-mop:slot-definition-documentation (slot)
40 (sb-pcl::documentation slot t))
41
42 ;;; TCP Server
43
44 (defimplementation preferred-communication-style ()
45 (if (and (member :sb-thread *features*)
46 (not (sb-alien:extern-alien "linux_no_threads_p" sb-alien:boolean)))
47 :spawn
48 :fd-handler))
49
50 (defun resolve-hostname (name)
51 (car (sb-bsd-sockets:host-ent-addresses
52 (sb-bsd-sockets:get-host-by-name name))))
53
54 (defimplementation create-socket (host port)
55 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
56 :type :stream
57 :protocol :tcp)))
58 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
59 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
60 (sb-bsd-sockets:socket-listen socket 5)
61 socket))
62
63 (defimplementation local-port (socket)
64 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
65
66 (defimplementation close-socket (socket)
67 (sb-sys:invalidate-descriptor (socket-fd socket))
68 (sb-bsd-sockets:socket-close socket))
69
70 (defimplementation accept-connection (socket
71 &key (external-format :iso-latin-1-unix))
72 (make-socket-io-stream (accept socket) external-format))
73
74 (defvar *sigio-handlers* '()
75 "List of (key . fn) pairs to be called on SIGIO.")
76
77 (defun sigio-handler (signal code scp)
78 (declare (ignore signal code scp))
79 (mapc (lambda (handler)
80 (funcall (the function (cdr handler))))
81 *sigio-handlers*))
82
83 (defun set-sigio-handler ()
84 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
85 (sigio-handler signal code scp))))
86
87 (defun enable-sigio-on-fd (fd)
88 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
89 (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
90
91 (defimplementation add-sigio-handler (socket fn)
92 (set-sigio-handler)
93 (let ((fd (socket-fd socket)))
94 (format *debug-io* "Adding sigio handler: ~S ~%" fd)
95 (enable-sigio-on-fd fd)
96 (push (cons fd fn) *sigio-handlers*)))
97
98 (defimplementation remove-sigio-handlers (socket)
99 (let ((fd (socket-fd socket)))
100 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
101 (sb-sys:invalidate-descriptor fd))
102 (close socket))
103
104 (defimplementation add-fd-handler (socket fn)
105 (declare (type function fn))
106 (let ((fd (socket-fd socket)))
107 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
108 (sb-sys:add-fd-handler fd :input (lambda (_)
109 _
110 (funcall fn)))))
111
112 (defimplementation remove-fd-handlers (socket)
113 (sb-sys:invalidate-descriptor (socket-fd socket)))
114
115 (defun socket-fd (socket)
116 (etypecase socket
117 (fixnum socket)
118 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
119 (file-stream (sb-sys:fd-stream-fd socket))))
120
121 (defun make-socket-io-stream (socket external-format)
122 (let ((encoding (ecase external-format
123 (:iso-latin-1-unix :iso-8859-1)
124 #+sb-unicode
125 (:utf-8-unix :utf-8))))
126 (sb-bsd-sockets:socket-make-stream socket
127 :output t
128 :input t
129 :element-type 'character
130 #+sb-unicode :external-format
131 #+sb-unicode encoding
132 )))
133
134 (defun accept (socket)
135 "Like socket-accept, but retry on EAGAIN."
136 (loop (handler-case
137 (return (sb-bsd-sockets:socket-accept socket))
138 (sb-bsd-sockets:interrupted-error ()))))
139
140 (defmethod call-without-interrupts (fn)
141 (declare (type function fn))
142 (sb-sys:without-interrupts (funcall fn)))
143
144 (defimplementation getpid ()
145 (sb-posix:getpid))
146
147 (defimplementation lisp-implementation-type-name ()
148 "sbcl")
149
150
151 ;;;; Support for SBCL syntax
152
153 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
154 ;;; containing `!' have special meaning. We have to work long and
155 ;;; hard to be able to read the source. To deal with #! reader
156 ;;; macros, we use a special readtable. The special symbols are
157 ;;; converted by a condition handler.
158
159 (defun feature-in-list-p (feature list)
160 (etypecase feature
161 (symbol (member feature list :test #'eq))
162 (cons (flet ((subfeature-in-list-p (subfeature)
163 (feature-in-list-p subfeature list)))
164 (ecase (first feature)
165 (:or (some #'subfeature-in-list-p (rest feature)))
166 (:and (every #'subfeature-in-list-p (rest feature)))
167 (:not (destructuring-bind (e) (cdr feature)
168 (not (subfeature-in-list-p e)))))))))
169
170 (defun shebang-reader (stream sub-character infix-parameter)
171 (declare (ignore sub-character))
172 (when infix-parameter
173 (error "illegal read syntax: #~D!" infix-parameter))
174 (let ((next-char (read-char stream)))
175 (unless (find next-char "+-")
176 (error "illegal read syntax: #!~C" next-char))
177 ;; When test is not satisfied
178 ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
179 ;; would become "unless test is satisfied"..
180 (when (let* ((*package* (find-package "KEYWORD"))
181 (*read-suppress* nil)
182 (not-p (char= next-char #\-))
183 (feature (read stream)))
184 (if (feature-in-list-p feature *features*)
185 not-p
186 (not not-p)))
187 ;; Read (and discard) a form from input.
188 (let ((*read-suppress* t))
189 (read stream t nil t))))
190 (values))
191
192 (defvar *shebang-readtable*
193 (let ((*readtable* (copy-readtable nil)))
194 (set-dispatch-macro-character #\# #\!
195 (lambda (s c n) (shebang-reader s c n))
196 *readtable*)
197 *readtable*))
198
199 (defun shebang-readtable ()
200 *shebang-readtable*)
201
202 (defun sbcl-package-p (package)
203 (let ((name (package-name package)))
204 (eql (mismatch "SB-" name) 3)))
205
206 (defun sbcl-source-file-p (filename)
207 (loop for (_ pattern) in (logical-pathname-translations "SYS")
208 thereis (pathname-match-p filename pattern)))
209
210 (defun guess-readtable-for-filename (filename)
211 (if (sbcl-source-file-p filename)
212 (shebang-readtable)
213 *readtable*))
214
215 (defvar *debootstrap-packages* t)
216
217 (defun call-with-debootstrapping (fun)
218 (handler-bind ((sb-int:bootstrap-package-not-found
219 #'sb-int:debootstrap-package))
220 (funcall fun)))
221
222 (defmacro with-debootstrapping (&body body)
223 `(call-with-debootstrapping (lambda () ,@body)))
224
225 (defimplementation call-with-syntax-hooks (fn)
226 (cond ((and *debootstrap-packages*
227 (sbcl-package-p *package*))
228 (with-debootstrapping (funcall fn)))
229 (t
230 (funcall fn))))
231
232 (defimplementation default-readtable-alist ()
233 (let ((readtable (shebang-readtable)))
234 (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
235 collect (cons (package-name p) readtable))))
236
237 ;;; Utilities
238
239 (defimplementation arglist ((fname t))
240 (sb-introspect:function-arglist fname))
241
242 (defimplementation function-name ((f function))
243 (sb-impl::%fun-name f))
244
245 (defvar *buffer-name* nil)
246 (defvar *buffer-offset*)
247 (defvar *buffer-substring* nil)
248
249 (defvar *previous-compiler-condition* nil
250 "Used to detect duplicates.")
251
252 (defun handle-notification-condition (condition)
253 "Handle a condition caused by a compiler warning.
254 This traps all compiler conditions at a lower-level than using
255 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
256 craft our own error messages, which can omit a lot of redundant
257 information."
258 (let ((context (sb-c::find-error-context nil)))
259 (unless (eq condition *previous-compiler-condition*)
260 (setq *previous-compiler-condition* condition)
261 (signal-compiler-condition condition context))))
262
263 (defun signal-compiler-condition (condition context)
264 (signal (make-condition
265 'compiler-condition
266 :original-condition condition
267 :severity (etypecase condition
268 (sb-c:compiler-error :error)
269 (sb-ext:compiler-note :note)
270 (style-warning :style-warning)
271 (warning :warning)
272 (error :error))
273 :short-message (brief-compiler-message-for-emacs condition)
274 :references (condition-references (real-condition condition))
275 :message (long-compiler-message-for-emacs condition context)
276 :location (compiler-note-location context))))
277
278 (defun real-condition (condition)
279 "Return the encapsulated condition or CONDITION itself."
280 (typecase condition
281 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
282 (t condition)))
283
284 (defun compiler-note-location (context)
285 (if context
286 (locate-compiler-note
287 (sb-c::compiler-error-context-file-name context)
288 (compiler-source-path context)
289 (sb-c::compiler-error-context-original-source context))
290 (list :error "No error location available")))
291
292 (defun locate-compiler-note (file source-path source)
293 (cond ((and (pathnamep file) *buffer-name*)
294 ;; Compiling from a buffer
295 (let ((position (+ *buffer-offset*
296 (source-path-string-position
297 source-path *buffer-substring*))))
298 (make-location (list :buffer *buffer-name*)
299 (list :position position))))
300 ((and (pathnamep file) (null *buffer-name*))
301 ;; Compiling from a file
302 (make-location (list :file (namestring file))
303 (list :position
304 (1+ (source-path-file-position
305 source-path file)))))
306 ((and (eq file :lisp) (stringp source))
307 ;; Compiling macro generated code
308 (make-location (list :source-form source)
309 (list :position 1)))
310 (t
311 (error "unhandled case"))))
312
313 (defun brief-compiler-message-for-emacs (condition)
314 "Briefly describe a compiler error for Emacs.
315 When Emacs presents the message it already has the source popped up
316 and the source form highlighted. This makes much of the information in
317 the error-context redundant."
318 (let ((sb-int:*print-condition-references* nil))
319 (princ-to-string condition)))
320
321 (defun long-compiler-message-for-emacs (condition error-context)
322 "Describe a compiler error for Emacs including context information."
323 (declare (type (or sb-c::compiler-error-context null) error-context))
324 (multiple-value-bind (enclosing source)
325 (if error-context
326 (values (sb-c::compiler-error-context-enclosing-source error-context)
327 (sb-c::compiler-error-context-source error-context)))
328 (let ((sb-int:*print-condition-references* nil))
329 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
330 enclosing source condition))))
331
332 (defun compiler-source-path (context)
333 "Return the source-path for the current compiler error.
334 Returns NIL if this cannot be determined by examining internal
335 compiler state."
336 (cond ((sb-c::node-p context)
337 (reverse
338 (sb-c::source-path-original-source
339 (sb-c::node-source-path context))))
340 ((sb-c::compiler-error-context-p context)
341 (reverse
342 (sb-c::compiler-error-context-original-source-path context)))))
343
344 (defimplementation call-with-compilation-hooks (function)
345 (declare (type function function))
346 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
347 (sb-c:compiler-error #'handle-notification-condition)
348 (sb-ext:compiler-note #'handle-notification-condition)
349 (style-warning #'handle-notification-condition)
350 (warning #'handle-notification-condition))
351 (funcall function)))
352
353 (defun handle-file-compiler-termination (condition)
354 "Handle a condition that caused the file compiler to terminate."
355 (handle-notification-condition
356 (sb-int:encapsulated-condition condition)))
357
358 (defvar *trap-load-time-warnings* nil)
359
360 (defimplementation swank-compile-file (filename load-p)
361 (handler-case
362 (let ((output-file (with-compilation-hooks ()
363 (compile-file filename))))
364 (when output-file
365 ;; Cache the latest source file for definition-finding.
366 (source-cache-get filename (file-write-date filename))
367 (when load-p
368 (load output-file))))
369 (sb-c:fatal-compiler-error () nil)))
370
371 ;;;; compile-string
372
373 ;;; We patch sb-c::debug-source-for-info so that we can dump our own
374 ;;; bits of source info. Our *user-source-info* is stored in the
375 ;;; debug-source-info slot.
376
377 (defvar *real-debug-source-for-info*)
378 (defvar *user-source-info*)
379
380 (defun debug-source-for-info-advice (info)
381 (destructuring-bind (source) (funcall *real-debug-source-for-info* info)
382 (when (boundp '*user-source-info*)
383 (setf (sb-c::debug-source-info source) *user-source-info*))
384 (list source)))
385
386 (defun install-debug-source-patch ()
387 (unless (boundp '*real-debug-source-for-info*)
388 (setq *real-debug-source-for-info* #'sb-c::debug-source-for-info))
389 (sb-ext:without-package-locks
390 (setf (symbol-function 'sb-c::debug-source-for-info)
391 #'debug-source-for-info-advice)))
392
393 (defimplementation swank-compile-string (string &key buffer position directory)
394 (declare (ignore directory))
395 (install-debug-source-patch)
396 (call/temp-file
397 string
398 (lambda (filename)
399 (let ((*user-source-info* (list :emacs-buffer buffer :emacs-string string
400 :emacs-position position))
401 (*buffer-name* buffer)
402 (*buffer-offset* position)
403 (*buffer-substring* string))
404 (let ((fasl (with-compilation-hooks ()
405 (compile-file filename))))
406 (load fasl)
407 (delete-file fasl))))))
408
409 (defun call/temp-file (string fun)
410 (let ((filename (temp-file-name)))
411 (unwind-protect
412 (with-open-file (s filename :direction :output :if-exists :error)
413 (write-string string s)
414 (finish-output s)
415 (funcall fun filename))
416 (when (probe-file filename)
417 (delete-file filename)))))
418
419 (defun temp-file-name ()
420 "Return a temporary file name to compile strings into."
421 (sb-alien:alien-funcall
422 (sb-alien:extern-alien
423 "tmpnam"
424 (function sb-alien:c-string sb-alien:system-area-pointer))
425 (sb-sys:int-sap 0)))
426
427 ;;;; Definitions
428
429 (defvar *debug-definition-finding* nil
430 "When true don't handle errors while looking for definitions.
431 This is useful when debugging the definition-finding code.")
432
433 (defimplementation find-definitions (name)
434 (append (function-definitions name)
435 (compiler-definitions name)))
436
437 ;;;;; Function definitions
438
439 (defun function-definitions (name)
440 (flet ((loc (fn name) (safe-function-source-location fn name)))
441 (append
442 (cond ((and (symbolp name) (macro-function name))
443 (list (list `(defmacro ,name)
444 (loc (macro-function name) name))))
445 ((fboundp name)
446 (let ((fn (fdefinition name)))
447 (typecase fn
448 (generic-function
449 (cons (list `(defgeneric ,name) (loc fn name))
450 (method-definitions fn)))
451 (t
452 (list (list `(function ,name) (loc fn name))))))))
453 (when (compiler-macro-function name)
454 (list (list `(define-compiler-macro ,name)
455 (loc (compiler-macro-function name) name)))))))
456
457 ;;;; function -> soucre location translation
458
459 ;;; Here we try to find the source locations for function objects. We
460 ;;; have to special case functions which were compiled with C-c C-c.
461 ;;; For the other functions we used the toplevel form number as
462 ;;; returned by the sb-introspect package to find the offset in the
463 ;;; source file. (If the function has debug-blocks, we should search
464 ;;; the position of the first code-location; for some reason, that
465 ;;; doesn't seem to work.)
466
467 (defun function-source-location (function &optional name)
468 "Try to find the canonical source location of FUNCTION."
469 (declare (type function function))
470 (if (function-from-emacs-buffer-p function)
471 (find-temp-function-source-location function)
472 (find-function-source-location function)))
473
474 (defun safe-function-source-location (fun name)
475 (if *debug-definition-finding*
476 (function-source-location fun name)
477 (handler-case (function-source-location fun name)
478 (error (e)
479 (list :error (format nil "Error: ~A" e))))))
480
481 (defun find-function-source-location (function)
482 (cond #+(or) ;; doesn't work for unknown reasons
483 ((function-has-start-location-p function)
484 (code-location-source-location (function-start-location function)))
485 ((not (function-source-filename function))
486 (error "Source filename not recorded for ~A" function))
487 (t
488 (let* ((pos (function-source-position function))
489 (snippet (function-hint-snippet function pos)))
490 (make-location `(:file ,(function-source-filename function))
491 `(:position ,pos)
492 `(:snippet ,snippet))))))
493
494 (defun function-source-position (function)
495 ;; We only consider the toplevel form number here.
496 (let* ((tlf (function-toplevel-form-number function))
497 (filename (function-source-filename function))
498 (*readtable* (guess-readtable-for-filename filename)))
499 (with-debootstrapping
500 (source-path-file-position (list tlf) filename))))
501
502 (defun function-source-filename (function)
503 (ignore-errors
504 (namestring
505 (truename
506 (sb-introspect:definition-source-pathname
507 (sb-introspect:find-definition-source function))))))
508
509 (defun function-source-write-date (function)
510 (definition-source-file-write-date
511 (sb-introspect:find-definition-source function)))
512
513 (defun function-toplevel-form-number (function)
514 (car
515 (sb-introspect:definition-source-form-path
516 (sb-introspect:find-definition-source function))))
517
518 (defun function-hint-snippet (function position)
519 (let ((source (get-source-code (function-source-filename function)
520 (function-source-write-date function))))
521 (with-input-from-string (s source)
522 (read-snippet s position))))
523
524 (defun function-has-start-location-p (function)
525 (ignore-errors (function-start-location function)))
526
527 (defun function-start-location (function)
528 (let ((dfun (sb-di:fun-debug-fun function)))
529 (and dfun (sb-di:debug-fun-start-location dfun))))
530
531 (defun find-temp-function-source-location (function)
532 (let ((info (function-debug-source-info function)))
533 (with-struct (sb-introspect::definition-source-
534 form-path character-offset)
535 (sb-introspect:find-definition-source function)
536 (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
537 (let ((pos (if form-path
538 (with-debootstrapping
539 (source-path-string-position
540 form-path emacs-string))
541 character-offset)))
542 (make-location `(:buffer ,emacs-buffer)
543 `(:position ,(+ pos emacs-position))
544 `(:snippet ,emacs-string)))))))
545
546 ;; FIXME: Symbol doesn't exist in released SBCL (0.8.20) yet.
547 (defun definition-source-file-write-date (def)
548 (let ((sym (find-symbol "DEFINITION-SOURCE-FILE-WRITE-DATE"
549 (find-package "SB-INTROSPECT"))))
550 (when sym (funcall sym def))))
551
552 (defun method-definitions (gf)
553 (let ((methods (sb-mop:generic-function-methods gf))
554 (name (sb-mop:generic-function-name gf)))
555 (loop for method in methods
556 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
557 (method-source-location method)))))
558
559 (defun method-source-location (method)
560 (safe-function-source-location (or (sb-pcl::method-fast-function method)
561 (sb-pcl:method-function method))
562 nil))
563
564 ;;;;; Compiler definitions
565
566 (defun compiler-definitions (name)
567 (let ((fun-info (sb-int:info :function :info name)))
568 (when fun-info
569 (append (transform-definitions fun-info name)
570 (optimizer-definitions fun-info name)))))
571
572 (defun transform-definitions (fun-info name)
573 (loop for xform in (sb-c::fun-info-transforms fun-info)
574 for loc = (safe-function-source-location
575 (sb-c::transform-function xform) name)
576 for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
577 for note = (sb-c::transform-note xform)
578 for spec = (if (consp typespec)
579 `(sb-c:deftransform ,(second typespec) ,note)
580 `(sb-c:deftransform ,note))
581 collect `(,spec ,loc)))
582
583 (defun optimizer-definitions (fun-info fun-name)
584 (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
585 (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
586 (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
587 (sb-c::fun-info-optimizer . sb-c:optimizer))))
588 (loop for (reader . name) in otypes
589 for fn = (funcall reader fun-info)
590 when fn collect `((sb-c:defoptimizer ,name)
591 ,(safe-function-source-location fn fun-name)))))
592
593 (defimplementation describe-symbol-for-emacs (symbol)
594 "Return a plist describing SYMBOL.
595 Return NIL if the symbol is unbound."
596 (let ((result '()))
597 (flet ((doc (kind)
598 (or (documentation symbol kind) :not-documented))
599 (maybe-push (property value)
600 (when value
601 (setf result (list* property value result)))))
602 (maybe-push
603 :variable (multiple-value-bind (kind recorded-p)
604 (sb-int:info :variable :kind symbol)
605 (declare (ignore kind))
606 (if (or (boundp symbol) recorded-p)
607 (doc 'variable))))
608 (when (fboundp symbol)
609 (maybe-push
610 (cond ((macro-function symbol) :macro)
611 ((special-operator-p symbol) :special-operator)
612 ((typep (fdefinition symbol) 'generic-function)
613 :generic-function)
614 (t :function))
615 (doc 'function)))
616 (maybe-push
617 :setf (if (or (sb-int:info :setf :inverse symbol)
618 (sb-int:info :setf :expander symbol))
619 (doc 'setf)))
620 (maybe-push
621 :type (if (sb-int:info :type :kind symbol)
622 (doc 'type)))
623 result)))
624
625 (defimplementation describe-definition (symbol type)
626 (case type
627 (:variable
628 (describe symbol))
629 (:function
630 (describe (symbol-function symbol)))
631 (:setf
632 (describe (or (sb-int:info :setf :inverse symbol)
633 (sb-int:info :setf :expander symbol))))
634 (:class
635 (describe (find-class symbol)))
636 (:type
637 (describe (sb-kernel:values-specifier-type symbol)))))
638
639 (defimplementation list-callers (symbol)
640 (let ((fn (fdefinition symbol)))
641 (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
642
643 (defimplementation list-callees (symbol)
644 (let ((fn (fdefinition symbol)))
645 (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
646
647 (defun function-dspec (fn)
648 "Describe where the function FN was defined.
649 Return a list of the form (NAME LOCATION)."
650 (let ((name (sb-kernel:%fun-name fn)))
651 (list name (safe-function-source-location fn name))))
652
653 ;;; macroexpansion
654
655 (defimplementation macroexpand-all (form)
656 (let ((sb-walker:*walk-form-expand-macros-p* t))
657 (sb-walker:walk-form form)))
658
659
660 ;;; Debugging
661
662 (defvar *sldb-stack-top*)
663
664 (defimplementation call-with-debugging-environment (debugger-loop-fn)
665 (declare (type function debugger-loop-fn))
666 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
667 (sb-debug:*stack-top-hint* nil))
668 (handler-bind ((sb-di:debug-condition
669 (lambda (condition)
670 (signal (make-condition
671 'sldb-condition
672 :original-condition condition)))))
673 (funcall debugger-loop-fn))))
674
675 (defimplementation call-with-debugger-hook (hook fun)
676 (let ((sb-ext:*invoke-debugger-hook* hook))
677 (funcall fun)))
678
679 (defun nth-frame (index)
680 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
681 (i index (1- i)))
682 ((zerop i) frame)))
683
684 (defimplementation compute-backtrace (start end)
685 "Return a list of frames starting with frame number START and
686 continuing to frame number END or, if END is nil, the last frame on the
687 stack."
688 (let ((end (or end most-positive-fixnum)))
689 (loop for f = (nth-frame start) then (sb-di:frame-down f)
690 for i from start below end
691 while f
692 collect f)))
693
694 (defimplementation print-frame (frame stream)
695 (macrolet ((printer-form ()
696 ;; MEGAKLUDGE: As SBCL 0.8.20.1 fixed its debug IO style
697 ;; our usage of unexported interfaces came back to haunt
698 ;; us. And since we still use the same interfaces it will
699 ;; haunt us again.
700 (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))
701 (if (fboundp print-sym)
702 (let* ((args (sb-introspect:function-arglist print-sym))
703 (key-pos (position '&key args)))
704 (cond ((eql 2 key-pos)
705 `(,print-sym frame stream))
706 ((eql 1 key-pos)
707 `(let ((*standard-output* stream))
708 (,print-sym frame)))
709 (t
710 (error "*THWAP* SBCL changes internals ~
711 again!"))))
712 (error "You're in a twisty little maze of unsupported
713 SBCL interfaces, all different.")))))
714 (printer-form)))
715
716 ;;;; Code-location -> source-location translation
717
718 ;;; If debug-block info is avaibale, we determine the file position of
719 ;;; the source-path for a code-location. If the code was compiled
720 ;;; with C-c C-c, we have to search the position in the source string.
721 ;;; If there's no debug-block info, we return the (less precise)
722 ;;; source-location of the corresponding function.
723
724 (defun code-location-source-location (code-location)
725 (let ((dsource (sb-di:code-location-debug-source code-location)))
726 (ecase (sb-di:debug-source-from dsource)
727 (:file (file-source-location code-location))
728 (:lisp (lisp-source-location code-location)))))
729
730 (defun file-source-location (code-location)
731 (cond ((code-location-has-debug-block-info-p code-location)
732 (if (code-location-from-emacs-buffer-p code-location)
733 (temp-file-source-location code-location)
734 (source-file-source-location code-location)))
735 (t
736 (let ((fun (code-location-debug-fun-fun code-location)))
737 (cond (fun (function-source-location fun))
738 (t (error "Cannot find source location for: ~A "
739 code-location)))))))
740
741 (defun lisp-source-location (code-location)
742 (let ((source (with-output-to-string (*standard-output*)
743 (print-code-location-source-form code-location 100))))
744 (make-location `(:source-form ,source) '(:position 0))))
745
746 (defun temp-file-source-location (code-location)
747 (let ((info (code-location-debug-source-info code-location)))
748 (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
749 (let* ((pos (string-source-position code-location emacs-string))
750 (snipped (with-input-from-string (s emacs-string)
751 (read-snippet s pos))))
752 (make-location `(:buffer ,emacs-buffer)
753 `(:position ,(+ emacs-position pos))
754 `(:snippet ,snipped))))))
755
756 (defun source-file-source-location (code-location)
757 (let* ((code-date (code-location-debug-source-created code-location))
758 (filename (code-location-debug-source-name code-location))
759 (source-code (get-source-code filename code-date)))
760 (with-input-from-string (s source-code)
761 (let* ((pos (stream-source-position code-location s))
762 (snippet (read-snippet s pos)))
763 (make-location `(:file ,filename)
764 `(:position ,(1+ pos))
765 `(:snippet ,snippet))))))
766
767 (defun code-location-debug-source-info (code-location)
768 (sb-c::debug-source-info (sb-di::code-location-debug-source code-location)))
769
770 (defun code-location-debug-source-name (code-location)
771 (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
772
773 (defun code-location-debug-source-created (code-location)
774 (sb-c::debug-source-created
775 (sb-di::code-location-debug-source code-location)))
776
777 (defun code-location-debug-fun-fun (code-location)
778 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
779
780 (defun code-location-from-emacs-buffer-p (code-location)
781 (info-from-emacs-buffer-p (code-location-debug-source-info code-location)))
782
783 (defun function-from-emacs-buffer-p (function)
784 (info-from-emacs-buffer-p (function-debug-source-info function)))
785
786 (defun function-debug-source-info (function)
787 (let* ((comp (sb-di::compiled-debug-fun-component
788 (sb-di::fun-debug-fun function))))
789 (sb-c::debug-source-info (car (sb-c::debug-info-source
790 (sb-kernel:%code-debug-info comp))))))
791
792 (defun info-from-emacs-buffer-p (info)
793 (and info
794 (consp info)
795 (eq :emacs-buffer (car info))))
796
797 (defun code-location-has-debug-block-info-p (code-location)
798 (handler-case
799 (progn (sb-di:code-location-debug-block code-location)
800 t)
801 (sb-di:no-debug-blocks () nil)))
802
803 (defun stream-source-position (code-location stream)
804 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
805 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
806 (form-number (sb-di::code-location-form-number cloc)))
807 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
808 (let* ((path-table (sb-di::form-number-translations tlf 0))
809 (path (cond ((<= (length path-table) form-number)
810 (warn "inconsistent form-number-translations")
811 (list 0))
812 (t
813 (reverse (cdr (aref path-table form-number)))))))
814 (source-path-source-position path tlf pos-map)))))
815
816 (defun string-source-position (code-location string)
817 (with-input-from-string (s string)
818 (stream-source-position code-location s)))
819
820 ;;; source-path-file-position and friends are in swank-source-path-parser
821
822 (defun print-code-location-source-form (code-location context)
823 (macrolet ((printer-form ()
824 ;; KLUDGE: These are both unexported interfaces, used
825 ;; by different versions of SBCL. ...sooner or later
826 ;; this will change again: hopefully by then we have
827 ;; figured out the interface we want to drive the
828 ;; debugger with and requested it from the SBCL
829 ;; folks.
830 (let ((print-code-sym
831 (find-symbol "PRINT-CODE-LOCATION-SOURCE-FORM"
832 :sb-debug))
833 (code-sym
834 (find-symbol "CODE-LOCATION-SOURCE-FORM"
835 :sb-debug)))
836 (cond ((fboundp print-code-sym)
837 `(,print-code-sym code-location context))
838 ((fboundp code-sym)
839 `(prin1 (,code-sym code-location context)))
840 (t
841 (error
842 "*THWAP* SBCL changes its debugger interface ~
843 again!"))))))
844 (printer-form)))
845
846 (defun safe-source-location-for-emacs (code-location)
847 (if *debug-definition-finding*
848 (code-location-source-location code-location)
849 (handler-case (code-location-source-location code-location)
850 (error (c) (list :error (format nil "~A" c))))))
851
852 (defimplementation frame-source-location-for-emacs (index)
853 (safe-source-location-for-emacs
854 (sb-di:frame-code-location (nth-frame index))))
855
856 (defun frame-debug-vars (frame)
857 "Return a vector of debug-variables in frame."
858 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
859
860 (defun debug-var-value (var frame location)
861 (ecase (sb-di:debug-var-validity var location)
862 (:valid (sb-di:debug-var-value var frame))
863 ((:invalid :unknown) ':<not-available>)))
864
865 (defimplementation frame-locals (index)
866 (let* ((frame (nth-frame index))
867 (loc (sb-di:frame-code-location frame))
868 (vars (frame-debug-vars frame)))
869 (loop for v across vars collect
870 (list :name (sb-di:debug-var-symbol v)
871 :id (sb-di:debug-var-id v)
872 :value (debug-var-value v frame loc)))))
873
874 (defimplementation frame-var-value (frame var)
875 (let* ((frame (nth-frame frame))
876 (dvar (aref (frame-debug-vars frame) var)))
877 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
878
879 (defimplementation frame-catch-tags (index)
880 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
881
882 (defimplementation eval-in-frame (form index)
883 (let ((frame (nth-frame index)))
884 (funcall (the function
885 (sb-di:preprocess-for-eval form
886 (sb-di:frame-code-location frame)))
887 frame)))
888
889 (defun sb-debug-catch-tag-p (tag)
890 (and (symbolp tag)
891 (not (symbol-package tag))
892 (string= tag :sb-debug-catch-tag)))
893
894 (defimplementation return-from-frame (index form)
895 (let* ((frame (nth-frame index))
896 (probe (assoc-if #'sb-debug-catch-tag-p
897 (sb-di::frame-catches frame))))
898 (cond (probe (throw (car probe) (eval-in-frame form index)))
899 (t (format nil "Cannot return from frame: ~S" frame)))))
900
901 ;;;;; reference-conditions
902
903 (defimplementation format-sldb-condition (condition)
904 (let ((sb-int:*print-condition-references* nil))
905 (princ-to-string condition)))
906
907 (defimplementation condition-references (condition)
908 (if (typep condition 'sb-int:reference-condition)
909 (sb-int:reference-condition-references condition)
910 '()))
911
912
913 ;;;; Profiling
914
915 (defimplementation profile (fname)
916 (when fname (eval `(sb-profile:profile ,fname))))
917
918 (defimplementation unprofile (fname)
919 (when fname (eval `(sb-profile:unprofile ,fname))))
920
921 (defimplementation unprofile-all ()
922 (sb-profile:unprofile)
923 "All functions unprofiled.")
924
925 (defimplementation profile-report ()
926 (sb-profile:report))
927
928 (defimplementation profile-reset ()
929 (sb-profile:reset)
930 "Reset profiling counters.")
931
932 (defimplementation profiled-functions ()
933 (sb-profile:profile))
934
935 (defimplementation profile-package (package callers methods)
936 (declare (ignore callers methods))
937 (eval `(sb-profile:profile ,(package-name (find-package package)))))
938
939
940 ;;;; Inspector
941
942 (defclass sbcl-inspector (inspector)
943 ())
944
945 (defimplementation make-default-inspector ()
946 (make-instance 'sbcl-inspector))
947
948 (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
949 (declare (ignore inspector))
950 (cond ((sb-di::indirect-value-cell-p o)
951 (values "A value cell." (label-value-line*
952 (:value (sb-kernel:value-cell-ref o)))))
953 (t
954 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
955 (if label
956 (values text (loop for (l . v) in parts
957 append (label-value-line l v)))
958 (values text (loop for value in parts for i from 0
959 append (label-value-line i value))))))))
960
961 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
962 (declare (ignore inspector))
963 (let ((header (sb-kernel:widetag-of o)))
964 (cond ((= header sb-vm:simple-fun-header-widetag)
965 (values "A simple-fun."
966 (label-value-line*
967 (:name (sb-kernel:%simple-fun-name o))
968 (:arglist (sb-kernel:%simple-fun-arglist o))
969 (:self (sb-kernel:%simple-fun-self o))
970 (:next (sb-kernel:%simple-fun-next o))
971 (:type (sb-kernel:%simple-fun-type o))
972 (:code (sb-kernel:fun-code-header o)))))
973 ((= header sb-vm:closure-header-widetag)
974 (values "A closure."
975 (append
976 (label-value-line :function (sb-kernel:%closure-fun o))
977 `("Closed over values:" (:newline))
978 (loop for i below (1- (sb-kernel:get-closure-length o))
979 append (label-value-line
980 i (sb-kernel:%closure-index-ref o i))))))
981 (t (call-next-method o)))))
982
983 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
984 (declare (ignore _))
985 (values (format nil "~A is a code data-block." o)
986 (append
987 (label-value-line*
988 (:code-size (sb-kernel:%code-code-size o))
989 (:entry-points (sb-kernel:%code-entry-points o))
990 (:debug-info (sb-kernel:%code-debug-info o))
991 (:trace-table-offset (sb-kernel:code-header-ref
992 o sb-vm:code-trace-table-offset-slot)))
993 `("Constants:" (:newline))
994 (loop for i from sb-vm:code-constants-offset
995 below (sb-kernel:get-header-data o)
996 append (label-value-line i (sb-kernel:code-header-ref o i)))
997 `("Code:" (:newline)
998 , (with-output-to-string (s)
999 (cond ((sb-kernel:%code-debug-info o)
1000 (sb-disassem:disassemble-code-component o :stream s))
1001 (t
1002 (sb-disassem:disassemble-memory
1003 (sb-disassem::align
1004 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1005 sb-vm:lowtag-mask)
1006 (* sb-vm:code-constants-offset
1007 sb-vm:n-word-bytes))
1008 (ash 1 sb-vm:n-lowtag-bits))
1009 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1010 :stream s))))))))
1011
1012 (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
1013 (declare (ignore inspector))
1014 (values "A fdefn object."
1015 (label-value-line*
1016 (:name (sb-kernel:fdefn-name o))
1017 (:function (sb-kernel:fdefn-fun o)))))
1018
1019 (defmethod inspect-for-emacs :around ((o generic-function)
1020 (inspector sbcl-inspector))
1021 (declare (ignore inspector))
1022 (multiple-value-bind (title contents) (call-next-method)
1023 (values title
1024 (append
1025 contents
1026 (label-value-line*
1027 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1028 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1029 )))))
1030
1031
1032 ;;;; Multiprocessing
1033
1034 #+sb-thread
1035 (progn
1036 (defimplementation spawn (fn &key name)
1037 (declare (ignore name))
1038 (sb-thread:make-thread fn))
1039
1040 (defimplementation startup-multiprocessing ())
1041
1042 (defimplementation thread-id (thread)
1043 thread)
1044
1045 (defimplementation find-thread (id)
1046 (if (member id (all-threads))
1047 id))
1048
1049 (defimplementation thread-name (thread)
1050 (format nil "Thread ~D" thread))
1051
1052 (defun %thread-state-slot (thread)
1053 (sb-sys:without-gcing
1054 (sb-kernel:make-lisp-obj
1055 (sb-sys:sap-int
1056 (sb-sys:sap-ref-sap (sb-thread::thread-sap-from-id thread)
1057 (* sb-vm::thread-state-slot
1058 sb-vm::n-word-bytes))))))
1059
1060 (defun %thread-state (thread)
1061 (ecase (%thread-state-slot thread)
1062 (0 :running)
1063 (1 :stopping)
1064 (2 :stopped)
1065 (3 :dead)))
1066
1067 (defimplementation thread-status (thread)
1068 (string (%thread-state thread)))
1069
1070 (defimplementation make-lock (&key name)
1071 (sb-thread:make-mutex :name name))
1072
1073 (defimplementation call-with-lock-held (lock function)
1074 (declare (type function function))
1075 (sb-thread:with-mutex (lock) (funcall function)))
1076
1077 (defimplementation current-thread ()
1078 (sb-thread:current-thread-id))
1079
1080 (defimplementation all-threads ()
1081 (let ((pids (sb-sys:without-gcing
1082 (sb-thread::mapcar-threads
1083 (lambda (sap)
1084 (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
1085 sb-vm::thread-pid-slot)))))))
1086 (remove :dead pids :key #'%thread-state)))
1087
1088 (defimplementation interrupt-thread (thread fn)
1089 (sb-thread:interrupt-thread thread fn))
1090
1091 (defimplementation kill-thread (thread)
1092 (sb-thread:terminate-thread thread))
1093
1094 (defimplementation thread-alive-p (thread)
1095 (ignore-errors (sb-thread:interrupt-thread thread (lambda ())) t))
1096
1097 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1098 (defvar *mailboxes* (list))
1099 (declaim (type list *mailboxes*))
1100
1101 (defstruct (mailbox (:conc-name mailbox.))
1102 thread
1103 (mutex (sb-thread:make-mutex))
1104 (waitqueue (sb-thread:make-waitqueue))
1105 (queue '() :type list))
1106
1107 (defun mailbox (thread)
1108 "Return THREAD's mailbox."
1109 (sb-thread:with-mutex (*mailbox-lock*)
1110 (or (find thread *mailboxes* :key #'mailbox.thread)
1111 (let ((mb (make-mailbox :thread thread)))
1112 (push mb *mailboxes*)
1113 mb))))
1114
1115 (defimplementation send (thread message)
1116 (let* ((mbox (mailbox thread))
1117 (mutex (mailbox.mutex mbox)))
1118 (sb-thread:with-mutex (mutex)
1119 (setf (mailbox.queue mbox)
1120 (nconc (mailbox.queue mbox) (list message)))
1121 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1122
1123 (defimplementation receive ()
1124 (let* ((mbox (mailbox (sb-thread:current-thread-id)))
1125 (mutex (mailbox.mutex mbox)))
1126 (sb-thread:with-mutex (mutex)
1127 (loop
1128 (let ((q (mailbox.queue mbox)))
1129 (cond (q (return (pop (mailbox.queue mbox))))
1130 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1131 mutex))))))))
1132
1133 )
1134
1135 (defimplementation quit-lisp ()
1136 #+sb-thread
1137 (dolist (thread (remove (current-thread) (all-threads)))
1138 (ignore-errors (sb-thread:interrupt-thread
1139 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1140 (sb-ext:quit))
1141
1142
1143
1144 ;;Trace implementations
1145 ;;In SBCL, we have:
1146 ;; (trace <name>)
1147 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1148 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1149 ;; <name> can be a normal name or a (setf name)
1150
1151 (defun toggle-trace-aux (fspec &rest args)
1152 (cond ((member fspec (eval '(trace)) :test #'equal)
1153 (eval `(untrace ,fspec))
1154 (format nil "~S is now untraced." fspec))
1155 (t
1156 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1157 (format nil "~S is now traced." fspec))))
1158
1159 (defun process-fspec (fspec)
1160 (cond ((consp fspec)
1161 (ecase (first fspec)
1162 ((:defun :defgeneric) (second fspec))
1163 ((:defmethod) `(method ,@(rest fspec)))
1164 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1165 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1166 (t
1167 fspec)))
1168
1169 (defimplementation toggle-trace (spec)
1170 (ecase (car spec)
1171 ((setf)
1172 (toggle-trace-aux spec))
1173 ((:defmethod)
1174 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1175 ((:defgeneric)
1176 (toggle-trace-aux (second spec) :methods t))
1177 ((:call)
1178 (destructuring-bind (caller callee) (cdr spec)
1179 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))

  ViewVC Help
Powered by ViewVC 1.1.5