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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.209 - (show annotations)
Wed Aug 6 21:50:37 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.208: +3 -2 lines
(receive-if): Fix typo.
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 (in-package :swank-backend)
15
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17 (require 'sb-bsd-sockets)
18 (require 'sb-introspect)
19 (require 'sb-posix)
20 (require 'sb-cltl2))
21
22 (declaim (optimize (debug 2)
23 (sb-c::insert-step-conditions 0)
24 (sb-c::insert-debug-catch 0)
25 (sb-c::merge-tail-calls 2)))
26
27 (import-from :sb-gray *gray-stream-symbols* :swank-backend)
28
29 ;;; backwards compability tests
30
31 (eval-when (:compile-toplevel :load-toplevel :execute)
32 ;; Generate a form suitable for testing for stepper support (0.9.17)
33 ;; with #+.
34 (defun sbcl-with-new-stepper-p ()
35 (if (find-symbol "ENABLE-STEPPING" "SB-IMPL")
36 '(:and)
37 '(:or)))
38 ;; Ditto for weak hash-tables
39 (defun sbcl-with-weak-hash-tables ()
40 (if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")
41 '(:and)
42 '(:or)))
43 ;; And for xref support (1.0.1)
44 (defun sbcl-with-xref-p ()
45 (if (find-symbol "WHO-CALLS" "SB-INTROSPECT")
46 '(:and)
47 '(:or)))
48 ;; ... for restart-frame support (1.0.2)
49 (defun sbcl-with-restart-frame ()
50 (if (find-symbol "FRAME-HAS-DEBUG-TAG-P" "SB-DEBUG")
51 '(:and)
52 '(:or)))
53 (defun sbcl-with-symbol (name package)
54 (if (find-symbol (string name) (string package))
55 '(:and)
56 '(:or)))
57 )
58
59 ;;; swank-mop
60
61 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
62
63 (defun swank-mop:slot-definition-documentation (slot)
64 (sb-pcl::documentation slot t))
65
66 ;;; Connection info
67
68 (defimplementation lisp-implementation-type-name ()
69 "sbcl")
70
71 ;; Declare return type explicitly to shut up STYLE-WARNINGS about
72 ;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
73 (declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
74 (defimplementation getpid ()
75 (sb-posix:getpid))
76
77 ;;; TCP Server
78
79 (defimplementation preferred-communication-style ()
80 (cond
81 ;; fixme: when SBCL/win32 gains better select() support, remove
82 ;; this.
83 ((member :win32 *features*) nil)
84 ((member :sb-thread *features*) :spawn)
85 (t :fd-handler)))
86
87 (defun resolve-hostname (name)
88 (car (sb-bsd-sockets:host-ent-addresses
89 (sb-bsd-sockets:get-host-by-name name))))
90
91 (defimplementation create-socket (host port)
92 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
93 :type :stream
94 :protocol :tcp)))
95 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
96 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
97 (sb-bsd-sockets:socket-listen socket 5)
98 socket))
99
100 (defimplementation local-port (socket)
101 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
102
103 (defimplementation close-socket (socket)
104 (sb-sys:invalidate-descriptor (socket-fd socket))
105 (sb-bsd-sockets:socket-close socket))
106
107 (defimplementation accept-connection (socket &key
108 external-format
109 buffering timeout)
110 (declare (ignore timeout))
111 (make-socket-io-stream (accept socket)
112 (or external-format :iso-latin-1-unix)
113 (or buffering :full)))
114
115 (defvar *sigio-handlers* '()
116 "List of (key . fn) pairs to be called on SIGIO.")
117
118 (defun sigio-handler (signal code scp)
119 (declare (ignore signal code scp))
120 (mapc (lambda (handler)
121 (funcall (the function (cdr handler))))
122 *sigio-handlers*))
123
124 (defun set-sigio-handler ()
125 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
126 (sigio-handler signal code scp))))
127
128 (defun enable-sigio-on-fd (fd)
129 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
130 (sb-posix::fcntl fd sb-posix::f-setown (getpid))
131 (values))
132
133 (defimplementation add-sigio-handler (socket fn)
134 (set-sigio-handler)
135 (let ((fd (socket-fd socket)))
136 (enable-sigio-on-fd fd)
137 (push (cons fd fn) *sigio-handlers*)))
138
139 (defimplementation remove-sigio-handlers (socket)
140 (let ((fd (socket-fd socket)))
141 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
142 (sb-sys:invalidate-descriptor fd))
143 (close socket))
144
145 (defimplementation add-fd-handler (socket fn)
146 (declare (type function fn))
147 (let ((fd (socket-fd socket)))
148 (sb-sys:add-fd-handler fd :input (lambda (_)
149 _
150 (funcall fn)))))
151
152 (defimplementation remove-fd-handlers (socket)
153 (sb-sys:invalidate-descriptor (socket-fd socket)))
154
155 (defun socket-fd (socket)
156 (etypecase socket
157 (fixnum socket)
158 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
159 (file-stream (sb-sys:fd-stream-fd socket))))
160
161 (defvar *external-format-to-coding-system*
162 '((:iso-8859-1
163 "latin-1" "latin-1-unix" "iso-latin-1-unix"
164 "iso-8859-1" "iso-8859-1-unix")
165 (:utf-8 "utf-8" "utf-8-unix")
166 (:euc-jp "euc-jp" "euc-jp-unix")
167 (:us-ascii "us-ascii" "us-ascii-unix")))
168
169 (defimplementation find-external-format (coding-system)
170 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
171 *external-format-to-coding-system*)))
172
173 (defun make-socket-io-stream (socket external-format buffering)
174 (sb-bsd-sockets:socket-make-stream socket
175 :output t
176 :input t
177 :element-type 'character
178 :buffering buffering
179 #+sb-unicode :external-format
180 #+sb-unicode external-format
181 ))
182
183 (defun accept (socket)
184 "Like socket-accept, but retry on EAGAIN."
185 (loop (handler-case
186 (return (sb-bsd-sockets:socket-accept socket))
187 (sb-bsd-sockets:interrupted-error ()))))
188
189 (defimplementation call-without-interrupts (fn)
190 (declare (type function fn))
191 (sb-sys:without-interrupts (funcall fn)))
192
193
194
195 ;;;; Support for SBCL syntax
196
197 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
198 ;;; containing `!' have special meaning. We have to work long and
199 ;;; hard to be able to read the source. To deal with #! reader
200 ;;; macros, we use a special readtable. The special symbols are
201 ;;; converted by a condition handler.
202
203 (defun feature-in-list-p (feature list)
204 (etypecase feature
205 (symbol (member feature list :test #'eq))
206 (cons (flet ((subfeature-in-list-p (subfeature)
207 (feature-in-list-p subfeature list)))
208 (ecase (first feature)
209 (:or (some #'subfeature-in-list-p (rest feature)))
210 (:and (every #'subfeature-in-list-p (rest feature)))
211 (:not (destructuring-bind (e) (cdr feature)
212 (not (subfeature-in-list-p e)))))))))
213
214 (defun shebang-reader (stream sub-character infix-parameter)
215 (declare (ignore sub-character))
216 (when infix-parameter
217 (error "illegal read syntax: #~D!" infix-parameter))
218 (let ((next-char (read-char stream)))
219 (unless (find next-char "+-")
220 (error "illegal read syntax: #!~C" next-char))
221 ;; When test is not satisfied
222 ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
223 ;; would become "unless test is satisfied"..
224 (when (let* ((*package* (find-package "KEYWORD"))
225 (*read-suppress* nil)
226 (not-p (char= next-char #\-))
227 (feature (read stream)))
228 (if (feature-in-list-p feature *features*)
229 not-p
230 (not not-p)))
231 ;; Read (and discard) a form from input.
232 (let ((*read-suppress* t))
233 (read stream t nil t))))
234 (values))
235
236 (defvar *shebang-readtable*
237 (let ((*readtable* (copy-readtable nil)))
238 (set-dispatch-macro-character #\# #\!
239 (lambda (s c n) (shebang-reader s c n))
240 *readtable*)
241 *readtable*))
242
243 (defun shebang-readtable ()
244 *shebang-readtable*)
245
246 (defun sbcl-package-p (package)
247 (let ((name (package-name package)))
248 (eql (mismatch "SB-" name) 3)))
249
250 (defun sbcl-source-file-p (filename)
251 (when filename
252 (loop for (_ pattern) in (logical-pathname-translations "SYS")
253 thereis (pathname-match-p filename pattern))))
254
255 (defun guess-readtable-for-filename (filename)
256 (if (sbcl-source-file-p filename)
257 (shebang-readtable)
258 *readtable*))
259
260 (defvar *debootstrap-packages* t)
261
262 (defun call-with-debootstrapping (fun)
263 (handler-bind ((sb-int:bootstrap-package-not-found
264 #'sb-int:debootstrap-package))
265 (funcall fun)))
266
267 (defmacro with-debootstrapping (&body body)
268 `(call-with-debootstrapping (lambda () ,@body)))
269
270 (defimplementation call-with-syntax-hooks (fn)
271 (cond ((and *debootstrap-packages*
272 (sbcl-package-p *package*))
273 (with-debootstrapping (funcall fn)))
274 (t
275 (funcall fn))))
276
277 (defimplementation default-readtable-alist ()
278 (let ((readtable (shebang-readtable)))
279 (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
280 collect (cons (package-name p) readtable))))
281
282 ;;; Utilities
283
284 (defimplementation arglist (fname)
285 (sb-introspect:function-arglist fname))
286
287 (defimplementation function-name (f)
288 (check-type f function)
289 (sb-impl::%fun-name f))
290
291 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
292 (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
293 (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
294 (if flags
295 ;; Symbols aren't printed with package qualifiers, but the FLAGS would
296 ;; have to be fully qualified when used inside a declaration. So we
297 ;; strip those as long as there's no better way. (FIXME)
298 `(&any ,@(remove-if-not #'(lambda (qualifier)
299 (find-symbol (symbol-name (first qualifier)) :cl))
300 flags :key #'ensure-list))
301 (call-next-method)))))
302
303 (defvar *buffer-name* nil)
304 (defvar *buffer-offset*)
305 (defvar *buffer-substring* nil)
306
307 (defvar *previous-compiler-condition* nil
308 "Used to detect duplicates.")
309
310 (defun handle-notification-condition (condition)
311 "Handle a condition caused by a compiler warning.
312 This traps all compiler conditions at a lower-level than using
313 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
314 craft our own error messages, which can omit a lot of redundant
315 information."
316 (unless (or (eq condition *previous-compiler-condition*))
317 ;; First resignal warnings, so that outer handlers -- which may choose to
318 ;; muffle this -- get a chance to run.
319 (when (typep condition 'warning)
320 (signal condition))
321 (setq *previous-compiler-condition* condition)
322 (signal-compiler-condition condition (sb-c::find-error-context nil))))
323
324 (defun signal-compiler-condition (condition context)
325 (signal (make-condition
326 'compiler-condition
327 :original-condition condition
328 :severity (etypecase condition
329 (sb-c:compiler-error :error)
330 (sb-ext:compiler-note :note)
331 (style-warning :style-warning)
332 (warning :warning)
333 (error :error))
334 :short-message (brief-compiler-message-for-emacs condition)
335 :references (condition-references (real-condition condition))
336 :message (long-compiler-message-for-emacs condition context)
337 :location (compiler-note-location context))))
338
339 (defun real-condition (condition)
340 "Return the encapsulated condition or CONDITION itself."
341 (typecase condition
342 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
343 (t condition)))
344
345 (defun condition-references (condition)
346 (if (typep condition 'sb-int:reference-condition)
347 (externalize-reference
348 (sb-int:reference-condition-references condition))))
349
350 (defun compiler-note-location (context)
351 (if context
352 (locate-compiler-note
353 (sb-c::compiler-error-context-file-name context)
354 (compiler-source-path context)
355 (sb-c::compiler-error-context-original-source context))
356 (list :error "No error location available")))
357
358 (defun locate-compiler-note (file source-path source)
359 (cond ((and (not (eq file :lisp)) *buffer-name*)
360 ;; Compiling from a buffer
361 (let ((position (+ *buffer-offset*
362 (source-path-string-position
363 source-path *buffer-substring*))))
364 (make-location (list :buffer *buffer-name*)
365 (list :position position))))
366 ((and (pathnamep file) (null *buffer-name*))
367 ;; Compiling from a file
368 (make-location (list :file (namestring file))
369 (list :position
370 (1+ (source-path-file-position
371 source-path file)))))
372 ((and (eq file :lisp) (stringp source))
373 ;; Compiling macro generated code
374 (make-location (list :source-form source)
375 (list :position 1)))
376 (t
377 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
378
379 (defun brief-compiler-message-for-emacs (condition)
380 "Briefly describe a compiler error for Emacs.
381 When Emacs presents the message it already has the source popped up
382 and the source form highlighted. This makes much of the information in
383 the error-context redundant."
384 (let ((sb-int:*print-condition-references* nil))
385 (princ-to-string condition)))
386
387 (defun long-compiler-message-for-emacs (condition error-context)
388 "Describe a compiler error for Emacs including context information."
389 (declare (type (or sb-c::compiler-error-context null) error-context))
390 (multiple-value-bind (enclosing source)
391 (if error-context
392 (values (sb-c::compiler-error-context-enclosing-source error-context)
393 (sb-c::compiler-error-context-source error-context)))
394 (let ((sb-int:*print-condition-references* nil))
395 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
396 enclosing source condition))))
397
398 (defun compiler-source-path (context)
399 "Return the source-path for the current compiler error.
400 Returns NIL if this cannot be determined by examining internal
401 compiler state."
402 (cond ((sb-c::node-p context)
403 (reverse
404 (sb-c::source-path-original-source
405 (sb-c::node-source-path context))))
406 ((sb-c::compiler-error-context-p context)
407 (reverse
408 (sb-c::compiler-error-context-original-source-path context)))))
409
410 (defimplementation call-with-compilation-hooks (function)
411 (declare (type function function))
412 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
413 (sb-c:compiler-error #'handle-notification-condition)
414 (sb-ext:compiler-note #'handle-notification-condition)
415 (warning #'handle-notification-condition))
416 (funcall function)))
417
418 (defun handle-file-compiler-termination (condition)
419 "Handle a condition that caused the file compiler to terminate."
420 (handle-notification-condition
421 (sb-int:encapsulated-condition condition)))
422
423 (defvar *trap-load-time-warnings* nil)
424
425 (defimplementation swank-compile-file (filename load-p external-format)
426 (handler-case
427 (let ((output-file (with-compilation-hooks ()
428 (compile-file filename
429 :external-format external-format))))
430 (when output-file
431 ;; Cache the latest source file for definition-finding.
432 (source-cache-get filename (file-write-date filename))
433 (when load-p
434 (load output-file))))
435 (sb-c:fatal-compiler-error () nil)))
436
437 ;;;; compile-string
438
439 ;;; We copy the string to a temporary file in order to get adequate
440 ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
441 ;;; which the previous approach using
442 ;;; (compile nil `(lambda () ,(read-from-string string)))
443 ;;; did not provide.
444
445 (sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
446 (dest (* sb-alien:c-string)))
447
448 (defun temp-file-name ()
449 "Return a temporary file name to compile strings into."
450 (concatenate 'string (tmpnam nil) ".lisp"))
451
452 (defimplementation swank-compile-string (string &key buffer position directory
453 debug)
454 (declare (ignorable debug))
455 (let ((*buffer-name* buffer)
456 (*buffer-offset* position)
457 (*buffer-substring* string)
458 (filename (temp-file-name))
459 #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
460 (old-min-debug (assoc 'debug (sb-ext:restrict-compiler-policy)))
461 )
462 #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
463 (when debug
464 (sb-ext:restrict-compiler-policy 'debug debug))
465 (flet ((load-it (filename)
466 (when filename (load filename)))
467 (compile-it (cont)
468 (with-compilation-hooks ()
469 (with-compilation-unit
470 (:source-plist (list :emacs-buffer buffer
471 :emacs-directory directory
472 :emacs-string string
473 :emacs-position position))
474 (funcall cont (compile-file filename))))))
475 (with-open-file (s filename :direction :output :if-exists :error)
476 (write-string string s))
477 (unwind-protect
478 (if *trap-load-time-warnings*
479 (compile-it #'load-it)
480 (load-it (compile-it #'identity)))
481 (ignore-errors
482 #+#.(swank-backend::sbcl-with-symbol
483 'restrict-compiler-policy 'sb-ext)
484 (sb-ext:restrict-compiler-policy 'debug (or old-min-debug 0))
485 (delete-file filename)
486 (delete-file (compile-file-pathname filename)))))))
487
488 ;;;; Definitions
489
490 (defvar *debug-definition-finding* nil
491 "When true don't handle errors while looking for definitions.
492 This is useful when debugging the definition-finding code.")
493
494 (defparameter *definition-types*
495 '(:variable defvar
496 :constant defconstant
497 :type deftype
498 :symbol-macro define-symbol-macro
499 :macro defmacro
500 :compiler-macro define-compiler-macro
501 :function defun
502 :generic-function defgeneric
503 :method defmethod
504 :setf-expander define-setf-expander
505 :structure defstruct
506 :condition define-condition
507 :class defclass
508 :method-combination define-method-combination
509 :package defpackage
510 :transform :deftransform
511 :optimizer :defoptimizer
512 :vop :define-vop
513 :source-transform :define-source-transform)
514 "Map SB-INTROSPECT definition type names to Slime-friendly forms")
515
516 (defimplementation find-definitions (name)
517 (loop for type in *definition-types* by #'cddr
518 for locations = (sb-introspect:find-definition-sources-by-name
519 name type)
520 append (loop for source-location in locations collect
521 (make-source-location-specification type name
522 source-location))))
523
524 (defimplementation find-source-location (obj)
525 (flet ((general-type-of (obj)
526 (typecase obj
527 (method :method)
528 (generic-function :generic-function)
529 (function :function)
530 (structure-class :structure-class)
531 (class :class)
532 (method-combination :method-combination)
533 (package :package)
534 (condition :condition)
535 (structure-object :structure-object)
536 (standard-object :standard-object)
537 (t :thing)))
538 (to-string (obj)
539 (typecase obj
540 (package (princ-to-string obj)) ; Packages are possibly named entities.
541 ((or structure-object standard-object condition)
542 (with-output-to-string (s)
543 (print-unreadable-object (obj s :type t :identity t))))
544 (t (princ-to-string obj)))))
545 (handler-case
546 (make-definition-source-location
547 (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))
548 (error (e)
549 (list :error (format nil "Error: ~A" e))))))
550
551
552 (defun make-source-location-specification (type name source-location)
553 (list (list* (getf *definition-types* type)
554 name
555 (sb-introspect::definition-source-description source-location))
556 (if *debug-definition-finding*
557 (make-definition-source-location source-location type name)
558 (handler-case
559 (make-definition-source-location source-location type name)
560 (error (e)
561 (list :error (format nil "Error: ~A" e)))))))
562
563 (defun make-definition-source-location (definition-source type name)
564 (with-struct (sb-introspect::definition-source-
565 pathname form-path character-offset plist
566 file-write-date)
567 definition-source
568 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
569 emacs-string &allow-other-keys)
570 plist
571 (cond
572 (emacs-buffer
573 (let* ((*readtable* (guess-readtable-for-filename emacs-directory))
574 (pos (if form-path
575 (with-debootstrapping
576 (source-path-string-position form-path emacs-string))
577 character-offset))
578 (snippet (string-path-snippet emacs-string form-path pos)))
579 (make-location `(:buffer ,emacs-buffer)
580 `(:position ,(+ pos emacs-position))
581 `(:snippet ,snippet))))
582 ((not pathname)
583 `(:error ,(format nil "Source definition of ~A ~A not found"
584 (string-downcase type) name)))
585 (t
586 (let* ((namestring (namestring (translate-logical-pathname pathname)))
587 (pos (source-file-position namestring file-write-date form-path
588 character-offset))
589 (snippet (source-hint-snippet namestring file-write-date pos)))
590 (make-location `(:file ,namestring)
591 ;; /file positions/ in Common Lisp start
592 ;; from 0, in Emacs they start from 1.
593 `(:position ,(1+ pos))
594 `(:snippet ,snippet))))))))
595
596 (defun string-path-snippet (string form-path position)
597 (if form-path
598 ;; If we have a form-path, use it to derive a more accurate
599 ;; snippet, so that we can point to the individual form rather
600 ;; than just the toplevel form.
601 (multiple-value-bind (data end)
602 (let ((*read-suppress* t))
603 (read-from-string string nil nil :start position))
604 (declare (ignore data))
605 (subseq string position end))
606 string))
607
608 (defun source-file-position (filename write-date form-path character-offset)
609 (let ((source (get-source-code filename write-date))
610 (*readtable* (guess-readtable-for-filename filename)))
611 (with-debootstrapping
612 (if form-path
613 (source-path-string-position form-path source)
614 (or character-offset 0)))))
615
616 (defun source-hint-snippet (filename write-date position)
617 (let ((source (get-source-code filename write-date)))
618 (with-input-from-string (s source)
619 (read-snippet s position))))
620
621 (defun function-source-location (function &optional name)
622 (declare (type function function))
623 (let ((location (sb-introspect:find-definition-source function)))
624 (make-definition-source-location location :function name)))
625
626 (defun safe-function-source-location (fun name)
627 (if *debug-definition-finding*
628 (function-source-location fun name)
629 (handler-case (function-source-location fun name)
630 (error (e)
631 (list :error (format nil "Error: ~A" e))))))
632
633 (defimplementation describe-symbol-for-emacs (symbol)
634 "Return a plist describing SYMBOL.
635 Return NIL if the symbol is unbound."
636 (let ((result '()))
637 (flet ((doc (kind)
638 (or (documentation symbol kind) :not-documented))
639 (maybe-push (property value)
640 (when value
641 (setf result (list* property value result)))))
642 (maybe-push
643 :variable (multiple-value-bind (kind recorded-p)
644 (sb-int:info :variable :kind symbol)
645 (declare (ignore kind))
646 (if (or (boundp symbol) recorded-p)
647 (doc 'variable))))
648 (when (fboundp symbol)
649 (maybe-push
650 (cond ((macro-function symbol) :macro)
651 ((special-operator-p symbol) :special-operator)
652 ((typep (fdefinition symbol) 'generic-function)
653 :generic-function)
654 (t :function))
655 (doc 'function)))
656 (maybe-push
657 :setf (if (or (sb-int:info :setf :inverse symbol)
658 (sb-int:info :setf :expander symbol))
659 (doc 'setf)))
660 (maybe-push
661 :type (if (sb-int:info :type :kind symbol)
662 (doc 'type)))
663 result)))
664
665 (defimplementation describe-definition (symbol type)
666 (case type
667 (:variable
668 (describe symbol))
669 (:function
670 (describe (symbol-function symbol)))
671 (:setf
672 (describe (or (sb-int:info :setf :inverse symbol)
673 (sb-int:info :setf :expander symbol))))
674 (:class
675 (describe (find-class symbol)))
676 (:type
677 (describe (sb-kernel:values-specifier-type symbol)))))
678
679 #+#.(swank-backend::sbcl-with-xref-p)
680 (progn
681 (defmacro defxref (name)
682 `(defimplementation ,name (what)
683 (sanitize-xrefs
684 (mapcar #'source-location-for-xref-data
685 (,(find-symbol (symbol-name name) "SB-INTROSPECT")
686 what)))))
687 (defxref who-calls)
688 (defxref who-binds)
689 (defxref who-sets)
690 (defxref who-references)
691 (defxref who-macroexpands))
692
693 (defun source-location-for-xref-data (xref-data)
694 (let ((name (car xref-data))
695 (source-location (cdr xref-data)))
696 (list name
697 (handler-case (make-definition-source-location source-location
698 'function
699 name)
700 (error (e)
701 (list :error (format nil "Error: ~A" e)))))))
702
703 (defimplementation list-callers (symbol)
704 (let ((fn (fdefinition symbol)))
705 (sanitize-xrefs
706 (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
707
708 (defimplementation list-callees (symbol)
709 (let ((fn (fdefinition symbol)))
710 (sanitize-xrefs
711 (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
712
713 (defun sanitize-xrefs (xrefs)
714 (remove-duplicates
715 (remove-if (lambda (f)
716 (member f (ignored-xref-function-names)))
717 (loop for entry in xrefs
718 for name = (car entry)
719 collect (if (and (consp name)
720 (member (car name)
721 '(sb-pcl::fast-method
722 sb-pcl::slow-method
723 sb-pcl::method)))
724 (cons (cons 'defmethod (cdr name))
725 (cdr entry))
726 entry))
727 :key #'car)
728 :test (lambda (a b)
729 (and (eq (first a) (first b))
730 (equal (second a) (second b))))))
731
732 (defun ignored-xref-function-names ()
733 #-#.(swank-backend::sbcl-with-new-stepper-p)
734 '(nil sb-c::step-form sb-c::step-values)
735 #+#.(swank-backend::sbcl-with-new-stepper-p)
736 '(nil))
737
738 (defun function-dspec (fn)
739 "Describe where the function FN was defined.
740 Return a list of the form (NAME LOCATION)."
741 (let ((name (sb-kernel:%fun-name fn)))
742 (list name (safe-function-source-location fn name))))
743
744 ;;; macroexpansion
745
746 (defimplementation macroexpand-all (form)
747 (let ((sb-walker:*walk-form-expand-macros-p* t))
748 (sb-walker:walk-form form)))
749
750
751 ;;; Debugging
752
753 (defvar *sldb-stack-top*)
754
755 (defun make-invoke-debugger-hook (hook)
756 #'(lambda (condition old-hook)
757 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
758 ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
759 ;; run when it was established locally by a user (i.e. changed meanwhile.)
760 (if *debugger-hook*
761 (funcall *debugger-hook* condition old-hook)
762 (funcall hook condition old-hook))))
763
764 (defimplementation install-debugger-globally (function)
765 (setq *debugger-hook* function)
766 (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
767
768 (defimplementation condition-extras (condition)
769 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
770 ((typep condition 'sb-impl::step-form-condition)
771 `((:show-frame-source 0)))
772 ((typep condition 'sb-int:reference-condition)
773 (let ((refs (sb-int:reference-condition-references condition)))
774 (if refs
775 `((:references ,(externalize-reference refs))))))))
776
777 (defun externalize-reference (ref)
778 (etypecase ref
779 (null nil)
780 (cons (cons (externalize-reference (car ref))
781 (externalize-reference (cdr ref))))
782 ((or string number) ref)
783 (symbol
784 (cond ((eq (symbol-package ref) (symbol-package :test))
785 ref)
786 (t (symbol-name ref))))))
787
788 (defimplementation call-with-debugging-environment (debugger-loop-fn)
789 (declare (type function debugger-loop-fn))
790 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
791 (sb-debug:*stack-top-hint* nil))
792 (handler-bind ((sb-di:debug-condition
793 (lambda (condition)
794 (signal (make-condition
795 'sldb-condition
796 :original-condition condition)))))
797 (funcall debugger-loop-fn))))
798
799 #+#.(swank-backend::sbcl-with-new-stepper-p)
800 (progn
801 (defimplementation activate-stepping (frame)
802 (declare (ignore frame))
803 (sb-impl::enable-stepping))
804 (defimplementation sldb-stepper-condition-p (condition)
805 (typep condition 'sb-ext:step-form-condition))
806 (defimplementation sldb-step-into ()
807 (invoke-restart 'sb-ext:step-into))
808 (defimplementation sldb-step-next ()
809 (invoke-restart 'sb-ext:step-next))
810 (defimplementation sldb-step-out ()
811 (invoke-restart 'sb-ext:step-out)))
812
813 (defimplementation call-with-debugger-hook (hook fun)
814 (let ((*debugger-hook* hook)
815 (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
816 #+#.(swank-backend::sbcl-with-new-stepper-p)
817 (sb-ext:*stepper-hook*
818 (lambda (condition)
819 (typecase condition
820 (sb-ext:step-form-condition
821 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
822 (sb-impl::invoke-debugger condition)))))))
823 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
824 (sb-ext:step-condition #'sb-impl::invoke-stepper))
825 (funcall fun))))
826
827 (defun nth-frame (index)
828 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
829 (i index (1- i)))
830 ((zerop i) frame)))
831
832 (defimplementation compute-backtrace (start end)
833 "Return a list of frames starting with frame number START and
834 continuing to frame number END or, if END is nil, the last frame on the
835 stack."
836 (let ((end (or end most-positive-fixnum)))
837 (loop for f = (nth-frame start) then (sb-di:frame-down f)
838 for i from start below end
839 while f
840 collect f)))
841
842 (defimplementation print-frame (frame stream)
843 (sb-debug::print-frame-call frame stream))
844
845 ;;;; Code-location -> source-location translation
846
847 ;;; If debug-block info is avaibale, we determine the file position of
848 ;;; the source-path for a code-location. If the code was compiled
849 ;;; with C-c C-c, we have to search the position in the source string.
850 ;;; If there's no debug-block info, we return the (less precise)
851 ;;; source-location of the corresponding function.
852
853 (defun code-location-source-location (code-location)
854 (let* ((dsource (sb-di:code-location-debug-source code-location))
855 (plist (sb-c::debug-source-plist dsource)))
856 (if (getf plist :emacs-buffer)
857 (emacs-buffer-source-location code-location plist)
858 #+#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
859 (ecase (sb-di:debug-source-from dsource)
860 (:file (file-source-location code-location))
861 (:lisp (lisp-source-location code-location)))
862 #-#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
863 (if (sb-di:debug-source-namestring dsource)
864 (file-source-location code-location)
865 (lisp-source-location code-location)))))
866
867 ;;; FIXME: The naming policy of source-location functions is a bit
868 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
869 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
870 ;;; which returns the source location for a _code-location_.
871 ;;;
872 ;;; Maybe these should be named code-location-file-source-location,
873 ;;; etc, turned into generic functions, or something. In the very
874 ;;; least the names should indicate the main entry point vs. helper
875 ;;; status.
876
877 (defun file-source-location (code-location)
878 (if (code-location-has-debug-block-info-p code-location)
879 (source-file-source-location code-location)
880 (fallback-source-location code-location)))
881
882 (defun fallback-source-location (code-location)
883 (let ((fun (code-location-debug-fun-fun code-location)))
884 (cond (fun (function-source-location fun))
885 (t (error "Cannot find source location for: ~A " code-location)))))
886
887 (defun lisp-source-location (code-location)
888 (let ((source (prin1-to-string
889 (sb-debug::code-location-source-form code-location 100))))
890 (make-location `(:source-form ,source) '(:position 0))))
891
892 (defun emacs-buffer-source-location (code-location plist)
893 (if (code-location-has-debug-block-info-p code-location)
894 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
895 &allow-other-keys)
896 plist
897 (let* ((pos (string-source-position code-location emacs-string))
898 (snipped (with-input-from-string (s emacs-string)
899 (read-snippet s pos))))
900 (make-location `(:buffer ,emacs-buffer)
901 `(:position ,(+ emacs-position pos))
902 `(:snippet ,snipped))))
903 (fallback-source-location code-location)))
904
905 (defun source-file-source-location (code-location)
906 (let* ((code-date (code-location-debug-source-created code-location))
907 (filename (code-location-debug-source-name code-location))
908 (*readtable* (guess-readtable-for-filename filename))
909 (source-code (get-source-code filename code-date)))
910 (with-debootstrapping
911 (with-input-from-string (s source-code)
912 (let* ((pos (stream-source-position code-location s))
913 (snippet (read-snippet s pos)))
914 (make-location `(:file ,filename)
915 `(:position ,(1+ pos))
916 `(:snippet ,snippet)))))))
917
918 (defun code-location-debug-source-name (code-location)
919 (namestring (truename (#+#.(swank-backend::sbcl-with-symbol
920 'debug-source-name 'sb-di)
921 sb-c::debug-source-name
922 #-#.(swank-backend::sbcl-with-symbol
923 'debug-source-name 'sb-di)
924 sb-c::debug-source-namestring
925 (sb-di::code-location-debug-source code-location)))))
926
927 (defun code-location-debug-source-created (code-location)
928 (sb-c::debug-source-created
929 (sb-di::code-location-debug-source code-location)))
930
931 (defun code-location-debug-fun-fun (code-location)
932 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
933
934 (defun code-location-has-debug-block-info-p (code-location)
935 (handler-case
936 (progn (sb-di:code-location-debug-block code-location)
937 t)
938 (sb-di:no-debug-blocks () nil)))
939
940 (defun stream-source-position (code-location stream)
941 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
942 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
943 (form-number (sb-di::code-location-form-number cloc)))
944 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
945 (let* ((path-table (sb-di::form-number-translations tlf 0))
946 (path (cond ((<= (length path-table) form-number)
947 (warn "inconsistent form-number-translations")
948 (list 0))
949 (t
950 (reverse (cdr (aref path-table form-number)))))))
951 (source-path-source-position path tlf pos-map)))))
952
953 (defun string-source-position (code-location string)
954 (with-input-from-string (s string)
955 (stream-source-position code-location s)))
956
957 ;;; source-path-file-position and friends are in swank-source-path-parser
958
959 (defun safe-source-location-for-emacs (code-location)
960 (if *debug-definition-finding*
961 (code-location-source-location code-location)
962 (handler-case (code-location-source-location code-location)
963 (error (c) (list :error (format nil "~A" c))))))
964
965 (defimplementation frame-source-location-for-emacs (index)
966 (safe-source-location-for-emacs
967 (sb-di:frame-code-location (nth-frame index))))
968
969 (defun frame-debug-vars (frame)
970 "Return a vector of debug-variables in frame."
971 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
972
973 (defun debug-var-value (var frame location)
974 (ecase (sb-di:debug-var-validity var location)
975 (:valid (sb-di:debug-var-value var frame))
976 ((:invalid :unknown) ':<not-available>)))
977
978 (defimplementation frame-locals (index)
979 (let* ((frame (nth-frame index))
980 (loc (sb-di:frame-code-location frame))
981 (vars (frame-debug-vars frame)))
982 (loop for v across vars collect
983 (list :name (sb-di:debug-var-symbol v)
984 :id (sb-di:debug-var-id v)
985 :value (debug-var-value v frame loc)))))
986
987 (defimplementation frame-var-value (frame var)
988 (let* ((frame (nth-frame frame))
989 (dvar (aref (frame-debug-vars frame) var)))
990 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
991
992 (defimplementation frame-catch-tags (index)
993 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
994
995 (defimplementation eval-in-frame (form index)
996 (let ((frame (nth-frame index)))
997 (funcall (the function
998 (sb-di:preprocess-for-eval form
999 (sb-di:frame-code-location frame)))
1000 frame)))
1001
1002 #+#.(swank-backend::sbcl-with-restart-frame)
1003 (progn
1004 (defimplementation return-from-frame (index form)
1005 (let* ((frame (nth-frame index)))
1006 (cond ((sb-debug:frame-has-debug-tag-p frame)
1007 (let ((values (multiple-value-list (eval-in-frame form index))))
1008 (sb-debug:unwind-to-frame-and-call frame
1009 (lambda ()
1010 (values-list values)))))
1011 (t (format nil "Cannot return from frame: ~S" frame)))))
1012
1013 (defimplementation restart-frame (index)
1014 (let* ((frame (nth-frame index)))
1015 (cond ((sb-debug:frame-has-debug-tag-p frame)
1016 (let* ((call-list (sb-debug::frame-call-as-list frame))
1017 (fun (fdefinition (car call-list)))
1018 (thunk (lambda ()
1019 ;; Ensure that the thunk gets tail-call-optimized
1020 (declare (optimize (debug 1)))
1021 (apply fun (cdr call-list)))))
1022 (sb-debug:unwind-to-frame-and-call frame thunk)))
1023 (t (format nil "Cannot restart frame: ~S" frame))))))
1024
1025 ;; FIXME: this implementation doesn't unwind the stack before
1026 ;; re-invoking the function, but it's better than no implementation at
1027 ;; all.
1028 #-#.(swank-backend::sbcl-with-restart-frame)
1029 (progn
1030 (defun sb-debug-catch-tag-p (tag)
1031 (and (symbolp tag)
1032 (not (symbol-package tag))
1033 (string= tag :sb-debug-catch-tag)))
1034
1035 (defimplementation return-from-frame (index form)
1036 (let* ((frame (nth-frame index))
1037 (probe (assoc-if #'sb-debug-catch-tag-p
1038 (sb-di::frame-catches frame))))
1039 (cond (probe (throw (car probe) (eval-in-frame form index)))
1040 (t (format nil "Cannot return from frame: ~S" frame)))))
1041
1042 (defimplementation restart-frame (index)
1043 (let ((frame (nth-frame index)))
1044 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1045
1046 ;;;;; reference-conditions
1047
1048 (defimplementation format-sldb-condition (condition)
1049 (let ((sb-int:*print-condition-references* nil))
1050 (princ-to-string condition)))
1051
1052
1053 ;;;; Profiling
1054
1055 (defimplementation profile (fname)
1056 (when fname (eval `(sb-profile:profile ,fname))))
1057
1058 (defimplementation unprofile (fname)
1059 (when fname (eval `(sb-profile:unprofile ,fname))))
1060
1061 (defimplementation unprofile-all ()
1062 (sb-profile:unprofile)
1063 "All functions unprofiled.")
1064
1065 (defimplementation profile-report ()
1066 (sb-profile:report))
1067
1068 (defimplementation profile-reset ()
1069 (sb-profile:reset)
1070 "Reset profiling counters.")
1071
1072 (defimplementation profiled-functions ()
1073 (sb-profile:profile))
1074
1075 (defimplementation profile-package (package callers methods)
1076 (declare (ignore callers methods))
1077 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1078
1079
1080 ;;;; Inspector
1081
1082 (defmethod emacs-inspect ((o t))
1083 (cond ((sb-di::indirect-value-cell-p o)
1084 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1085 (t
1086 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1087 (list* (format nil "~a~%" text)
1088 (if label
1089 (loop for (l . v) in parts
1090 append (label-value-line l v))
1091 (loop for value in parts for i from 0
1092 append (label-value-line i value))))))))
1093
1094 (defmethod emacs-inspect ((o function))
1095 (let ((header (sb-kernel:widetag-of o)))
1096 (cond ((= header sb-vm:simple-fun-header-widetag)
1097 (label-value-line*
1098 (:name (sb-kernel:%simple-fun-name o))
1099 (:arglist (sb-kernel:%simple-fun-arglist o))
1100 (:self (sb-kernel:%simple-fun-self o))
1101 (:next (sb-kernel:%simple-fun-next o))
1102 (:type (sb-kernel:%simple-fun-type o))
1103 (:code (sb-kernel:fun-code-header o))))
1104 ((= header sb-vm:closure-header-widetag)
1105 (append
1106 (label-value-line :function (sb-kernel:%closure-fun o))
1107 `("Closed over values:" (:newline))
1108 (loop for i below (1- (sb-kernel:get-closure-length o))
1109 append (label-value-line
1110 i (sb-kernel:%closure-index-ref o i)))))
1111 (t (call-next-method o)))))
1112
1113 (defmethod emacs-inspect ((o sb-kernel:code-component))
1114 (append
1115 (label-value-line*
1116 (:code-size (sb-kernel:%code-code-size o))
1117 (:entry-points (sb-kernel:%code-entry-points o))
1118 (:debug-info (sb-kernel:%code-debug-info o))
1119 (:trace-table-offset (sb-kernel:code-header-ref
1120 o sb-vm:code-trace-table-offset-slot)))
1121 `("Constants:" (:newline))
1122 (loop for i from sb-vm:code-constants-offset
1123 below (sb-kernel:get-header-data o)
1124 append (label-value-line i (sb-kernel:code-header-ref o i)))
1125 `("Code:" (:newline)
1126 , (with-output-to-string (s)
1127 (cond ((sb-kernel:%code-debug-info o)
1128 (sb-disassem:disassemble-code-component o :stream s))
1129 (t
1130 (sb-disassem:disassemble-memory
1131 (sb-disassem::align
1132 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1133 sb-vm:lowtag-mask)
1134 (* sb-vm:code-constants-offset
1135 sb-vm:n-word-bytes))
1136 (ash 1 sb-vm:n-lowtag-bits))
1137 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1138 :stream s)))))))
1139
1140 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1141 (label-value-line*
1142 (:value (sb-ext:weak-pointer-value o))))
1143
1144 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1145 (label-value-line*
1146 (:name (sb-kernel:fdefn-name o))
1147 (:function (sb-kernel:fdefn-fun o))))
1148
1149 (defmethod emacs-inspect :around ((o generic-function))
1150 (append
1151 (call-next-method)
1152 (label-value-line*
1153 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1154 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1155 )))
1156
1157
1158 ;;;; Multiprocessing
1159
1160 #+(and sb-thread
1161 #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1162 (progn
1163 (defvar *thread-id-counter* 0)
1164
1165 (defvar *thread-id-counter-lock*
1166 (sb-thread:make-mutex :name "thread id counter lock"))
1167
1168 (defun next-thread-id ()
1169 (sb-thread:with-mutex (*thread-id-counter-lock*)
1170 (incf *thread-id-counter*)))
1171
1172 (defparameter *thread-id-map* (make-hash-table))
1173
1174 ;; This should be a thread -> id map but as weak keys are not
1175 ;; supported it is id -> map instead.
1176 (defvar *thread-id-map-lock*
1177 (sb-thread:make-mutex :name "thread id map lock"))
1178
1179 (defimplementation spawn (fn &key name)
1180 (sb-thread:make-thread fn :name name))
1181
1182 (defimplementation thread-id (thread)
1183 (block thread-id
1184 (sb-thread:with-mutex (*thread-id-map-lock*)
1185 (loop for id being the hash-key in *thread-id-map*
1186 using (hash-value thread-pointer)
1187 do
1188 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1189 (cond ((null maybe-thread)
1190 ;; the value is gc'd, remove it manually
1191 (remhash id *thread-id-map*))
1192 ((eq thread maybe-thread)
1193 (return-from thread-id id)))))
1194 ;; lazy numbering
1195 (let ((id (next-thread-id)))
1196 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1197 id))))
1198
1199 (defimplementation find-thread (id)
1200 (sb-thread:with-mutex (*thread-id-map-lock*)
1201 (let ((thread-pointer (gethash id *thread-id-map*)))
1202 (if thread-pointer
1203 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1204 (if maybe-thread
1205 maybe-thread
1206 ;; the value is gc'd, remove it manually
1207 (progn
1208 (remhash id *thread-id-map*)
1209 nil)))
1210 nil))))
1211
1212 (defimplementation thread-name (thread)
1213 ;; sometimes the name is not a string (e.g. NIL)
1214 (princ-to-string (sb-thread:thread-name thread)))
1215
1216 (defimplementation thread-status (thread)
1217 (if (sb-thread:thread-alive-p thread)
1218 "RUNNING"
1219 "STOPPED"))
1220 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1221 (progn
1222 (defparameter *thread-description-map*
1223 (make-weak-key-hash-table))
1224
1225 (defvar *thread-descr-map-lock*
1226 (sb-thread:make-mutex :name "thread description map lock"))
1227
1228 (defimplementation thread-description (thread)
1229 (sb-thread:with-mutex (*thread-descr-map-lock*)
1230 (or (gethash thread *thread-description-map*)
1231 (short-backtrace thread 6 10))))
1232
1233 (defimplementation set-thread-description (thread description)
1234 (sb-thread:with-mutex (*thread-descr-map-lock*)
1235 (setf (gethash thread *thread-description-map*) description)))
1236
1237 (defun short-backtrace (thread start count)
1238 (let ((self (current-thread))
1239 (tag (get-internal-real-time)))
1240 (sb-thread:interrupt-thread
1241 thread
1242 (lambda ()
1243 (let* ((frames (nthcdr start (sb-debug:backtrace-as-list count))))
1244 (send self (cons tag frames)))))
1245 (handler-case
1246 (sb-ext:with-timeout 0.1
1247 (let ((frames (cdr (receive-if (lambda (msg)
1248 (eq (car msg) tag)))))
1249 (*print-pretty* nil))
1250 (format nil "~{~a~^ <- ~}" (mapcar #'car frames))))
1251 (sb-ext:timeout () ""))))
1252
1253 )
1254
1255 (defimplementation make-lock (&key name)
1256 (sb-thread:make-mutex :name name))
1257
1258 (defimplementation call-with-lock-held (lock function)
1259 (declare (type function function))
1260 (sb-thread:with-recursive-lock (lock) (funcall function)))
1261
1262 (defimplementation current-thread ()
1263 sb-thread:*current-thread*)
1264
1265 (defimplementation all-threads ()
1266 (sb-thread:list-all-threads))
1267
1268 (defimplementation interrupt-thread (thread fn)
1269 (sb-thread:interrupt-thread thread fn))
1270
1271 (defimplementation kill-thread (thread)
1272 (sb-thread:terminate-thread thread))
1273
1274 (defimplementation thread-alive-p (thread)
1275 (sb-thread:thread-alive-p thread))
1276
1277 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1278 (defvar *mailboxes* (list))
1279 (declaim (type list *mailboxes*))
1280
1281 (defstruct (mailbox (:conc-name mailbox.))
1282 thread
1283 (mutex (sb-thread:make-mutex))
1284 (waitqueue (sb-thread:make-waitqueue))
1285 (queue '() :type list))
1286
1287 (defun mailbox (thread)
1288 "Return THREAD's mailbox."
1289 (sb-thread:with-mutex (*mailbox-lock*)
1290 (or (find thread *mailboxes* :key #'mailbox.thread)
1291 (let ((mb (make-mailbox :thread thread)))
1292 (push mb *mailboxes*)
1293 mb))))
1294
1295 (defimplementation send (thread message)
1296 (let* ((mbox (mailbox thread))
1297 (mutex (mailbox.mutex mbox)))
1298 (sb-thread:with-mutex (mutex)
1299 (setf (mailbox.queue mbox)
1300 (nconc (mailbox.queue mbox) (list message)))
1301 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1302
1303 (defimplementation receive ()
1304 (receive-if (constantly t)))
1305
1306 (defimplementation receive-if (test)
1307 (let* ((mbox (mailbox (current-thread)))
1308 (mutex (mailbox.mutex mbox)))
1309 (loop
1310 (check-slime-interrupts)
1311 (sb-thread:with-mutex (mutex)
1312 (let* ((q (mailbox.queue mbox))
1313 (tail (member-if test q)))
1314 (when tail
1315 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1316 (return (car tail))))
1317 (handler-case (sb-ext:with-timeout 0.2
1318 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1319 mutex))
1320 (sb-ext:timeout ()))))))
1321
1322 ;; Auto-flush streams
1323
1324 (defvar *auto-flush-interval* 0.15
1325 "How often to flush interactive streams. This value is passed
1326 directly to cl:sleep.")
1327
1328 (defvar *auto-flush-lock* (sb-thread:make-mutex :name "auto flush"))
1329
1330 (defvar *auto-flush-thread* nil)
1331
1332 (defvar *auto-flush-streams* '())
1333
1334 (defimplementation make-stream-interactive (stream)
1335 (sb-thread:with-mutex (*auto-flush-lock*)
1336 (pushnew stream *auto-flush-streams*)
1337 (unless *auto-flush-thread*
1338 (setq *auto-flush-thread*
1339 (sb-thread:make-thread #'flush-streams
1340 :name "auto-flush-thread")))))
1341
1342 (defun flush-streams ()
1343 (loop
1344 (sb-thread:with-mutex (*auto-flush-lock*)
1345 (setq *auto-flush-streams*
1346 (remove-if (lambda (x)
1347 (not (and (open-stream-p x)
1348 (output-stream-p x))))
1349 *auto-flush-streams*))
1350 (mapc #'finish-output *auto-flush-streams*))
1351 (sleep *auto-flush-interval*)))
1352
1353 )
1354
1355 (defimplementation quit-lisp ()
1356 #+sb-thread
1357 (dolist (thread (remove (current-thread) (all-threads)))
1358 (ignore-errors (sb-thread:interrupt-thread
1359 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1360 (sb-ext:quit))
1361
1362
1363
1364 ;;Trace implementations
1365 ;;In SBCL, we have:
1366 ;; (trace <name>)
1367 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1368 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1369 ;; <name> can be a normal name or a (setf name)
1370
1371 (defun toggle-trace-aux (fspec &rest args)
1372 (cond ((member fspec (eval '(trace)) :test #'equal)
1373 (eval `(untrace ,fspec))
1374 (format nil "~S is now untraced." fspec))
1375 (t
1376 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1377 (format nil "~S is now traced." fspec))))
1378
1379 (defun process-fspec (fspec)
1380 (cond ((consp fspec)
1381 (ecase (first fspec)
1382 ((:defun :defgeneric) (second fspec))
1383 ((:defmethod) `(method ,@(rest fspec)))
1384 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1385 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1386 (t
1387 fspec)))
1388
1389 (defimplementation toggle-trace (spec)
1390 (ecase (car spec)
1391 ((setf)
1392 (toggle-trace-aux spec))
1393 ((:defmethod)
1394 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1395 ((:defgeneric)
1396 (toggle-trace-aux (second spec) :methods t))
1397 ((:call)
1398 (destructuring-bind (caller callee) (cdr spec)
1399 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1400
1401 ;;; Weak datastructures
1402
1403 (defimplementation make-weak-key-hash-table (&rest args)
1404 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1405 (apply #'make-hash-table :weakness :key args)
1406 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1407 (apply #'make-hash-table args))
1408
1409 (defimplementation make-weak-value-hash-table (&rest args)
1410 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1411 (apply #'make-hash-table :weakness :value args)
1412 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1413 (apply #'make-hash-table args))
1414
1415 (defimplementation hash-table-weakness (hashtable)
1416 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1417 (sb-ext:hash-table-weakness hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5