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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.229 - (show annotations)
Fri Jan 2 17:07:00 2009 UTC (5 years, 3 months ago) by trittweiler
Branch: MAIN
Changes since 1.228: +6 -0 lines
	Arglists of user-defined types are now displayed by slime-autodoc
	on SBCL.

	  (deftype foo (x y) `(cons ,x ,y))
	  (declare (type (foo |

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

  ViewVC Help
Powered by ViewVC 1.1.5