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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.204 - (show annotations)
Mon Aug 4 21:38:07 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.203: +2 -4 lines
* swank-gray.lisp (slime-output-stream): Undo last change.
Make force-output and finish-output do the same.
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 (let ((context (sb-c::find-error-context nil)))
317 (unless (eq condition *previous-compiler-condition*)
318 (setq *previous-compiler-condition* condition)
319 (signal-compiler-condition condition context))))
320
321 (defun signal-compiler-condition (condition context)
322 (signal (make-condition
323 'compiler-condition
324 :original-condition condition
325 :severity (etypecase condition
326 (sb-c:compiler-error :error)
327 (sb-ext:compiler-note :note)
328 (style-warning :style-warning)
329 (warning :warning)
330 (error :error))
331 :short-message (brief-compiler-message-for-emacs condition)
332 :references (condition-references (real-condition condition))
333 :message (long-compiler-message-for-emacs condition context)
334 :location (compiler-note-location context))))
335
336 (defun real-condition (condition)
337 "Return the encapsulated condition or CONDITION itself."
338 (typecase condition
339 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
340 (t condition)))
341
342 (defun condition-references (condition)
343 (if (typep condition 'sb-int:reference-condition)
344 (externalize-reference
345 (sb-int:reference-condition-references condition))))
346
347 (defun compiler-note-location (context)
348 (if context
349 (locate-compiler-note
350 (sb-c::compiler-error-context-file-name context)
351 (compiler-source-path context)
352 (sb-c::compiler-error-context-original-source context))
353 (list :error "No error location available")))
354
355 (defun locate-compiler-note (file source-path source)
356 (cond ((and (not (eq file :lisp)) *buffer-name*)
357 ;; Compiling from a buffer
358 (let ((position (+ *buffer-offset*
359 (source-path-string-position
360 source-path *buffer-substring*))))
361 (make-location (list :buffer *buffer-name*)
362 (list :position position))))
363 ((and (pathnamep file) (null *buffer-name*))
364 ;; Compiling from a file
365 (make-location (list :file (namestring file))
366 (list :position
367 (1+ (source-path-file-position
368 source-path file)))))
369 ((and (eq file :lisp) (stringp source))
370 ;; Compiling macro generated code
371 (make-location (list :source-form source)
372 (list :position 1)))
373 (t
374 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
375
376 (defun brief-compiler-message-for-emacs (condition)
377 "Briefly describe a compiler error for Emacs.
378 When Emacs presents the message it already has the source popped up
379 and the source form highlighted. This makes much of the information in
380 the error-context redundant."
381 (let ((sb-int:*print-condition-references* nil))
382 (princ-to-string condition)))
383
384 (defun long-compiler-message-for-emacs (condition error-context)
385 "Describe a compiler error for Emacs including context information."
386 (declare (type (or sb-c::compiler-error-context null) error-context))
387 (multiple-value-bind (enclosing source)
388 (if error-context
389 (values (sb-c::compiler-error-context-enclosing-source error-context)
390 (sb-c::compiler-error-context-source error-context)))
391 (let ((sb-int:*print-condition-references* nil))
392 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
393 enclosing source condition))))
394
395 (defun compiler-source-path (context)
396 "Return the source-path for the current compiler error.
397 Returns NIL if this cannot be determined by examining internal
398 compiler state."
399 (cond ((sb-c::node-p context)
400 (reverse
401 (sb-c::source-path-original-source
402 (sb-c::node-source-path context))))
403 ((sb-c::compiler-error-context-p context)
404 (reverse
405 (sb-c::compiler-error-context-original-source-path context)))))
406
407 (defimplementation call-with-compilation-hooks (function)
408 (declare (type function function))
409 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
410 (sb-c:compiler-error #'handle-notification-condition)
411 (sb-ext:compiler-note #'handle-notification-condition)
412 (style-warning #'handle-notification-condition)
413 (warning #'handle-notification-condition))
414 (funcall function)))
415
416 (defun handle-file-compiler-termination (condition)
417 "Handle a condition that caused the file compiler to terminate."
418 (handle-notification-condition
419 (sb-int:encapsulated-condition condition)))
420
421 (defvar *trap-load-time-warnings* nil)
422
423 (defimplementation swank-compile-file (filename load-p external-format)
424 (handler-case
425 (let ((output-file (with-compilation-hooks ()
426 (compile-file filename
427 :external-format external-format))))
428 (when output-file
429 ;; Cache the latest source file for definition-finding.
430 (source-cache-get filename (file-write-date filename))
431 (when load-p
432 (load output-file))))
433 (sb-c:fatal-compiler-error () nil)))
434
435 ;;;; compile-string
436
437 ;;; We copy the string to a temporary file in order to get adequate
438 ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
439 ;;; which the previous approach using
440 ;;; (compile nil `(lambda () ,(read-from-string string)))
441 ;;; did not provide.
442
443 (sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
444 (dest (* sb-alien:c-string)))
445
446 (defun temp-file-name ()
447 "Return a temporary file name to compile strings into."
448 (concatenate 'string (tmpnam nil) ".lisp"))
449
450 (defimplementation swank-compile-string (string &key buffer position directory
451 debug)
452 (let ((*buffer-name* buffer)
453 (*buffer-offset* position)
454 (*buffer-substring* string)
455 (filename (temp-file-name))
456 #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
457 (old-min-debug (assoc 'debug (sb-ext:restrict-compiler-policy)))
458 )
459 #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
460 (when debug
461 (sb-ext:restrict-compiler-policy 'debug debug))
462 (flet ((load-it (filename)
463 (when filename (load filename)))
464 (compile-it (cont)
465 (with-compilation-hooks ()
466 (with-compilation-unit
467 (:source-plist (list :emacs-buffer buffer
468 :emacs-directory directory
469 :emacs-string string
470 :emacs-position position))
471 (funcall cont (compile-file filename))))))
472 (with-open-file (s filename :direction :output :if-exists :error)
473 (write-string string s))
474 (unwind-protect
475 (if *trap-load-time-warnings*
476 (compile-it #'load-it)
477 (load-it (compile-it #'identity)))
478 (ignore-errors
479 #+#.(swank-backend::sbcl-with-symbol
480 'restrict-compiler-policy 'sb-ext)
481 (sb-ext:restrict-compiler-policy 'debug (or old-min-debug 0))
482 (delete-file filename)
483 (delete-file (compile-file-pathname filename)))))))
484
485 ;;;; Definitions
486
487 (defvar *debug-definition-finding* nil
488 "When true don't handle errors while looking for definitions.
489 This is useful when debugging the definition-finding code.")
490
491 (defparameter *definition-types*
492 '(:variable defvar
493 :constant defconstant
494 :type deftype
495 :symbol-macro define-symbol-macro
496 :macro defmacro
497 :compiler-macro define-compiler-macro
498 :function defun
499 :generic-function defgeneric
500 :method defmethod
501 :setf-expander define-setf-expander
502 :structure defstruct
503 :condition define-condition
504 :class defclass
505 :method-combination define-method-combination
506 :package defpackage
507 :transform :deftransform
508 :optimizer :defoptimizer
509 :vop :define-vop
510 :source-transform :define-source-transform)
511 "Map SB-INTROSPECT definition type names to Slime-friendly forms")
512
513 (defimplementation find-definitions (name)
514 (loop for type in *definition-types* by #'cddr
515 for locations = (sb-introspect:find-definition-sources-by-name
516 name type)
517 append (loop for source-location in locations collect
518 (make-source-location-specification type name
519 source-location))))
520
521 (defimplementation find-source-location (obj)
522 (flet ((general-type-of (obj)
523 (typecase obj
524 (method :method)
525 (generic-function :generic-function)
526 (function :function)
527 (structure-class :structure-class)
528 (class :class)
529 (method-combination :method-combination)
530 (package :package)
531 (condition :condition)
532 (structure-object :structure-object)
533 (standard-object :standard-object)
534 (t :thing)))
535 (to-string (obj)
536 (typecase obj
537 (package (princ-to-string obj)) ; Packages are possibly named entities.
538 ((or structure-object standard-object condition)
539 (with-output-to-string (s)
540 (print-unreadable-object (obj s :type t :identity t))))
541 (t (princ-to-string obj)))))
542 (handler-case
543 (make-definition-source-location
544 (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))
545 (error (e)
546 (list :error (format nil "Error: ~A" e))))))
547
548
549 (defun make-source-location-specification (type name source-location)
550 (list (list* (getf *definition-types* type)
551 name
552 (sb-introspect::definition-source-description source-location))
553 (if *debug-definition-finding*
554 (make-definition-source-location source-location type name)
555 (handler-case
556 (make-definition-source-location source-location type name)
557 (error (e)
558 (list :error (format nil "Error: ~A" e)))))))
559
560 (defun make-definition-source-location (definition-source type name)
561 (with-struct (sb-introspect::definition-source-
562 pathname form-path character-offset plist
563 file-write-date)
564 definition-source
565 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
566 emacs-string &allow-other-keys)
567 plist
568 (cond
569 (emacs-buffer
570 (let* ((*readtable* (guess-readtable-for-filename emacs-directory))
571 (pos (if form-path
572 (with-debootstrapping
573 (source-path-string-position form-path emacs-string))
574 character-offset))
575 (snippet (string-path-snippet emacs-string form-path pos)))
576 (make-location `(:buffer ,emacs-buffer)
577 `(:position ,(+ pos emacs-position))
578 `(:snippet ,snippet))))
579 ((not pathname)
580 `(:error ,(format nil "Source definition of ~A ~A not found"
581 (string-downcase type) name)))
582 (t
583 (let* ((namestring (namestring (translate-logical-pathname pathname)))
584 (pos (source-file-position namestring file-write-date form-path
585 character-offset))
586 (snippet (source-hint-snippet namestring file-write-date pos)))
587 (make-location `(:file ,namestring)
588 ;; /file positions/ in Common Lisp start
589 ;; from 0, in Emacs they start from 1.
590 `(:position ,(1+ pos))
591 `(:snippet ,snippet))))))))
592
593 (defun string-path-snippet (string form-path position)
594 (if form-path
595 ;; If we have a form-path, use it to derive a more accurate
596 ;; snippet, so that we can point to the individual form rather
597 ;; than just the toplevel form.
598 (multiple-value-bind (data end)
599 (let ((*read-suppress* t))
600 (read-from-string string nil nil :start position))
601 (declare (ignore data))
602 (subseq string position end))
603 string))
604
605 (defun source-file-position (filename write-date form-path character-offset)
606 (let ((source (get-source-code filename write-date))
607 (*readtable* (guess-readtable-for-filename filename)))
608 (with-debootstrapping
609 (if form-path
610 (source-path-string-position form-path source)
611 (or character-offset 0)))))
612
613 (defun source-hint-snippet (filename write-date position)
614 (let ((source (get-source-code filename write-date)))
615 (with-input-from-string (s source)
616 (read-snippet s position))))
617
618 (defun function-source-location (function &optional name)
619 (declare (type function function))
620 (let ((location (sb-introspect:find-definition-source function)))
621 (make-definition-source-location location :function name)))
622
623 (defun safe-function-source-location (fun name)
624 (if *debug-definition-finding*
625 (function-source-location fun name)
626 (handler-case (function-source-location fun name)
627 (error (e)
628 (list :error (format nil "Error: ~A" e))))))
629
630 (defimplementation describe-symbol-for-emacs (symbol)
631 "Return a plist describing SYMBOL.
632 Return NIL if the symbol is unbound."
633 (let ((result '()))
634 (flet ((doc (kind)
635 (or (documentation symbol kind) :not-documented))
636 (maybe-push (property value)
637 (when value
638 (setf result (list* property value result)))))
639 (maybe-push
640 :variable (multiple-value-bind (kind recorded-p)
641 (sb-int:info :variable :kind symbol)
642 (declare (ignore kind))
643 (if (or (boundp symbol) recorded-p)
644 (doc 'variable))))
645 (when (fboundp symbol)
646 (maybe-push
647 (cond ((macro-function symbol) :macro)
648 ((special-operator-p symbol) :special-operator)
649 ((typep (fdefinition symbol) 'generic-function)
650 :generic-function)
651 (t :function))
652 (doc 'function)))
653 (maybe-push
654 :setf (if (or (sb-int:info :setf :inverse symbol)
655 (sb-int:info :setf :expander symbol))
656 (doc 'setf)))
657 (maybe-push
658 :type (if (sb-int:info :type :kind symbol)
659 (doc 'type)))
660 result)))
661
662 (defimplementation describe-definition (symbol type)
663 (case type
664 (:variable
665 (describe symbol))
666 (:function
667 (describe (symbol-function symbol)))
668 (:setf
669 (describe (or (sb-int:info :setf :inverse symbol)
670 (sb-int:info :setf :expander symbol))))
671 (:class
672 (describe (find-class symbol)))
673 (:type
674 (describe (sb-kernel:values-specifier-type symbol)))))
675
676 #+#.(swank-backend::sbcl-with-xref-p)
677 (progn
678 (defmacro defxref (name)
679 `(defimplementation ,name (what)
680 (sanitize-xrefs
681 (mapcar #'source-location-for-xref-data
682 (,(find-symbol (symbol-name name) "SB-INTROSPECT")
683 what)))))
684 (defxref who-calls)
685 (defxref who-binds)
686 (defxref who-sets)
687 (defxref who-references)
688 (defxref who-macroexpands))
689
690 (defun source-location-for-xref-data (xref-data)
691 (let ((name (car xref-data))
692 (source-location (cdr xref-data)))
693 (list name
694 (handler-case (make-definition-source-location source-location
695 'function
696 name)
697 (error (e)
698 (list :error (format nil "Error: ~A" e)))))))
699
700 (defimplementation list-callers (symbol)
701 (let ((fn (fdefinition symbol)))
702 (sanitize-xrefs
703 (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
704
705 (defimplementation list-callees (symbol)
706 (let ((fn (fdefinition symbol)))
707 (sanitize-xrefs
708 (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
709
710 (defun sanitize-xrefs (xrefs)
711 (remove-duplicates
712 (remove-if (lambda (f)
713 (member f (ignored-xref-function-names)))
714 (loop for entry in xrefs
715 for name = (car entry)
716 collect (if (and (consp name)
717 (member (car name)
718 '(sb-pcl::fast-method
719 sb-pcl::slow-method
720 sb-pcl::method)))
721 (cons (cons 'defmethod (cdr name))
722 (cdr entry))
723 entry))
724 :key #'car)
725 :test (lambda (a b)
726 (and (eq (first a) (first b))
727 (equal (second a) (second b))))))
728
729 (defun ignored-xref-function-names ()
730 #-#.(swank-backend::sbcl-with-new-stepper-p)
731 '(nil sb-c::step-form sb-c::step-values)
732 #+#.(swank-backend::sbcl-with-new-stepper-p)
733 '(nil))
734
735 (defun function-dspec (fn)
736 "Describe where the function FN was defined.
737 Return a list of the form (NAME LOCATION)."
738 (let ((name (sb-kernel:%fun-name fn)))
739 (list name (safe-function-source-location fn name))))
740
741 ;;; macroexpansion
742
743 (defimplementation macroexpand-all (form)
744 (let ((sb-walker:*walk-form-expand-macros-p* t))
745 (sb-walker:walk-form form)))
746
747
748 ;;; Debugging
749
750 (defvar *sldb-stack-top*)
751
752 (defun make-invoke-debugger-hook (hook)
753 #'(lambda (condition old-hook)
754 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
755 ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
756 ;; run when it was established locally by a user (i.e. changed meanwhile.)
757 (if *debugger-hook*
758 (funcall *debugger-hook* condition old-hook)
759 (funcall hook condition old-hook))))
760
761 (defimplementation install-debugger-globally (function)
762 (setq *debugger-hook* function)
763 (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
764
765 (defimplementation condition-extras (condition)
766 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
767 ((typep condition 'sb-impl::step-form-condition)
768 `((:show-frame-source 0)))
769 ((typep condition 'sb-int:reference-condition)
770 (let ((refs (sb-int:reference-condition-references condition)))
771 (if refs
772 `((:references ,(externalize-reference refs))))))))
773
774 (defun externalize-reference (ref)
775 (etypecase ref
776 (null nil)
777 (cons (cons (externalize-reference (car ref))
778 (externalize-reference (cdr ref))))
779 ((or string number) ref)
780 (symbol
781 (cond ((eq (symbol-package ref) (symbol-package :test))
782 ref)
783 (t (symbol-name ref))))))
784
785 (defimplementation call-with-debugging-environment (debugger-loop-fn)
786 (declare (type function debugger-loop-fn))
787 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
788 (sb-debug:*stack-top-hint* nil))
789 (handler-bind ((sb-di:debug-condition
790 (lambda (condition)
791 (signal (make-condition
792 'sldb-condition
793 :original-condition condition)))))
794 (funcall debugger-loop-fn))))
795
796 #+#.(swank-backend::sbcl-with-new-stepper-p)
797 (progn
798 (defimplementation activate-stepping (frame)
799 (declare (ignore frame))
800 (sb-impl::enable-stepping))
801 (defimplementation sldb-stepper-condition-p (condition)
802 (typep condition 'sb-ext:step-form-condition))
803 (defimplementation sldb-step-into ()
804 (invoke-restart 'sb-ext:step-into))
805 (defimplementation sldb-step-next ()
806 (invoke-restart 'sb-ext:step-next))
807 (defimplementation sldb-step-out ()
808 (invoke-restart 'sb-ext:step-out)))
809
810 (defimplementation call-with-debugger-hook (hook fun)
811 (let ((*debugger-hook* hook)
812 (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
813 #+#.(swank-backend::sbcl-with-new-stepper-p)
814 (sb-ext:*stepper-hook*
815 (lambda (condition)
816 (typecase condition
817 (sb-ext:step-form-condition
818 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
819 (sb-impl::invoke-debugger condition)))))))
820 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
821 (sb-ext:step-condition #'sb-impl::invoke-stepper))
822 (funcall fun))))
823
824 (defun nth-frame (index)
825 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
826 (i index (1- i)))
827 ((zerop i) frame)))
828
829 (defimplementation compute-backtrace (start end)
830 "Return a list of frames starting with frame number START and
831 continuing to frame number END or, if END is nil, the last frame on the
832 stack."
833 (let ((end (or end most-positive-fixnum)))
834 (loop for f = (nth-frame start) then (sb-di:frame-down f)
835 for i from start below end
836 while f
837 collect f)))
838
839 (defimplementation print-frame (frame stream)
840 (sb-debug::print-frame-call frame stream))
841
842 ;;;; Code-location -> source-location translation
843
844 ;;; If debug-block info is avaibale, we determine the file position of
845 ;;; the source-path for a code-location. If the code was compiled
846 ;;; with C-c C-c, we have to search the position in the source string.
847 ;;; If there's no debug-block info, we return the (less precise)
848 ;;; source-location of the corresponding function.
849
850 (defun code-location-source-location (code-location)
851 (let* ((dsource (sb-di:code-location-debug-source code-location))
852 (plist (sb-c::debug-source-plist dsource)))
853 (if (getf plist :emacs-buffer)
854 (emacs-buffer-source-location code-location plist)
855 #+#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
856 (ecase (sb-di:debug-source-from dsource)
857 (:file (file-source-location code-location))
858 (:lisp (lisp-source-location code-location)))
859 #-#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
860 (if (sb-di:debug-source-namestring dsource)
861 (file-source-location code-location)
862 (lisp-source-location code-location)))))
863
864 ;;; FIXME: The naming policy of source-location functions is a bit
865 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
866 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
867 ;;; which returns the source location for a _code-location_.
868 ;;;
869 ;;; Maybe these should be named code-location-file-source-location,
870 ;;; etc, turned into generic functions, or something. In the very
871 ;;; least the names should indicate the main entry point vs. helper
872 ;;; status.
873
874 (defun file-source-location (code-location)
875 (if (code-location-has-debug-block-info-p code-location)
876 (source-file-source-location code-location)
877 (fallback-source-location code-location)))
878
879 (defun fallback-source-location (code-location)
880 (let ((fun (code-location-debug-fun-fun code-location)))
881 (cond (fun (function-source-location fun))
882 (t (error "Cannot find source location for: ~A " code-location)))))
883
884 (defun lisp-source-location (code-location)
885 (let ((source (prin1-to-string
886 (sb-debug::code-location-source-form code-location 100))))
887 (make-location `(:source-form ,source) '(:position 0))))
888
889 (defun emacs-buffer-source-location (code-location plist)
890 (if (code-location-has-debug-block-info-p code-location)
891 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
892 &allow-other-keys)
893 plist
894 (let* ((pos (string-source-position code-location emacs-string))
895 (snipped (with-input-from-string (s emacs-string)
896 (read-snippet s pos))))
897 (make-location `(:buffer ,emacs-buffer)
898 `(:position ,(+ emacs-position pos))
899 `(:snippet ,snipped))))
900 (fallback-source-location code-location)))
901
902 (defun source-file-source-location (code-location)
903 (let* ((code-date (code-location-debug-source-created code-location))
904 (filename (code-location-debug-source-name code-location))
905 (*readtable* (guess-readtable-for-filename filename))
906 (source-code (get-source-code filename code-date)))
907 (with-debootstrapping
908 (with-input-from-string (s source-code)
909 (let* ((pos (stream-source-position code-location s))
910 (snippet (read-snippet s pos)))
911 (make-location `(:file ,filename)
912 `(:position ,(1+ pos))
913 `(:snippet ,snippet)))))))
914
915 (defun code-location-debug-source-name (code-location)
916 (namestring (truename (#+#.(swank-backend::sbcl-with-symbol
917 'debug-source-name 'sb-di)
918 sb-c::debug-source-name
919 #-#.(swank-backend::sbcl-with-symbol
920 'debug-source-name 'sb-di)
921 sb-c::debug-source-namestring
922 (sb-di::code-location-debug-source code-location)))))
923
924 (defun code-location-debug-source-created (code-location)
925 (sb-c::debug-source-created
926 (sb-di::code-location-debug-source code-location)))
927
928 (defun code-location-debug-fun-fun (code-location)
929 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
930
931 (defun code-location-has-debug-block-info-p (code-location)
932 (handler-case
933 (progn (sb-di:code-location-debug-block code-location)
934 t)
935 (sb-di:no-debug-blocks () nil)))
936
937 (defun stream-source-position (code-location stream)
938 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
939 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
940 (form-number (sb-di::code-location-form-number cloc)))
941 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
942 (let* ((path-table (sb-di::form-number-translations tlf 0))
943 (path (cond ((<= (length path-table) form-number)
944 (warn "inconsistent form-number-translations")
945 (list 0))
946 (t
947 (reverse (cdr (aref path-table form-number)))))))
948 (source-path-source-position path tlf pos-map)))))
949
950 (defun string-source-position (code-location string)
951 (with-input-from-string (s string)
952 (stream-source-position code-location s)))
953
954 ;;; source-path-file-position and friends are in swank-source-path-parser
955
956 (defun safe-source-location-for-emacs (code-location)
957 (if *debug-definition-finding*
958 (code-location-source-location code-location)
959 (handler-case (code-location-source-location code-location)
960 (error (c) (list :error (format nil "~A" c))))))
961
962 (defimplementation frame-source-location-for-emacs (index)
963 (safe-source-location-for-emacs
964 (sb-di:frame-code-location (nth-frame index))))
965
966 (defun frame-debug-vars (frame)
967 "Return a vector of debug-variables in frame."
968 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
969
970 (defun debug-var-value (var frame location)
971 (ecase (sb-di:debug-var-validity var location)
972 (:valid (sb-di:debug-var-value var frame))
973 ((:invalid :unknown) ':<not-available>)))
974
975 (defimplementation frame-locals (index)
976 (let* ((frame (nth-frame index))
977 (loc (sb-di:frame-code-location frame))
978 (vars (frame-debug-vars frame)))
979 (loop for v across vars collect
980 (list :name (sb-di:debug-var-symbol v)
981 :id (sb-di:debug-var-id v)
982 :value (debug-var-value v frame loc)))))
983
984 (defimplementation frame-var-value (frame var)
985 (let* ((frame (nth-frame frame))
986 (dvar (aref (frame-debug-vars frame) var)))
987 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
988
989 (defimplementation frame-catch-tags (index)
990 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
991
992 (defimplementation eval-in-frame (form index)
993 (let ((frame (nth-frame index)))
994 (funcall (the function
995 (sb-di:preprocess-for-eval form
996 (sb-di:frame-code-location frame)))
997 frame)))
998
999 #+#.(swank-backend::sbcl-with-restart-frame)
1000 (progn
1001 (defimplementation return-from-frame (index form)
1002 (let* ((frame (nth-frame index)))
1003 (cond ((sb-debug:frame-has-debug-tag-p frame)
1004 (let ((values (multiple-value-list (eval-in-frame form index))))
1005 (sb-debug:unwind-to-frame-and-call frame
1006 (lambda ()
1007 (values-list values)))))
1008 (t (format nil "Cannot return from frame: ~S" frame)))))
1009
1010 (defimplementation restart-frame (index)
1011 (let* ((frame (nth-frame index)))
1012 (cond ((sb-debug:frame-has-debug-tag-p frame)
1013 (let* ((call-list (sb-debug::frame-call-as-list frame))
1014 (fun (fdefinition (car call-list)))
1015 (thunk (lambda ()
1016 ;; Ensure that the thunk gets tail-call-optimized
1017 (declare (optimize (debug 1)))
1018 (apply fun (cdr call-list)))))
1019 (sb-debug:unwind-to-frame-and-call frame thunk)))
1020 (t (format nil "Cannot restart frame: ~S" frame))))))
1021
1022 ;; FIXME: this implementation doesn't unwind the stack before
1023 ;; re-invoking the function, but it's better than no implementation at
1024 ;; all.
1025 #-#.(swank-backend::sbcl-with-restart-frame)
1026 (progn
1027 (defun sb-debug-catch-tag-p (tag)
1028 (and (symbolp tag)
1029 (not (symbol-package tag))
1030 (string= tag :sb-debug-catch-tag)))
1031
1032 (defimplementation return-from-frame (index form)
1033 (let* ((frame (nth-frame index))
1034 (probe (assoc-if #'sb-debug-catch-tag-p
1035 (sb-di::frame-catches frame))))
1036 (cond (probe (throw (car probe) (eval-in-frame form index)))
1037 (t (format nil "Cannot return from frame: ~S" frame)))))
1038
1039 (defimplementation restart-frame (index)
1040 (let ((frame (nth-frame index)))
1041 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1042
1043 ;;;;; reference-conditions
1044
1045 (defimplementation format-sldb-condition (condition)
1046 (let ((sb-int:*print-condition-references* nil))
1047 (princ-to-string condition)))
1048
1049
1050 ;;;; Profiling
1051
1052 (defimplementation profile (fname)
1053 (when fname (eval `(sb-profile:profile ,fname))))
1054
1055 (defimplementation unprofile (fname)
1056 (when fname (eval `(sb-profile:unprofile ,fname))))
1057
1058 (defimplementation unprofile-all ()
1059 (sb-profile:unprofile)
1060 "All functions unprofiled.")
1061
1062 (defimplementation profile-report ()
1063 (sb-profile:report))
1064
1065 (defimplementation profile-reset ()
1066 (sb-profile:reset)
1067 "Reset profiling counters.")
1068
1069 (defimplementation profiled-functions ()
1070 (sb-profile:profile))
1071
1072 (defimplementation profile-package (package callers methods)
1073 (declare (ignore callers methods))
1074 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1075
1076
1077 ;;;; Inspector
1078
1079 (defmethod emacs-inspect ((o t))
1080 (cond ((sb-di::indirect-value-cell-p o)
1081 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1082 (t
1083 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1084 (list* (format nil "~a~%" text)
1085 (if label
1086 (loop for (l . v) in parts
1087 append (label-value-line l v))
1088 (loop for value in parts for i from 0
1089 append (label-value-line i value))))))))
1090
1091 (defmethod emacs-inspect ((o function))
1092 (let ((header (sb-kernel:widetag-of o)))
1093 (cond ((= header sb-vm:simple-fun-header-widetag)
1094 (label-value-line*
1095 (:name (sb-kernel:%simple-fun-name o))
1096 (:arglist (sb-kernel:%simple-fun-arglist o))
1097 (:self (sb-kernel:%simple-fun-self o))
1098 (:next (sb-kernel:%simple-fun-next o))
1099 (:type (sb-kernel:%simple-fun-type o))
1100 (:code (sb-kernel:fun-code-header o))))
1101 ((= header sb-vm:closure-header-widetag)
1102 (append
1103 (label-value-line :function (sb-kernel:%closure-fun o))
1104 `("Closed over values:" (:newline))
1105 (loop for i below (1- (sb-kernel:get-closure-length o))
1106 append (label-value-line
1107 i (sb-kernel:%closure-index-ref o i)))))
1108 (t (call-next-method o)))))
1109
1110 (defmethod emacs-inspect ((o sb-kernel:code-component))
1111 (append
1112 (label-value-line*
1113 (:code-size (sb-kernel:%code-code-size o))
1114 (:entry-points (sb-kernel:%code-entry-points o))
1115 (:debug-info (sb-kernel:%code-debug-info o))
1116 (:trace-table-offset (sb-kernel:code-header-ref
1117 o sb-vm:code-trace-table-offset-slot)))
1118 `("Constants:" (:newline))
1119 (loop for i from sb-vm:code-constants-offset
1120 below (sb-kernel:get-header-data o)
1121 append (label-value-line i (sb-kernel:code-header-ref o i)))
1122 `("Code:" (:newline)
1123 , (with-output-to-string (s)
1124 (cond ((sb-kernel:%code-debug-info o)
1125 (sb-disassem:disassemble-code-component o :stream s))
1126 (t
1127 (sb-disassem:disassemble-memory
1128 (sb-disassem::align
1129 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1130 sb-vm:lowtag-mask)
1131 (* sb-vm:code-constants-offset
1132 sb-vm:n-word-bytes))
1133 (ash 1 sb-vm:n-lowtag-bits))
1134 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1135 :stream s)))))))
1136
1137 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1138 (label-value-line*
1139 (:value (sb-ext:weak-pointer-value o))))
1140
1141 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1142 (label-value-line*
1143 (:name (sb-kernel:fdefn-name o))
1144 (:function (sb-kernel:fdefn-fun o))))
1145
1146 (defmethod emacs-inspect :around ((o generic-function))
1147 (append
1148 (call-next-method)
1149 (label-value-line*
1150 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1151 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1152 )))
1153
1154
1155 ;;;; Multiprocessing
1156
1157 #+(and sb-thread
1158 #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1159 (progn
1160 (defvar *thread-id-counter* 0)
1161
1162 (defvar *thread-id-counter-lock*
1163 (sb-thread:make-mutex :name "thread id counter lock"))
1164
1165 (defun next-thread-id ()
1166 (sb-thread:with-mutex (*thread-id-counter-lock*)
1167 (incf *thread-id-counter*)))
1168
1169 (defparameter *thread-id-map* (make-hash-table))
1170
1171 ;; This should be a thread -> id map but as weak keys are not
1172 ;; supported it is id -> map instead.
1173 (defvar *thread-id-map-lock*
1174 (sb-thread:make-mutex :name "thread id map lock"))
1175
1176 (defimplementation spawn (fn &key name)
1177 (sb-thread:make-thread fn :name name))
1178
1179 (defimplementation thread-id (thread)
1180 (block thread-id
1181 (sb-thread:with-mutex (*thread-id-map-lock*)
1182 (loop for id being the hash-key in *thread-id-map*
1183 using (hash-value thread-pointer)
1184 do
1185 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1186 (cond ((null maybe-thread)
1187 ;; the value is gc'd, remove it manually
1188 (remhash id *thread-id-map*))
1189 ((eq thread maybe-thread)
1190 (return-from thread-id id)))))
1191 ;; lazy numbering
1192 (let ((id (next-thread-id)))
1193 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1194 id))))
1195
1196 (defimplementation find-thread (id)
1197 (sb-thread:with-mutex (*thread-id-map-lock*)
1198 (let ((thread-pointer (gethash id *thread-id-map*)))
1199 (if thread-pointer
1200 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1201 (if maybe-thread
1202 maybe-thread
1203 ;; the value is gc'd, remove it manually
1204 (progn
1205 (remhash id *thread-id-map*)
1206 nil)))
1207 nil))))
1208
1209 (defimplementation thread-name (thread)
1210 ;; sometimes the name is not a string (e.g. NIL)
1211 (princ-to-string (sb-thread:thread-name thread)))
1212
1213 (defimplementation thread-status (thread)
1214 (if (sb-thread:thread-alive-p thread)
1215 "RUNNING"
1216 "STOPPED"))
1217 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1218 (progn
1219 (defparameter *thread-description-map*
1220 (make-weak-key-hash-table))
1221
1222 (defvar *thread-descr-map-lock*
1223 (sb-thread:make-mutex :name "thread description map lock"))
1224
1225 (defimplementation thread-description (thread)
1226 (sb-thread:with-mutex (*thread-descr-map-lock*)
1227 (or (gethash thread *thread-description-map*) "")))
1228
1229 (defimplementation set-thread-description (thread description)
1230 (sb-thread:with-mutex (*thread-descr-map-lock*)
1231 (setf (gethash thread *thread-description-map*) description))))
1232
1233 (defimplementation make-lock (&key name)
1234 (sb-thread:make-mutex :name name))
1235
1236 (defimplementation call-with-lock-held (lock function)
1237 (declare (type function function))
1238 (sb-thread:with-mutex (lock) (funcall function)))
1239
1240 (defimplementation make-recursive-lock (&key name)
1241 (sb-thread:make-mutex :name name))
1242
1243 (defimplementation call-with-recursive-lock-held (lock function)
1244 (declare (type function function))
1245 (sb-thread:with-recursive-lock (lock) (funcall function)))
1246
1247 (defimplementation current-thread ()
1248 sb-thread:*current-thread*)
1249
1250 (defimplementation all-threads ()
1251 (sb-thread:list-all-threads))
1252
1253 (defimplementation interrupt-thread (thread fn)
1254 (sb-thread:interrupt-thread thread fn))
1255
1256 (defimplementation kill-thread (thread)
1257 (sb-thread:terminate-thread thread))
1258
1259 (defimplementation thread-alive-p (thread)
1260 (sb-thread:thread-alive-p thread))
1261
1262 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1263 (defvar *mailboxes* (list))
1264 (declaim (type list *mailboxes*))
1265
1266 (defstruct (mailbox (:conc-name mailbox.))
1267 thread
1268 (mutex (sb-thread:make-mutex))
1269 (waitqueue (sb-thread:make-waitqueue))
1270 (queue '() :type list))
1271
1272 (defun mailbox (thread)
1273 "Return THREAD's mailbox."
1274 (sb-thread:with-mutex (*mailbox-lock*)
1275 (or (find thread *mailboxes* :key #'mailbox.thread)
1276 (let ((mb (make-mailbox :thread thread)))
1277 (push mb *mailboxes*)
1278 mb))))
1279
1280 (defimplementation send (thread message)
1281 (let* ((mbox (mailbox thread))
1282 (mutex (mailbox.mutex mbox)))
1283 (sb-thread:with-mutex (mutex)
1284 (setf (mailbox.queue mbox)
1285 (nconc (mailbox.queue mbox) (list message)))
1286 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1287
1288 (defimplementation receive ()
1289 (let* ((mbox (mailbox (current-thread)))
1290 (mutex (mailbox.mutex mbox)))
1291 (sb-thread:with-mutex (mutex)
1292 (loop
1293 (let ((q (mailbox.queue mbox)))
1294 (cond (q (return (pop (mailbox.queue mbox))))
1295 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1296 mutex))))))))
1297
1298 (defimplementation receive-if (test)
1299 (let* ((mbox (mailbox (current-thread)))
1300 (mutex (mailbox.mutex mbox)))
1301 (sb-thread:with-mutex (mutex)
1302 (loop
1303 (let* ((q (mailbox.queue mbox))
1304 (tail (member-if test q)))
1305 (cond (tail
1306 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1307 (return (car tail)))
1308 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1309 mutex))))))))
1310
1311 ;; Auto-flush streams
1312
1313 (defvar *auto-flush-interval* 0.15
1314 "How often to flush interactive streams. This value is passed
1315 directly to cl:sleep.")
1316
1317 (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
1318
1319 (defvar *auto-flush-thread* nil)
1320
1321 (defvar *auto-flush-streams* '())
1322
1323 (defimplementation make-stream-interactive (stream)
1324 (call-with-recursive-lock-held
1325 *auto-flush-lock*
1326 (lambda ()
1327 (pushnew stream *auto-flush-streams*)
1328 (unless *auto-flush-thread*
1329 (setq *auto-flush-thread*
1330 (sb-thread:make-thread #'flush-streams
1331 :name "auto-flush-thread"))))))
1332
1333 (defun flush-streams ()
1334 (loop
1335 (call-with-recursive-lock-held
1336 *auto-flush-lock*
1337 (lambda ()
1338 (setq *auto-flush-streams*
1339 (remove-if (lambda (x)
1340 (not (and (open-stream-p x)
1341 (output-stream-p x))))
1342 *auto-flush-streams*))
1343 (mapc #'finish-output *auto-flush-streams*)))
1344 (sleep *auto-flush-interval*)))
1345
1346 )
1347
1348 (defimplementation quit-lisp ()
1349 #+sb-thread
1350 (dolist (thread (remove (current-thread) (all-threads)))
1351 (ignore-errors (sb-thread:interrupt-thread
1352 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1353 (sb-ext:quit))
1354
1355
1356
1357 ;;Trace implementations
1358 ;;In SBCL, we have:
1359 ;; (trace <name>)
1360 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1361 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1362 ;; <name> can be a normal name or a (setf name)
1363
1364 (defun toggle-trace-aux (fspec &rest args)
1365 (cond ((member fspec (eval '(trace)) :test #'equal)
1366 (eval `(untrace ,fspec))
1367 (format nil "~S is now untraced." fspec))
1368 (t
1369 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1370 (format nil "~S is now traced." fspec))))
1371
1372 (defun process-fspec (fspec)
1373 (cond ((consp fspec)
1374 (ecase (first fspec)
1375 ((:defun :defgeneric) (second fspec))
1376 ((:defmethod) `(method ,@(rest fspec)))
1377 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1378 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1379 (t
1380 fspec)))
1381
1382 (defimplementation toggle-trace (spec)
1383 (ecase (car spec)
1384 ((setf)
1385 (toggle-trace-aux spec))
1386 ((:defmethod)
1387 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1388 ((:defgeneric)
1389 (toggle-trace-aux (second spec) :methods t))
1390 ((:call)
1391 (destructuring-bind (caller callee) (cdr spec)
1392 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1393
1394 ;;; Weak datastructures
1395
1396 (defimplementation make-weak-key-hash-table (&rest args)
1397 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1398 (apply #'make-hash-table :weakness :key args)
1399 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1400 (apply #'make-hash-table args))
1401
1402 (defimplementation make-weak-value-hash-table (&rest args)
1403 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1404 (apply #'make-hash-table :weakness :value args)
1405 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1406 (apply #'make-hash-table args))
1407
1408 (defimplementation hash-table-weakness (hashtable)
1409 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1410 (sb-ext:hash-table-weakness hashtable))

  ViewVC Help
Powered by ViewVC 1.1.5