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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.213 - (show annotations)
Mon Aug 11 17:41:55 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.212: +6 -0 lines
Improve interrupt safety for single-threaded lisps.

* slime.el (slime-interrupt): Send a :emacs-interrupt message
together with SIGINT.  SIGINT now means "check for new events"
instead of "invoke the debugger".

* swank-backend.lisp (install-sigint-handler)
(call-with-user-break-handler): New functions.

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

  ViewVC Help
Powered by ViewVC 1.1.5