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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.194 - (show annotations)
Wed Mar 26 15:57:37 2008 UTC (6 years ago) by trittweiler
Branch: MAIN
Changes since 1.193: +26 -8 lines
	On SBCL,

	  (block outta
	    (let ((*debugger-hook* #'(lambda (c hook)
				       (declare (ignore hook))
				       (return-from outta 42))))
	      (error "FOO")))

	would kist silently skip over the *DEBUGGER-HOOK*, and pop right
	into SLDB to handle the error. Fix that.

	* swank-sbcl (make-invoke-debugger-hook): New function; returns a
	hook for SB-EXT:*INVOKE-DEBUGGER-HOOK* that checks for the
	presence of *DEBUGGER-HOOK*, and calls that if available.
	(install-debugger-globally): Use it.
	(call-with-debugger-hook): Ditto.

	(getpid): Declaim return type explicitly, to make SBCL shut up about
	being unable to optimize %SAP-ALIEN in ENABLE-SIGIO-ON-FD.

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

  ViewVC Help
Powered by ViewVC 1.1.5