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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5