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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5