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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5