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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5