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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.233 - (show annotations)
Tue Jan 27 14:56:14 2009 UTC (5 years, 2 months ago) by trittweiler
Branch: MAIN
Changes since 1.232: +14 -27 lines
	* swank-backend.lisp (with-symbol): New function, to be used with #+.

	* swank-sbcl.lisp: Use WITH-SYMBOL and get rid of SBCL-WITH-SYMBOL.

	* swank-openmcl.lisp (macroexpand-all): Implement it.

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

  ViewVC Help
Powered by ViewVC 1.1.5