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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.198 - (show annotations)
Sat Jul 5 11:48:11 2008 UTC (5 years, 9 months ago) by trittweiler
Branch: MAIN
Changes since 1.197: +16 -1 lines
	`M-x slime-lisp-threads' will now contain a summary of what's
	currently executed in a thread that was created by Swank.

	* swank-backend.lisp (thread-description, set-thread-description):
	New interface functions to associate strings with threads.
	* swank-sbcl.lisp (thread-description, set-thread-description):
	Implemented.

	* swank.lisp (call-with-thread-description),
	(with-thread-description): New.
	(read-from-emacs): Now temporarily sets the thread-description of
	the current thread to a summary of what's going to be executed by
	the current request.
	(defslimefun list-threads): Changed return value to also contain
	a thread's description.

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

  ViewVC Help
Powered by ViewVC 1.1.5