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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5