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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.218 - (show annotations)
Fri Sep 12 12:27:38 2008 UTC (5 years, 7 months ago) by trittweiler
Branch: MAIN
Changes since 1.217: +11 -6 lines
	New faces: `sldb-restartable-frame-line-face',
	           `sldb-non-restartable-frame-line-face'.

	The former is the face for frames that are surely restartable, the
	latter for frames that are surely not restartable. If
	restartability of a frame cannot be reliably determined, the face
	`sldb-frame-line-face' is used.

	At the moment, determination of frame restartability is supported
	by the SBCL backend only.

	* slime.el (sldb-frame.string): New.
	(sldb-frame.number): New.
	(sldb-frame.plist): New.
	(sldb-prune-initial-frames): Use them.
	(sldb-insert-frames): Ditto.
	(sldb-compute-frame-face): New.
	(sldb-insert-frame): Use `sldb-compute-frame-face' to insert
	frames with one of the faces described above.

	* swank.lisp (defslimefun backtrace): Changed return value; each
	frame is now accompanied with a PLIST which at the moment can
	contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame
	is restartable, or not.

	* swank-backend.lisp (defstruct swank-frame): New structure.
	(compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs.
	(print-frame): Renamed to PRINT-SWANK-FRAME.

	* swank-sbcl.lisp, swank-cmucl.lisp, swank-lispworks.lisp,
	* swank-allegro.lisp, swank-scl.lisp, swank-openmcl.lisp,
	* swank-abcl.lisp, swank-clisp.lisp: Adapted to swank-backend changes.
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 (nil 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 collect (make-swank-frame
853 :%frame f
854 :restartable (frame-restartable-p f)))))
855
856 (defimplementation print-swank-frame (swank-frame stream)
857 (sb-debug::print-frame-call (swank-frame.%frame swank-frame) stream))
858
859 (defun frame-restartable-p (frame)
860 #+#.(swank-backend::sbcl-with-restart-frame)
861 (sb-debug:frame-has-debug-tag-p frame))
862
863 ;;;; Code-location -> source-location translation
864
865 ;;; If debug-block info is avaibale, we determine the file position of
866 ;;; the source-path for a code-location. If the code was compiled
867 ;;; with C-c C-c, we have to search the position in the source string.
868 ;;; If there's no debug-block info, we return the (less precise)
869 ;;; source-location of the corresponding function.
870
871 (defun code-location-source-location (code-location)
872 (let* ((dsource (sb-di:code-location-debug-source code-location))
873 (plist (sb-c::debug-source-plist dsource)))
874 (if (getf plist :emacs-buffer)
875 (emacs-buffer-source-location code-location plist)
876 #+#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
877 (ecase (sb-di:debug-source-from dsource)
878 (:file (file-source-location code-location))
879 (:lisp (lisp-source-location code-location)))
880 #-#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
881 (if (sb-di:debug-source-namestring dsource)
882 (file-source-location code-location)
883 (lisp-source-location code-location)))))
884
885 ;;; FIXME: The naming policy of source-location functions is a bit
886 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
887 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
888 ;;; which returns the source location for a _code-location_.
889 ;;;
890 ;;; Maybe these should be named code-location-file-source-location,
891 ;;; etc, turned into generic functions, or something. In the very
892 ;;; least the names should indicate the main entry point vs. helper
893 ;;; status.
894
895 (defun file-source-location (code-location)
896 (if (code-location-has-debug-block-info-p code-location)
897 (source-file-source-location code-location)
898 (fallback-source-location code-location)))
899
900 (defun fallback-source-location (code-location)
901 (let ((fun (code-location-debug-fun-fun code-location)))
902 (cond (fun (function-source-location fun))
903 (t (error "Cannot find source location for: ~A " code-location)))))
904
905 (defun lisp-source-location (code-location)
906 (let ((source (prin1-to-string
907 (sb-debug::code-location-source-form code-location 100))))
908 (make-location `(:source-form ,source) '(:position 0))))
909
910 (defun emacs-buffer-source-location (code-location plist)
911 (if (code-location-has-debug-block-info-p code-location)
912 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
913 &allow-other-keys)
914 plist
915 (let* ((pos (string-source-position code-location emacs-string))
916 (snipped (with-input-from-string (s emacs-string)
917 (read-snippet s pos))))
918 (make-location `(:buffer ,emacs-buffer)
919 `(:position ,(+ emacs-position pos))
920 `(:snippet ,snipped))))
921 (fallback-source-location code-location)))
922
923 (defun source-file-source-location (code-location)
924 (let* ((code-date (code-location-debug-source-created code-location))
925 (filename (code-location-debug-source-name code-location))
926 (*readtable* (guess-readtable-for-filename filename))
927 (source-code (get-source-code filename code-date)))
928 (with-debootstrapping
929 (with-input-from-string (s source-code)
930 (let* ((pos (stream-source-position code-location s))
931 (snippet (read-snippet s pos)))
932 (make-location `(:file ,filename)
933 `(:position ,(1+ pos))
934 `(:snippet ,snippet)))))))
935
936 (defun code-location-debug-source-name (code-location)
937 (namestring (truename (#+#.(swank-backend::sbcl-with-symbol
938 'debug-source-name 'sb-di)
939 sb-c::debug-source-name
940 #-#.(swank-backend::sbcl-with-symbol
941 'debug-source-name 'sb-di)
942 sb-c::debug-source-namestring
943 (sb-di::code-location-debug-source code-location)))))
944
945 (defun code-location-debug-source-created (code-location)
946 (sb-c::debug-source-created
947 (sb-di::code-location-debug-source code-location)))
948
949 (defun code-location-debug-fun-fun (code-location)
950 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
951
952 (defun code-location-has-debug-block-info-p (code-location)
953 (handler-case
954 (progn (sb-di:code-location-debug-block code-location)
955 t)
956 (sb-di:no-debug-blocks () nil)))
957
958 (defun stream-source-position (code-location stream)
959 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
960 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
961 (form-number (sb-di::code-location-form-number cloc)))
962 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
963 (let* ((path-table (sb-di::form-number-translations tlf 0))
964 (path (cond ((<= (length path-table) form-number)
965 (warn "inconsistent form-number-translations")
966 (list 0))
967 (t
968 (reverse (cdr (aref path-table form-number)))))))
969 (source-path-source-position path tlf pos-map)))))
970
971 (defun string-source-position (code-location string)
972 (with-input-from-string (s string)
973 (stream-source-position code-location s)))
974
975 ;;; source-path-file-position and friends are in swank-source-path-parser
976
977 (defun safe-source-location-for-emacs (code-location)
978 (if *debug-definition-finding*
979 (code-location-source-location code-location)
980 (handler-case (code-location-source-location code-location)
981 (error (c) (list :error (format nil "~A" c))))))
982
983 (defimplementation frame-source-location-for-emacs (index)
984 (safe-source-location-for-emacs
985 (sb-di:frame-code-location (nth-frame index))))
986
987 (defun frame-debug-vars (frame)
988 "Return a vector of debug-variables in frame."
989 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
990
991 (defun debug-var-value (var frame location)
992 (ecase (sb-di:debug-var-validity var location)
993 (:valid (sb-di:debug-var-value var frame))
994 ((:invalid :unknown) ':<not-available>)))
995
996 (defimplementation frame-locals (index)
997 (let* ((frame (nth-frame index))
998 (loc (sb-di:frame-code-location frame))
999 (vars (frame-debug-vars frame)))
1000 (loop for v across vars collect
1001 (list :name (sb-di:debug-var-symbol v)
1002 :id (sb-di:debug-var-id v)
1003 :value (debug-var-value v frame loc)))))
1004
1005 (defimplementation frame-var-value (frame var)
1006 (let* ((frame (nth-frame frame))
1007 (dvar (aref (frame-debug-vars frame) var)))
1008 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
1009
1010 (defimplementation frame-catch-tags (index)
1011 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1012
1013 (defimplementation eval-in-frame (form index)
1014 (let ((frame (nth-frame index)))
1015 (funcall (the function
1016 (sb-di:preprocess-for-eval form
1017 (sb-di:frame-code-location frame)))
1018 frame)))
1019
1020 #+#.(swank-backend::sbcl-with-restart-frame)
1021 (progn
1022 (defimplementation return-from-frame (index form)
1023 (let* ((frame (nth-frame index)))
1024 (cond ((sb-debug:frame-has-debug-tag-p frame)
1025 (let ((values (multiple-value-list (eval-in-frame form index))))
1026 (sb-debug:unwind-to-frame-and-call frame
1027 (lambda ()
1028 (values-list values)))))
1029 (t (format nil "Cannot return from frame: ~S" frame)))))
1030
1031 (defimplementation restart-frame (index)
1032 (let* ((frame (nth-frame index)))
1033 (cond ((sb-debug:frame-has-debug-tag-p frame)
1034 (let* ((call-list (sb-debug::frame-call-as-list frame))
1035 (fun (fdefinition (car call-list)))
1036 (thunk (lambda ()
1037 ;; Ensure that the thunk gets tail-call-optimized
1038 (declare (optimize (debug 1)))
1039 (apply fun (cdr call-list)))))
1040 (sb-debug:unwind-to-frame-and-call frame thunk)))
1041 (t (format nil "Cannot restart frame: ~S" frame))))))
1042
1043 ;; FIXME: this implementation doesn't unwind the stack before
1044 ;; re-invoking the function, but it's better than no implementation at
1045 ;; all.
1046 #-#.(swank-backend::sbcl-with-restart-frame)
1047 (progn
1048 (defun sb-debug-catch-tag-p (tag)
1049 (and (symbolp tag)
1050 (not (symbol-package tag))
1051 (string= tag :sb-debug-catch-tag)))
1052
1053 (defimplementation return-from-frame (index form)
1054 (let* ((frame (nth-frame index))
1055 (probe (assoc-if #'sb-debug-catch-tag-p
1056 (sb-di::frame-catches frame))))
1057 (cond (probe (throw (car probe) (eval-in-frame form index)))
1058 (t (format nil "Cannot return from frame: ~S" frame)))))
1059
1060 (defimplementation restart-frame (index)
1061 (let ((frame (nth-frame index)))
1062 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1063
1064 ;;;;; reference-conditions
1065
1066 (defimplementation format-sldb-condition (condition)
1067 (let ((sb-int:*print-condition-references* nil))
1068 (princ-to-string condition)))
1069
1070
1071 ;;;; Profiling
1072
1073 (defimplementation profile (fname)
1074 (when fname (eval `(sb-profile:profile ,fname))))
1075
1076 (defimplementation unprofile (fname)
1077 (when fname (eval `(sb-profile:unprofile ,fname))))
1078
1079 (defimplementation unprofile-all ()
1080 (sb-profile:unprofile)
1081 "All functions unprofiled.")
1082
1083 (defimplementation profile-report ()
1084 (sb-profile:report))
1085
1086 (defimplementation profile-reset ()
1087 (sb-profile:reset)
1088 "Reset profiling counters.")
1089
1090 (defimplementation profiled-functions ()
1091 (sb-profile:profile))
1092
1093 (defimplementation profile-package (package callers methods)
1094 (declare (ignore callers methods))
1095 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1096
1097
1098 ;;;; Inspector
1099
1100 (defmethod emacs-inspect ((o t))
1101 (cond ((sb-di::indirect-value-cell-p o)
1102 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1103 (t
1104 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1105 (list* (format nil "~a~%" text)
1106 (if label
1107 (loop for (l . v) in parts
1108 append (label-value-line l v))
1109 (loop for value in parts for i from 0
1110 append (label-value-line i value))))))))
1111
1112 (defmethod emacs-inspect ((o function))
1113 (let ((header (sb-kernel:widetag-of o)))
1114 (cond ((= header sb-vm:simple-fun-header-widetag)
1115 (label-value-line*
1116 (:name (sb-kernel:%simple-fun-name o))
1117 (:arglist (sb-kernel:%simple-fun-arglist o))
1118 (:self (sb-kernel:%simple-fun-self o))
1119 (:next (sb-kernel:%simple-fun-next o))
1120 (:type (sb-kernel:%simple-fun-type o))
1121 (:code (sb-kernel:fun-code-header o))))
1122 ((= header sb-vm:closure-header-widetag)
1123 (append
1124 (label-value-line :function (sb-kernel:%closure-fun o))
1125 `("Closed over values:" (:newline))
1126 (loop for i below (1- (sb-kernel:get-closure-length o))
1127 append (label-value-line
1128 i (sb-kernel:%closure-index-ref o i)))))
1129 (t (call-next-method o)))))
1130
1131 (defmethod emacs-inspect ((o sb-kernel:code-component))
1132 (append
1133 (label-value-line*
1134 (:code-size (sb-kernel:%code-code-size o))
1135 (:entry-points (sb-kernel:%code-entry-points o))
1136 (:debug-info (sb-kernel:%code-debug-info o))
1137 (:trace-table-offset (sb-kernel:code-header-ref
1138 o sb-vm:code-trace-table-offset-slot)))
1139 `("Constants:" (:newline))
1140 (loop for i from sb-vm:code-constants-offset
1141 below (sb-kernel:get-header-data o)
1142 append (label-value-line i (sb-kernel:code-header-ref o i)))
1143 `("Code:" (:newline)
1144 , (with-output-to-string (s)
1145 (cond ((sb-kernel:%code-debug-info o)
1146 (sb-disassem:disassemble-code-component o :stream s))
1147 (t
1148 (sb-disassem:disassemble-memory
1149 (sb-disassem::align
1150 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1151 sb-vm:lowtag-mask)
1152 (* sb-vm:code-constants-offset
1153 sb-vm:n-word-bytes))
1154 (ash 1 sb-vm:n-lowtag-bits))
1155 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1156 :stream s)))))))
1157
1158 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1159 (label-value-line*
1160 (:value (sb-ext:weak-pointer-value o))))
1161
1162 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1163 (label-value-line*
1164 (:name (sb-kernel:fdefn-name o))
1165 (:function (sb-kernel:fdefn-fun o))))
1166
1167 (defmethod emacs-inspect :around ((o generic-function))
1168 (append
1169 (call-next-method)
1170 (label-value-line*
1171 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1172 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1173 )))
1174
1175
1176 ;;;; Multiprocessing
1177
1178 #+(and sb-thread
1179 #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1180 (progn
1181 (defvar *thread-id-counter* 0)
1182
1183 (defvar *thread-id-counter-lock*
1184 (sb-thread:make-mutex :name "thread id counter lock"))
1185
1186 (defun next-thread-id ()
1187 (sb-thread:with-mutex (*thread-id-counter-lock*)
1188 (incf *thread-id-counter*)))
1189
1190 (defparameter *thread-id-map* (make-hash-table))
1191
1192 ;; This should be a thread -> id map but as weak keys are not
1193 ;; supported it is id -> map instead.
1194 (defvar *thread-id-map-lock*
1195 (sb-thread:make-mutex :name "thread id map lock"))
1196
1197 (defimplementation spawn (fn &key name)
1198 (sb-thread:make-thread fn :name name))
1199
1200 (defimplementation thread-id (thread)
1201 (block thread-id
1202 (sb-thread:with-mutex (*thread-id-map-lock*)
1203 (loop for id being the hash-key in *thread-id-map*
1204 using (hash-value thread-pointer)
1205 do
1206 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1207 (cond ((null maybe-thread)
1208 ;; the value is gc'd, remove it manually
1209 (remhash id *thread-id-map*))
1210 ((eq thread maybe-thread)
1211 (return-from thread-id id)))))
1212 ;; lazy numbering
1213 (let ((id (next-thread-id)))
1214 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1215 id))))
1216
1217 (defimplementation find-thread (id)
1218 (sb-thread:with-mutex (*thread-id-map-lock*)
1219 (let ((thread-pointer (gethash id *thread-id-map*)))
1220 (if thread-pointer
1221 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1222 (if maybe-thread
1223 maybe-thread
1224 ;; the value is gc'd, remove it manually
1225 (progn
1226 (remhash id *thread-id-map*)
1227 nil)))
1228 nil))))
1229
1230 (defimplementation thread-name (thread)
1231 ;; sometimes the name is not a string (e.g. NIL)
1232 (princ-to-string (sb-thread:thread-name thread)))
1233
1234 (defimplementation thread-status (thread)
1235 (if (sb-thread:thread-alive-p thread)
1236 "RUNNING"
1237 "STOPPED"))
1238 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1239 (progn
1240 (defparameter *thread-description-map*
1241 (make-weak-key-hash-table))
1242
1243 (defvar *thread-descr-map-lock*
1244 (sb-thread:make-mutex :name "thread description map lock"))
1245
1246 (defimplementation thread-description (thread)
1247 (sb-thread:with-mutex (*thread-descr-map-lock*)
1248 (or (gethash thread *thread-description-map*)
1249 (short-backtrace thread 6 10))))
1250
1251 (defimplementation set-thread-description (thread description)
1252 (sb-thread:with-mutex (*thread-descr-map-lock*)
1253 (setf (gethash thread *thread-description-map*) description)))
1254
1255 (defun short-backtrace (thread start count)
1256 (let ((self (current-thread))
1257 (tag (get-internal-real-time)))
1258 (sb-thread:interrupt-thread
1259 thread
1260 (lambda ()
1261 (let* ((frames (nthcdr start (sb-debug:backtrace-as-list count))))
1262 (send self (cons tag frames)))))
1263 (handler-case
1264 (sb-ext:with-timeout 0.1
1265 (let ((frames (cdr (receive-if (lambda (msg)
1266 (eq (car msg) tag)))))
1267 (*print-pretty* nil))
1268 (format nil "~{~a~^ <- ~}" (mapcar #'car frames))))
1269 (sb-ext:timeout () ""))))
1270
1271 )
1272
1273 (defimplementation make-lock (&key name)
1274 (sb-thread:make-mutex :name name))
1275
1276 (defimplementation call-with-lock-held (lock function)
1277 (declare (type function function))
1278 (sb-thread:with-recursive-lock (lock) (funcall function)))
1279
1280 (defimplementation current-thread ()
1281 sb-thread:*current-thread*)
1282
1283 (defimplementation all-threads ()
1284 (sb-thread:list-all-threads))
1285
1286 (defimplementation interrupt-thread (thread fn)
1287 (sb-thread:interrupt-thread thread fn))
1288
1289 (defimplementation kill-thread (thread)
1290 (sb-thread:terminate-thread thread))
1291
1292 (defimplementation thread-alive-p (thread)
1293 (sb-thread:thread-alive-p thread))
1294
1295 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1296 (defvar *mailboxes* (list))
1297 (declaim (type list *mailboxes*))
1298
1299 (defstruct (mailbox (:conc-name mailbox.))
1300 thread
1301 (mutex (sb-thread:make-mutex))
1302 (waitqueue (sb-thread:make-waitqueue))
1303 (queue '() :type list))
1304
1305 (defun mailbox (thread)
1306 "Return THREAD's mailbox."
1307 (sb-thread:with-mutex (*mailbox-lock*)
1308 (or (find thread *mailboxes* :key #'mailbox.thread)
1309 (let ((mb (make-mailbox :thread thread)))
1310 (push mb *mailboxes*)
1311 mb))))
1312
1313 (defimplementation send (thread message)
1314 (let* ((mbox (mailbox thread))
1315 (mutex (mailbox.mutex mbox)))
1316 (sb-thread:with-mutex (mutex)
1317 (setf (mailbox.queue mbox)
1318 (nconc (mailbox.queue mbox) (list message)))
1319 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1320
1321 (defimplementation receive-if (test &optional timeout)
1322 (let* ((mbox (mailbox (current-thread)))
1323 (mutex (mailbox.mutex mbox)))
1324 (assert (or (not timeout) (eq timeout t)))
1325 (loop
1326 (check-slime-interrupts)
1327 (sb-thread:with-mutex (mutex)
1328 (let* ((q (mailbox.queue mbox))
1329 (tail (member-if test q)))
1330 (when tail
1331 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1332 (return (car tail))))
1333 (when (eq timeout t) (return (values nil t)))
1334 ;; FIXME: with-timeout doesn't work properly on Darwin
1335 #+linux
1336 (handler-case (sb-ext:with-timeout 0.2
1337 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1338 mutex))
1339 (sb-ext:timeout ()))
1340 #-linux
1341 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1342 mutex)))))
1343 )
1344
1345 (defimplementation quit-lisp ()
1346 #+sb-thread
1347 (dolist (thread (remove (current-thread) (all-threads)))
1348 (ignore-errors (sb-thread:interrupt-thread
1349 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1350 (sb-ext:quit))
1351
1352
1353
1354 ;;Trace implementations
1355 ;;In SBCL, we have:
1356 ;; (trace <name>)
1357 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1358 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1359 ;; <name> can be a normal name or a (setf name)
1360
1361 (defun toggle-trace-aux (fspec &rest args)
1362 (cond ((member fspec (eval '(trace)) :test #'equal)
1363 (eval `(untrace ,fspec))
1364 (format nil "~S is now untraced." fspec))
1365 (t
1366 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1367 (format nil "~S is now traced." fspec))))
1368
1369 (defun process-fspec (fspec)
1370 (cond ((consp fspec)
1371 (ecase (first fspec)
1372 ((:defun :defgeneric) (second fspec))
1373 ((:defmethod) `(method ,@(rest fspec)))
1374 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1375 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1376 (t
1377 fspec)))
1378
1379 (defimplementation toggle-trace (spec)
1380 (ecase (car spec)
1381 ((setf)
1382 (toggle-trace-aux spec))
1383 ((:defmethod)
1384 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1385 ((:defgeneric)
1386 (toggle-trace-aux (second spec) :methods t))
1387 ((:call)
1388 (destructuring-bind (caller callee) (cdr spec)
1389 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1390
1391 ;;; Weak datastructures
1392
1393 (defimplementation make-weak-key-hash-table (&rest args)
1394 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1395 (apply #'make-hash-table :weakness :key args)
1396 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1397 (apply #'make-hash-table args))
1398
1399 (defimplementation make-weak-value-hash-table (&rest args)
1400 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1401 (apply #'make-hash-table :weakness :value args)
1402 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1403 (apply #'make-hash-table args))
1404
1405 (defimplementation hash-table-weakness (hashtable)
1406 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1407 (sb-ext:hash-table-weakness hashtable))
1408
1409 #-win32
1410 (defimplementation save-image (filename &optional restart-function)
1411 (let ((pid (sb-posix:fork)))
1412 (cond ((= pid 0)
1413 (let ((args `(,filename
1414 ,@(if restart-function
1415 `((:toplevel ,restart-function))))))
1416 (apply #'sb-ext:save-lisp-and-die args)))
1417 (t
1418 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1419 (assert (= pid rpid))
1420 (assert (and (sb-posix:wifexited status)
1421 (zerop (sb-posix:wexitstatus status)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5