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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.219 - (show annotations)
Wed Sep 17 06:19:49 2008 UTC (5 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.218: +11 -13 lines
Adjust positions in files with CRLF-style end-on-line markers.

* slime.el (slime-eol-conversion-fixup): New function.
(slime-goto-location-position): Use it.  Also add a new position
type :offset, so that we don't adjust offsets in strings that were
sent over the wire (which uses LF eol-convention).

* swank-abcl.lisp
* swank-allegro.lisp
* swank-clisp.lisp
* swank-cmucl.lisp
* swank-corman.lisp
* swank-ecl.lisp
* swank-lispworks.lisp
* swank-openmcl.lisp
* swank-sbcl.lisp
* swank-scl.lisp: Create :offset style positions where needed.

* swank-lispworks.lisp (skip-comments): New function.
(dspec-stream-position): Use it.
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 (make-location (list :buffer *buffer-name*)
375 (list :offset *buffer-offset*
376 (source-path-string-position
377 source-path *buffer-substring*))))
378 ((and (pathnamep file) (null *buffer-name*))
379 ;; Compiling from a file
380 (make-location (list :file (namestring file))
381 (list :position (1+ (source-path-file-position
382 source-path file)))))
383 ((and (eq file :lisp) (stringp source))
384 ;; Compiling macro generated code
385 (make-location (list :source-form source)
386 (list :position 1)))
387 (t
388 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
389
390 (defun brief-compiler-message-for-emacs (condition)
391 "Briefly describe a compiler error for Emacs.
392 When Emacs presents the message it already has the source popped up
393 and the source form highlighted. This makes much of the information in
394 the error-context redundant."
395 (let ((sb-int:*print-condition-references* nil))
396 (princ-to-string condition)))
397
398 (defun long-compiler-message-for-emacs (condition error-context)
399 "Describe a compiler error for Emacs including context information."
400 (declare (type (or sb-c::compiler-error-context null) error-context))
401 (multiple-value-bind (enclosing source)
402 (if error-context
403 (values (sb-c::compiler-error-context-enclosing-source error-context)
404 (sb-c::compiler-error-context-source error-context)))
405 (let ((sb-int:*print-condition-references* nil))
406 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
407 enclosing source condition))))
408
409 (defun compiler-source-path (context)
410 "Return the source-path for the current compiler error.
411 Returns NIL if this cannot be determined by examining internal
412 compiler state."
413 (cond ((sb-c::node-p context)
414 (reverse
415 (sb-c::source-path-original-source
416 (sb-c::node-source-path context))))
417 ((sb-c::compiler-error-context-p context)
418 (reverse
419 (sb-c::compiler-error-context-original-source-path context)))))
420
421 (defimplementation call-with-compilation-hooks (function)
422 (declare (type function function))
423 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
424 (sb-c:compiler-error #'handle-notification-condition)
425 (sb-ext:compiler-note #'handle-notification-condition)
426 (warning #'handle-notification-condition))
427 (funcall function)))
428
429 (defun handle-file-compiler-termination (condition)
430 "Handle a condition that caused the file compiler to terminate."
431 (handle-notification-condition
432 (sb-int:encapsulated-condition condition)))
433
434 (defvar *trap-load-time-warnings* nil)
435
436 (defimplementation swank-compile-file (pathname load-p external-format)
437 (handler-case
438 (let ((output-file (with-compilation-hooks ()
439 (compile-file pathname
440 :external-format external-format))))
441 (when output-file
442 ;; Cache the latest source file for definition-finding.
443 (source-cache-get pathname (file-write-date pathname))
444 (when load-p
445 (load output-file))))
446 (sb-c:fatal-compiler-error () nil)))
447
448 ;;;; compile-string
449
450 ;;; We copy the string to a temporary file in order to get adequate
451 ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
452 ;;; which the previous approach using
453 ;;; (compile nil `(lambda () ,(read-from-string string)))
454 ;;; did not provide.
455
456 (sb-alien:define-alien-routine "tmpnam" sb-alien:c-string
457 (dest (* sb-alien:c-string)))
458
459 (defun temp-file-name ()
460 "Return a temporary file name to compile strings into."
461 (concatenate 'string (tmpnam nil) ".lisp"))
462
463 (defimplementation swank-compile-string (string &key buffer position directory
464 debug)
465 (declare (ignorable debug))
466 (let ((*buffer-name* buffer)
467 (*buffer-offset* position)
468 (*buffer-substring* string)
469 (filename (temp-file-name))
470 #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
471 (old-min-debug (assoc 'debug (sb-ext:restrict-compiler-policy)))
472 )
473 #+#.(swank-backend::sbcl-with-symbol 'restrict-compiler-policy 'sb-ext)
474 (when debug
475 (sb-ext:restrict-compiler-policy 'debug debug))
476 (flet ((load-it (filename)
477 (when filename (load filename)))
478 (compile-it (cont)
479 (with-compilation-hooks ()
480 (with-compilation-unit
481 (:source-plist (list :emacs-buffer buffer
482 :emacs-directory directory
483 :emacs-string string
484 :emacs-position position))
485 (funcall cont (compile-file filename))))))
486 (with-open-file (s filename :direction :output :if-exists :error)
487 (write-string string s))
488 (unwind-protect
489 (if *trap-load-time-warnings*
490 (compile-it #'load-it)
491 (load-it (compile-it #'identity)))
492 (ignore-errors
493 #+#.(swank-backend::sbcl-with-symbol
494 'restrict-compiler-policy 'sb-ext)
495 (sb-ext:restrict-compiler-policy 'debug (or old-min-debug 0))
496 (delete-file filename)
497 (delete-file (compile-file-pathname filename)))))))
498
499 ;;;; Definitions
500
501 (defvar *debug-definition-finding* nil
502 "When true don't handle errors while looking for definitions.
503 This is useful when debugging the definition-finding code.")
504
505 (defparameter *definition-types*
506 '(:variable defvar
507 :constant defconstant
508 :type deftype
509 :symbol-macro define-symbol-macro
510 :macro defmacro
511 :compiler-macro define-compiler-macro
512 :function defun
513 :generic-function defgeneric
514 :method defmethod
515 :setf-expander define-setf-expander
516 :structure defstruct
517 :condition define-condition
518 :class defclass
519 :method-combination define-method-combination
520 :package defpackage
521 :transform :deftransform
522 :optimizer :defoptimizer
523 :vop :define-vop
524 :source-transform :define-source-transform)
525 "Map SB-INTROSPECT definition type names to Slime-friendly forms")
526
527 (defimplementation find-definitions (name)
528 (loop for type in *definition-types* by #'cddr
529 for locations = (sb-introspect:find-definition-sources-by-name
530 name type)
531 append (loop for source-location in locations collect
532 (make-source-location-specification type name
533 source-location))))
534
535 (defimplementation find-source-location (obj)
536 (flet ((general-type-of (obj)
537 (typecase obj
538 (method :method)
539 (generic-function :generic-function)
540 (function :function)
541 (structure-class :structure-class)
542 (class :class)
543 (method-combination :method-combination)
544 (package :package)
545 (condition :condition)
546 (structure-object :structure-object)
547 (standard-object :standard-object)
548 (t :thing)))
549 (to-string (obj)
550 (typecase obj
551 (package (princ-to-string obj)) ; Packages are possibly named entities.
552 ((or structure-object standard-object condition)
553 (with-output-to-string (s)
554 (print-unreadable-object (obj s :type t :identity t))))
555 (t (princ-to-string obj)))))
556 (handler-case
557 (make-definition-source-location
558 (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))
559 (error (e)
560 (list :error (format nil "Error: ~A" e))))))
561
562
563 (defun make-source-location-specification (type name source-location)
564 (list (list* (getf *definition-types* type)
565 name
566 (sb-introspect::definition-source-description source-location))
567 (if *debug-definition-finding*
568 (make-definition-source-location source-location type name)
569 (handler-case
570 (make-definition-source-location source-location type name)
571 (error (e)
572 (list :error (format nil "Error: ~A" e)))))))
573
574 (defun make-definition-source-location (definition-source type name)
575 (with-struct (sb-introspect::definition-source-
576 pathname form-path character-offset plist
577 file-write-date)
578 definition-source
579 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
580 emacs-string &allow-other-keys)
581 plist
582 (cond
583 (emacs-buffer
584 (let* ((*readtable* (guess-readtable-for-filename emacs-directory))
585 (pos (if form-path
586 (with-debootstrapping
587 (source-path-string-position form-path emacs-string))
588 character-offset))
589 (snippet (string-path-snippet emacs-string form-path pos)))
590 (make-location `(:buffer ,emacs-buffer)
591 `(:offset ,emacs-position ,pos)
592 `(:snippet ,snippet))))
593 ((not pathname)
594 `(:error ,(format nil "Source definition of ~A ~A not found"
595 (string-downcase type) name)))
596 (t
597 (let* ((namestring (namestring (translate-logical-pathname pathname)))
598 (pos (source-file-position namestring file-write-date form-path
599 character-offset))
600 (snippet (source-hint-snippet namestring file-write-date pos)))
601 (make-location `(:file ,namestring)
602 ;; /file positions/ in Common Lisp start
603 ;; from 0, in Emacs they start from 1.
604 `(:position (1+ ,pos))
605 `(:snippet ,snippet))))))))
606
607 (defun string-path-snippet (string form-path position)
608 (if form-path
609 ;; If we have a form-path, use it to derive a more accurate
610 ;; snippet, so that we can point to the individual form rather
611 ;; than just the toplevel form.
612 (multiple-value-bind (data end)
613 (let ((*read-suppress* t))
614 (read-from-string string nil nil :start position))
615 (declare (ignore data))
616 (subseq string position end))
617 string))
618
619 (defun source-file-position (filename write-date form-path character-offset)
620 (let ((source (get-source-code filename write-date))
621 (*readtable* (guess-readtable-for-filename filename)))
622 (with-debootstrapping
623 (if form-path
624 (source-path-string-position form-path source)
625 (or character-offset 0)))))
626
627 (defun source-hint-snippet (filename write-date position)
628 (let ((source (get-source-code filename write-date)))
629 (with-input-from-string (s source)
630 (read-snippet s position))))
631
632 (defun function-source-location (function &optional name)
633 (declare (type function function))
634 (let ((location (sb-introspect:find-definition-source function)))
635 (make-definition-source-location location :function name)))
636
637 (defun safe-function-source-location (fun name)
638 (if *debug-definition-finding*
639 (function-source-location fun name)
640 (handler-case (function-source-location fun name)
641 (error (e)
642 (list :error (format nil "Error: ~A" e))))))
643
644 (defimplementation describe-symbol-for-emacs (symbol)
645 "Return a plist describing SYMBOL.
646 Return NIL if the symbol is unbound."
647 (let ((result '()))
648 (flet ((doc (kind)
649 (or (documentation symbol kind) :not-documented))
650 (maybe-push (property value)
651 (when value
652 (setf result (list* property value result)))))
653 (maybe-push
654 :variable (multiple-value-bind (kind recorded-p)
655 (sb-int:info :variable :kind symbol)
656 (declare (ignore kind))
657 (if (or (boundp symbol) recorded-p)
658 (doc 'variable))))
659 (when (fboundp symbol)
660 (maybe-push
661 (cond ((macro-function symbol) :macro)
662 ((special-operator-p symbol) :special-operator)
663 ((typep (fdefinition symbol) 'generic-function)
664 :generic-function)
665 (t :function))
666 (doc 'function)))
667 (maybe-push
668 :setf (if (or (sb-int:info :setf :inverse symbol)
669 (sb-int:info :setf :expander symbol))
670 (doc 'setf)))
671 (maybe-push
672 :type (if (sb-int:info :type :kind symbol)
673 (doc 'type)))
674 result)))
675
676 (defimplementation describe-definition (symbol type)
677 (case type
678 (:variable
679 (describe symbol))
680 (:function
681 (describe (symbol-function symbol)))
682 (:setf
683 (describe (or (sb-int:info :setf :inverse symbol)
684 (sb-int:info :setf :expander symbol))))
685 (:class
686 (describe (find-class symbol)))
687 (:type
688 (describe (sb-kernel:values-specifier-type symbol)))))
689
690 #+#.(swank-backend::sbcl-with-xref-p)
691 (progn
692 (defmacro defxref (name)
693 `(defimplementation ,name (what)
694 (sanitize-xrefs
695 (mapcar #'source-location-for-xref-data
696 (,(find-symbol (symbol-name name) "SB-INTROSPECT")
697 what)))))
698 (defxref who-calls)
699 (defxref who-binds)
700 (defxref who-sets)
701 (defxref who-references)
702 (defxref who-macroexpands))
703
704 (defun source-location-for-xref-data (xref-data)
705 (let ((name (car xref-data))
706 (source-location (cdr xref-data)))
707 (list name
708 (handler-case (make-definition-source-location source-location
709 'function
710 name)
711 (error (e)
712 (list :error (format nil "Error: ~A" e)))))))
713
714 (defimplementation list-callers (symbol)
715 (let ((fn (fdefinition symbol)))
716 (sanitize-xrefs
717 (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
718
719 (defimplementation list-callees (symbol)
720 (let ((fn (fdefinition symbol)))
721 (sanitize-xrefs
722 (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
723
724 (defun sanitize-xrefs (xrefs)
725 (remove-duplicates
726 (remove-if (lambda (f)
727 (member f (ignored-xref-function-names)))
728 (loop for entry in xrefs
729 for name = (car entry)
730 collect (if (and (consp name)
731 (member (car name)
732 '(sb-pcl::fast-method
733 sb-pcl::slow-method
734 sb-pcl::method)))
735 (cons (cons 'defmethod (cdr name))
736 (cdr entry))
737 entry))
738 :key #'car)
739 :test (lambda (a b)
740 (and (eq (first a) (first b))
741 (equal (second a) (second b))))))
742
743 (defun ignored-xref-function-names ()
744 #-#.(swank-backend::sbcl-with-new-stepper-p)
745 '(nil sb-c::step-form sb-c::step-values)
746 #+#.(swank-backend::sbcl-with-new-stepper-p)
747 '(nil))
748
749 (defun function-dspec (fn)
750 "Describe where the function FN was defined.
751 Return a list of the form (NAME LOCATION)."
752 (let ((name (sb-kernel:%fun-name fn)))
753 (list name (safe-function-source-location fn name))))
754
755 ;;; macroexpansion
756
757 (defimplementation macroexpand-all (form)
758 (let ((sb-walker:*walk-form-expand-macros-p* t))
759 (sb-walker:walk-form form)))
760
761
762 ;;; Debugging
763
764 (defvar *sldb-stack-top*)
765
766 (defun make-invoke-debugger-hook (hook)
767 #'(lambda (condition old-hook)
768 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
769 ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
770 ;; run when it was established locally by a user (i.e. changed meanwhile.)
771 (if *debugger-hook*
772 (funcall *debugger-hook* condition old-hook)
773 (funcall hook condition old-hook))))
774
775 (defimplementation install-debugger-globally (function)
776 (setq *debugger-hook* function)
777 (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
778
779 (defimplementation condition-extras (condition)
780 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
781 ((typep condition 'sb-impl::step-form-condition)
782 `((:show-frame-source 0)))
783 ((typep condition 'sb-int:reference-condition)
784 (let ((refs (sb-int:reference-condition-references condition)))
785 (if refs
786 `((:references ,(externalize-reference refs))))))))
787
788 (defun externalize-reference (ref)
789 (etypecase ref
790 (null nil)
791 (cons (cons (externalize-reference (car ref))
792 (externalize-reference (cdr ref))))
793 ((or string number) ref)
794 (symbol
795 (cond ((eq (symbol-package ref) (symbol-package :test))
796 ref)
797 (t (symbol-name ref))))))
798
799 (defimplementation call-with-debugging-environment (debugger-loop-fn)
800 (declare (type function debugger-loop-fn))
801 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
802 (sb-debug:*stack-top-hint* nil))
803 (handler-bind ((sb-di:debug-condition
804 (lambda (condition)
805 (signal (make-condition
806 'sldb-condition
807 :original-condition condition)))))
808 (funcall debugger-loop-fn))))
809
810 #+#.(swank-backend::sbcl-with-new-stepper-p)
811 (progn
812 (defimplementation activate-stepping (frame)
813 (declare (ignore frame))
814 (sb-impl::enable-stepping))
815 (defimplementation sldb-stepper-condition-p (condition)
816 (typep condition 'sb-ext:step-form-condition))
817 (defimplementation sldb-step-into ()
818 (invoke-restart 'sb-ext:step-into))
819 (defimplementation sldb-step-next ()
820 (invoke-restart 'sb-ext:step-next))
821 (defimplementation sldb-step-out ()
822 (invoke-restart 'sb-ext:step-out)))
823
824 (defimplementation call-with-debugger-hook (hook fun)
825 (let ((*debugger-hook* hook)
826 (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
827 #+#.(swank-backend::sbcl-with-new-stepper-p)
828 (sb-ext:*stepper-hook*
829 (lambda (condition)
830 (typecase condition
831 (sb-ext:step-form-condition
832 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
833 (sb-impl::invoke-debugger condition)))))))
834 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
835 (sb-ext:step-condition #'sb-impl::invoke-stepper))
836 (funcall fun))))
837
838 (defun nth-frame (index)
839 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
840 (i index (1- i)))
841 ((zerop i) frame)))
842
843 (defimplementation compute-backtrace (start end)
844 "Return a list of frames starting with frame number START and
845 continuing to frame number END or, if END is nil, the last frame on the
846 stack."
847 (let ((end (or end most-positive-fixnum)))
848 (loop for f = (nth-frame start) then (sb-di:frame-down f)
849 for i from start below end
850 while f collect (make-swank-frame
851 :%frame f
852 :restartable (frame-restartable-p f)))))
853
854 (defimplementation print-swank-frame (swank-frame stream)
855 (sb-debug::print-frame-call (swank-frame.%frame swank-frame) stream))
856
857 (defun frame-restartable-p (frame)
858 #+#.(swank-backend::sbcl-with-restart-frame)
859 (sb-debug:frame-has-debug-tag-p frame))
860
861 ;;;; Code-location -> source-location translation
862
863 ;;; If debug-block info is avaibale, we determine the file position of
864 ;;; the source-path for a code-location. If the code was compiled
865 ;;; with C-c C-c, we have to search the position in the source string.
866 ;;; If there's no debug-block info, we return the (less precise)
867 ;;; source-location of the corresponding function.
868
869 (defun code-location-source-location (code-location)
870 (let* ((dsource (sb-di:code-location-debug-source code-location))
871 (plist (sb-c::debug-source-plist dsource)))
872 (if (getf plist :emacs-buffer)
873 (emacs-buffer-source-location code-location plist)
874 #+#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
875 (ecase (sb-di:debug-source-from dsource)
876 (:file (file-source-location code-location))
877 (:lisp (lisp-source-location code-location)))
878 #-#.(swank-backend::sbcl-with-symbol 'debug-source-from 'sb-di)
879 (if (sb-di:debug-source-namestring dsource)
880 (file-source-location code-location)
881 (lisp-source-location code-location)))))
882
883 ;;; FIXME: The naming policy of source-location functions is a bit
884 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
885 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
886 ;;; which returns the source location for a _code-location_.
887 ;;;
888 ;;; Maybe these should be named code-location-file-source-location,
889 ;;; etc, turned into generic functions, or something. In the very
890 ;;; least the names should indicate the main entry point vs. helper
891 ;;; status.
892
893 (defun file-source-location (code-location)
894 (if (code-location-has-debug-block-info-p code-location)
895 (source-file-source-location code-location)
896 (fallback-source-location code-location)))
897
898 (defun fallback-source-location (code-location)
899 (let ((fun (code-location-debug-fun-fun code-location)))
900 (cond (fun (function-source-location fun))
901 (t (error "Cannot find source location for: ~A " code-location)))))
902
903 (defun lisp-source-location (code-location)
904 (let ((source (prin1-to-string
905 (sb-debug::code-location-source-form code-location 100))))
906 (make-location `(:source-form ,source) '(:position 1))))
907
908 (defun emacs-buffer-source-location (code-location plist)
909 (if (code-location-has-debug-block-info-p code-location)
910 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
911 &allow-other-keys)
912 plist
913 (let* ((pos (string-source-position code-location emacs-string))
914 (snipped (with-input-from-string (s emacs-string)
915 (read-snippet s pos))))
916 (make-location `(:buffer ,emacs-buffer)
917 `(:offset ,emacs-position ,pos)
918 `(:snippet ,snipped))))
919 (fallback-source-location code-location)))
920
921 (defun source-file-source-location (code-location)
922 (let* ((code-date (code-location-debug-source-created code-location))
923 (filename (code-location-debug-source-name code-location))
924 (*readtable* (guess-readtable-for-filename filename))
925 (source-code (get-source-code filename code-date)))
926 (with-debootstrapping
927 (with-input-from-string (s source-code)
928 (let* ((pos (stream-source-position code-location s))
929 (snippet (read-snippet s pos)))
930 (make-location `(:file ,filename)
931 `(:position ,pos)
932 `(:snippet ,snippet)))))))
933
934 (defun code-location-debug-source-name (code-location)
935 (namestring (truename (#+#.(swank-backend::sbcl-with-symbol
936 'debug-source-name 'sb-di)
937 sb-c::debug-source-name
938 #-#.(swank-backend::sbcl-with-symbol
939 'debug-source-name 'sb-di)
940 sb-c::debug-source-namestring
941 (sb-di::code-location-debug-source code-location)))))
942
943 (defun code-location-debug-source-created (code-location)
944 (sb-c::debug-source-created
945 (sb-di::code-location-debug-source code-location)))
946
947 (defun code-location-debug-fun-fun (code-location)
948 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
949
950 (defun code-location-has-debug-block-info-p (code-location)
951 (handler-case
952 (progn (sb-di:code-location-debug-block code-location)
953 t)
954 (sb-di:no-debug-blocks () nil)))
955
956 (defun stream-source-position (code-location stream)
957 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
958 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
959 (form-number (sb-di::code-location-form-number cloc)))
960 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
961 (let* ((path-table (sb-di::form-number-translations tlf 0))
962 (path (cond ((<= (length path-table) form-number)
963 (warn "inconsistent form-number-translations")
964 (list 0))
965 (t
966 (reverse (cdr (aref path-table form-number)))))))
967 (source-path-source-position path tlf pos-map)))))
968
969 (defun string-source-position (code-location string)
970 (with-input-from-string (s string)
971 (stream-source-position code-location s)))
972
973 ;;; source-path-file-position and friends are in swank-source-path-parser
974
975 (defun safe-source-location-for-emacs (code-location)
976 (if *debug-definition-finding*
977 (code-location-source-location code-location)
978 (handler-case (code-location-source-location code-location)
979 (error (c) (list :error (format nil "~A" c))))))
980
981 (defimplementation frame-source-location-for-emacs (index)
982 (safe-source-location-for-emacs
983 (sb-di:frame-code-location (nth-frame index))))
984
985 (defun frame-debug-vars (frame)
986 "Return a vector of debug-variables in frame."
987 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
988
989 (defun debug-var-value (var frame location)
990 (ecase (sb-di:debug-var-validity var location)
991 (:valid (sb-di:debug-var-value var frame))
992 ((:invalid :unknown) ':<not-available>)))
993
994 (defimplementation frame-locals (index)
995 (let* ((frame (nth-frame index))
996 (loc (sb-di:frame-code-location frame))
997 (vars (frame-debug-vars frame)))
998 (loop for v across vars collect
999 (list :name (sb-di:debug-var-symbol v)
1000 :id (sb-di:debug-var-id v)
1001 :value (debug-var-value v frame loc)))))
1002
1003 (defimplementation frame-var-value (frame var)
1004 (let* ((frame (nth-frame frame))
1005 (dvar (aref (frame-debug-vars frame) var)))
1006 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
1007
1008 (defimplementation frame-catch-tags (index)
1009 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1010
1011 (defimplementation eval-in-frame (form index)
1012 (let ((frame (nth-frame index)))
1013 (funcall (the function
1014 (sb-di:preprocess-for-eval form
1015 (sb-di:frame-code-location frame)))
1016 frame)))
1017
1018 #+#.(swank-backend::sbcl-with-restart-frame)
1019 (progn
1020 (defimplementation return-from-frame (index form)
1021 (let* ((frame (nth-frame index)))
1022 (cond ((sb-debug:frame-has-debug-tag-p frame)
1023 (let ((values (multiple-value-list (eval-in-frame form index))))
1024 (sb-debug:unwind-to-frame-and-call frame
1025 (lambda ()
1026 (values-list values)))))
1027 (t (format nil "Cannot return from frame: ~S" frame)))))
1028
1029 (defimplementation restart-frame (index)
1030 (let* ((frame (nth-frame index)))
1031 (cond ((sb-debug:frame-has-debug-tag-p frame)
1032 (let* ((call-list (sb-debug::frame-call-as-list frame))
1033 (fun (fdefinition (car call-list)))
1034 (thunk (lambda ()
1035 ;; Ensure that the thunk gets tail-call-optimized
1036 (declare (optimize (debug 1)))
1037 (apply fun (cdr call-list)))))
1038 (sb-debug:unwind-to-frame-and-call frame thunk)))
1039 (t (format nil "Cannot restart frame: ~S" frame))))))
1040
1041 ;; FIXME: this implementation doesn't unwind the stack before
1042 ;; re-invoking the function, but it's better than no implementation at
1043 ;; all.
1044 #-#.(swank-backend::sbcl-with-restart-frame)
1045 (progn
1046 (defun sb-debug-catch-tag-p (tag)
1047 (and (symbolp tag)
1048 (not (symbol-package tag))
1049 (string= tag :sb-debug-catch-tag)))
1050
1051 (defimplementation return-from-frame (index form)
1052 (let* ((frame (nth-frame index))
1053 (probe (assoc-if #'sb-debug-catch-tag-p
1054 (sb-di::frame-catches frame))))
1055 (cond (probe (throw (car probe) (eval-in-frame form index)))
1056 (t (format nil "Cannot return from frame: ~S" frame)))))
1057
1058 (defimplementation restart-frame (index)
1059 (let ((frame (nth-frame index)))
1060 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1061
1062 ;;;;; reference-conditions
1063
1064 (defimplementation format-sldb-condition (condition)
1065 (let ((sb-int:*print-condition-references* nil))
1066 (princ-to-string condition)))
1067
1068
1069 ;;;; Profiling
1070
1071 (defimplementation profile (fname)
1072 (when fname (eval `(sb-profile:profile ,fname))))
1073
1074 (defimplementation unprofile (fname)
1075 (when fname (eval `(sb-profile:unprofile ,fname))))
1076
1077 (defimplementation unprofile-all ()
1078 (sb-profile:unprofile)
1079 "All functions unprofiled.")
1080
1081 (defimplementation profile-report ()
1082 (sb-profile:report))
1083
1084 (defimplementation profile-reset ()
1085 (sb-profile:reset)
1086 "Reset profiling counters.")
1087
1088 (defimplementation profiled-functions ()
1089 (sb-profile:profile))
1090
1091 (defimplementation profile-package (package callers methods)
1092 (declare (ignore callers methods))
1093 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1094
1095
1096 ;;;; Inspector
1097
1098 (defmethod emacs-inspect ((o t))
1099 (cond ((sb-di::indirect-value-cell-p o)
1100 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1101 (t
1102 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1103 (list* (format nil "~a~%" text)
1104 (if label
1105 (loop for (l . v) in parts
1106 append (label-value-line l v))
1107 (loop for value in parts for i from 0
1108 append (label-value-line i value))))))))
1109
1110 (defmethod emacs-inspect ((o function))
1111 (let ((header (sb-kernel:widetag-of o)))
1112 (cond ((= header sb-vm:simple-fun-header-widetag)
1113 (label-value-line*
1114 (:name (sb-kernel:%simple-fun-name o))
1115 (:arglist (sb-kernel:%simple-fun-arglist o))
1116 (:self (sb-kernel:%simple-fun-self o))
1117 (:next (sb-kernel:%simple-fun-next o))
1118 (:type (sb-kernel:%simple-fun-type o))
1119 (:code (sb-kernel:fun-code-header o))))
1120 ((= header sb-vm:closure-header-widetag)
1121 (append
1122 (label-value-line :function (sb-kernel:%closure-fun o))
1123 `("Closed over values:" (:newline))
1124 (loop for i below (1- (sb-kernel:get-closure-length o))
1125 append (label-value-line
1126 i (sb-kernel:%closure-index-ref o i)))))
1127 (t (call-next-method o)))))
1128
1129 (defmethod emacs-inspect ((o sb-kernel:code-component))
1130 (append
1131 (label-value-line*
1132 (:code-size (sb-kernel:%code-code-size o))
1133 (:entry-points (sb-kernel:%code-entry-points o))
1134 (:debug-info (sb-kernel:%code-debug-info o))
1135 (:trace-table-offset (sb-kernel:code-header-ref
1136 o sb-vm:code-trace-table-offset-slot)))
1137 `("Constants:" (:newline))
1138 (loop for i from sb-vm:code-constants-offset
1139 below (sb-kernel:get-header-data o)
1140 append (label-value-line i (sb-kernel:code-header-ref o i)))
1141 `("Code:" (:newline)
1142 , (with-output-to-string (s)
1143 (cond ((sb-kernel:%code-debug-info o)
1144 (sb-disassem:disassemble-code-component o :stream s))
1145 (t
1146 (sb-disassem:disassemble-memory
1147 (sb-disassem::align
1148 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1149 sb-vm:lowtag-mask)
1150 (* sb-vm:code-constants-offset
1151 sb-vm:n-word-bytes))
1152 (ash 1 sb-vm:n-lowtag-bits))
1153 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1154 :stream s)))))))
1155
1156 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1157 (label-value-line*
1158 (:value (sb-ext:weak-pointer-value o))))
1159
1160 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1161 (label-value-line*
1162 (:name (sb-kernel:fdefn-name o))
1163 (:function (sb-kernel:fdefn-fun o))))
1164
1165 (defmethod emacs-inspect :around ((o generic-function))
1166 (append
1167 (call-next-method)
1168 (label-value-line*
1169 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1170 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1171 )))
1172
1173
1174 ;;;; Multiprocessing
1175
1176 #+(and sb-thread
1177 #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1178 (progn
1179 (defvar *thread-id-counter* 0)
1180
1181 (defvar *thread-id-counter-lock*
1182 (sb-thread:make-mutex :name "thread id counter lock"))
1183
1184 (defun next-thread-id ()
1185 (sb-thread:with-mutex (*thread-id-counter-lock*)
1186 (incf *thread-id-counter*)))
1187
1188 (defparameter *thread-id-map* (make-hash-table))
1189
1190 ;; This should be a thread -> id map but as weak keys are not
1191 ;; supported it is id -> map instead.
1192 (defvar *thread-id-map-lock*
1193 (sb-thread:make-mutex :name "thread id map lock"))
1194
1195 (defimplementation spawn (fn &key name)
1196 (sb-thread:make-thread fn :name name))
1197
1198 (defimplementation thread-id (thread)
1199 (block thread-id
1200 (sb-thread:with-mutex (*thread-id-map-lock*)
1201 (loop for id being the hash-key in *thread-id-map*
1202 using (hash-value thread-pointer)
1203 do
1204 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1205 (cond ((null maybe-thread)
1206 ;; the value is gc'd, remove it manually
1207 (remhash id *thread-id-map*))
1208 ((eq thread maybe-thread)
1209 (return-from thread-id id)))))
1210 ;; lazy numbering
1211 (let ((id (next-thread-id)))
1212 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1213 id))))
1214
1215 (defimplementation find-thread (id)
1216 (sb-thread:with-mutex (*thread-id-map-lock*)
1217 (let ((thread-pointer (gethash id *thread-id-map*)))
1218 (if thread-pointer
1219 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1220 (if maybe-thread
1221 maybe-thread
1222 ;; the value is gc'd, remove it manually
1223 (progn
1224 (remhash id *thread-id-map*)
1225 nil)))
1226 nil))))
1227
1228 (defimplementation thread-name (thread)
1229 ;; sometimes the name is not a string (e.g. NIL)
1230 (princ-to-string (sb-thread:thread-name thread)))
1231
1232 (defimplementation thread-status (thread)
1233 (if (sb-thread:thread-alive-p thread)
1234 "RUNNING"
1235 "STOPPED"))
1236 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1237 (progn
1238 (defparameter *thread-description-map*
1239 (make-weak-key-hash-table))
1240
1241 (defvar *thread-descr-map-lock*
1242 (sb-thread:make-mutex :name "thread description map lock"))
1243
1244 (defimplementation thread-description (thread)
1245 (sb-thread:with-mutex (*thread-descr-map-lock*)
1246 (or (gethash thread *thread-description-map*)
1247 (short-backtrace thread 6 10))))
1248
1249 (defimplementation set-thread-description (thread description)
1250 (sb-thread:with-mutex (*thread-descr-map-lock*)
1251 (setf (gethash thread *thread-description-map*) description)))
1252
1253 (defun short-backtrace (thread start count)
1254 (let ((self (current-thread))
1255 (tag (get-internal-real-time)))
1256 (sb-thread:interrupt-thread
1257 thread
1258 (lambda ()
1259 (let* ((frames (nthcdr start (sb-debug:backtrace-as-list count))))
1260 (send self (cons tag frames)))))
1261 (handler-case
1262 (sb-ext:with-timeout 0.1
1263 (let ((frames (cdr (receive-if (lambda (msg)
1264 (eq (car msg) tag)))))
1265 (*print-pretty* nil))
1266 (format nil "~{~a~^ <- ~}" (mapcar #'car frames))))
1267 (sb-ext:timeout () ""))))
1268
1269 )
1270
1271 (defimplementation make-lock (&key name)
1272 (sb-thread:make-mutex :name name))
1273
1274 (defimplementation call-with-lock-held (lock function)
1275 (declare (type function function))
1276 (sb-thread:with-recursive-lock (lock) (funcall function)))
1277
1278 (defimplementation current-thread ()
1279 sb-thread:*current-thread*)
1280
1281 (defimplementation all-threads ()
1282 (sb-thread:list-all-threads))
1283
1284 (defimplementation interrupt-thread (thread fn)
1285 (sb-thread:interrupt-thread thread fn))
1286
1287 (defimplementation kill-thread (thread)
1288 (sb-thread:terminate-thread thread))
1289
1290 (defimplementation thread-alive-p (thread)
1291 (sb-thread:thread-alive-p thread))
1292
1293 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1294 (defvar *mailboxes* (list))
1295 (declaim (type list *mailboxes*))
1296
1297 (defstruct (mailbox (:conc-name mailbox.))
1298 thread
1299 (mutex (sb-thread:make-mutex))
1300 (waitqueue (sb-thread:make-waitqueue))
1301 (queue '() :type list))
1302
1303 (defun mailbox (thread)
1304 "Return THREAD's mailbox."
1305 (sb-thread:with-mutex (*mailbox-lock*)
1306 (or (find thread *mailboxes* :key #'mailbox.thread)
1307 (let ((mb (make-mailbox :thread thread)))
1308 (push mb *mailboxes*)
1309 mb))))
1310
1311 (defimplementation send (thread message)
1312 (let* ((mbox (mailbox thread))
1313 (mutex (mailbox.mutex mbox)))
1314 (sb-thread:with-mutex (mutex)
1315 (setf (mailbox.queue mbox)
1316 (nconc (mailbox.queue mbox) (list message)))
1317 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1318
1319 (defimplementation receive-if (test &optional timeout)
1320 (let* ((mbox (mailbox (current-thread)))
1321 (mutex (mailbox.mutex mbox)))
1322 (assert (or (not timeout) (eq timeout t)))
1323 (loop
1324 (check-slime-interrupts)
1325 (sb-thread:with-mutex (mutex)
1326 (let* ((q (mailbox.queue mbox))
1327 (tail (member-if test q)))
1328 (when tail
1329 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1330 (return (car tail))))
1331 (when (eq timeout t) (return (values nil t)))
1332 ;; FIXME: with-timeout doesn't work properly on Darwin
1333 #+linux
1334 (handler-case (sb-ext:with-timeout 0.2
1335 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1336 mutex))
1337 (sb-ext:timeout ()))
1338 #-linux
1339 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1340 mutex)))))
1341 )
1342
1343 (defimplementation quit-lisp ()
1344 #+sb-thread
1345 (dolist (thread (remove (current-thread) (all-threads)))
1346 (ignore-errors (sb-thread:interrupt-thread
1347 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1348 (sb-ext:quit))
1349
1350
1351
1352 ;;Trace implementations
1353 ;;In SBCL, we have:
1354 ;; (trace <name>)
1355 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1356 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1357 ;; <name> can be a normal name or a (setf name)
1358
1359 (defun toggle-trace-aux (fspec &rest args)
1360 (cond ((member fspec (eval '(trace)) :test #'equal)
1361 (eval `(untrace ,fspec))
1362 (format nil "~S is now untraced." fspec))
1363 (t
1364 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1365 (format nil "~S is now traced." fspec))))
1366
1367 (defun process-fspec (fspec)
1368 (cond ((consp fspec)
1369 (ecase (first fspec)
1370 ((:defun :defgeneric) (second fspec))
1371 ((:defmethod) `(method ,@(rest fspec)))
1372 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1373 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1374 (t
1375 fspec)))
1376
1377 (defimplementation toggle-trace (spec)
1378 (ecase (car spec)
1379 ((setf)
1380 (toggle-trace-aux spec))
1381 ((:defmethod)
1382 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1383 ((:defgeneric)
1384 (toggle-trace-aux (second spec) :methods t))
1385 ((:call)
1386 (destructuring-bind (caller callee) (cdr spec)
1387 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1388
1389 ;;; Weak datastructures
1390
1391 (defimplementation make-weak-key-hash-table (&rest args)
1392 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1393 (apply #'make-hash-table :weakness :key args)
1394 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1395 (apply #'make-hash-table args))
1396
1397 (defimplementation make-weak-value-hash-table (&rest args)
1398 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1399 (apply #'make-hash-table :weakness :value args)
1400 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1401 (apply #'make-hash-table args))
1402
1403 (defimplementation hash-table-weakness (hashtable)
1404 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1405 (sb-ext:hash-table-weakness hashtable))
1406
1407 #-win32
1408 (defimplementation save-image (filename &optional restart-function)
1409 (let ((pid (sb-posix:fork)))
1410 (cond ((= pid 0)
1411 (let ((args `(,filename
1412 ,@(if restart-function
1413 `((:toplevel ,restart-function))))))
1414 (apply #'sb-ext:save-lisp-and-die args)))
1415 (t
1416 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1417 (assert (= pid rpid))
1418 (assert (and (sb-posix:wifexited status)
1419 (zerop (sb-posix:wexitstatus status)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5