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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.246 - (show annotations)
Sun Aug 2 12:57:23 2009 UTC (4 years, 8 months ago) by trittweiler
Branch: MAIN
Changes since 1.245: +4 -1 lines
	* swank-backend.lisp (severity [type]): Allow :redefinition.

	* swank-sbcl.lisp (signal-compiler-condition): Tag redefinitions.

	* slime.el (slime-maybe-show-compilation-log): Do not show
	compilation log if each note describes just a redefinition.
	(slime-insert-compilation-log): Insert notes indented by 2
	spaces. Insert some more newlines so the buffer appears more
	structured.
	(slime-show-note-counts): Add :redefinition to ecase.
	(slime-redefinition-note-p): New.
	(slime-severity-label): Was unused. Adapted to be usable.
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 (sb-kernel:redefinition-warning
440 :redefinition)
441 (style-warning :style-warning)
442 (warning :warning)
443 (reader-error :read-error)
444 (error :error))
445 :short-message (brief-compiler-message-for-emacs condition)
446 :references (condition-references (real-condition condition))
447 :message (long-compiler-message-for-emacs condition context)
448 :location (compiler-note-location condition context))))
449
450 (defun real-condition (condition)
451 "Return the encapsulated condition or CONDITION itself."
452 (typecase condition
453 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
454 (t condition)))
455
456 (defun condition-references (condition)
457 (if (typep condition 'sb-int:reference-condition)
458 (externalize-reference
459 (sb-int:reference-condition-references condition))))
460
461 (defun compiler-note-location (condition context)
462 (flet ((bailout ()
463 (list :error "No error location available")))
464 (cond (context
465 (locate-compiler-note
466 (sb-c::compiler-error-context-file-name context)
467 (compiler-source-path context)
468 (sb-c::compiler-error-context-original-source context)))
469 ((typep condition 'reader-error)
470 (let* ((stream (stream-error-stream condition))
471 (file (pathname stream)))
472 (unless (open-stream-p stream)
473 (bailout))
474 (if (compiling-from-buffer-p file)
475 ;; The stream position for e.g. "comma not inside backquote"
476 ;; is at the character following the comma, :offset is 0-based,
477 ;; hence the 1-.
478 (make-location (list :buffer *buffer-name*)
479 (list :offset *buffer-offset*
480 (1- (file-position stream))))
481 (progn
482 (assert (compiling-from-file-p file))
483 ;; No 1- because :position is 1-based.
484 (make-location (list :file (namestring file))
485 (list :position (file-position stream)))))))
486 (t (bailout)))))
487
488 (defun compiling-from-buffer-p (filename)
489 (and (not (eq filename :lisp)) *buffer-name*))
490
491 (defun compiling-from-file-p (filename)
492 (and (pathnamep filename) (null *buffer-name*)))
493
494 (defun compiling-from-generated-code-p (filename source)
495 (and (eq filename :lisp) (stringp source)))
496
497 (defun locate-compiler-note (file source-path source)
498 (cond ((compiling-from-buffer-p file)
499 (make-location (list :buffer *buffer-name*)
500 (list :offset *buffer-offset*
501 (source-path-string-position
502 source-path *buffer-substring*))))
503 ((compiling-from-file-p file)
504 (make-location (list :file (namestring file))
505 (list :position (1+ (source-path-file-position
506 source-path file)))))
507 ((compiling-from-generated-code-p file source)
508 (make-location (list :source-form source)
509 (list :position 1)))
510 (t
511 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
512
513 (defun brief-compiler-message-for-emacs (condition)
514 "Briefly describe a compiler error for Emacs.
515 When Emacs presents the message it already has the source popped up
516 and the source form highlighted. This makes much of the information in
517 the error-context redundant."
518 (let ((sb-int:*print-condition-references* nil))
519 (princ-to-string condition)))
520
521 (defun long-compiler-message-for-emacs (condition error-context)
522 "Describe a compiler error for Emacs including context information."
523 (declare (type (or sb-c::compiler-error-context null) error-context))
524 (multiple-value-bind (enclosing source)
525 (if error-context
526 (values (sb-c::compiler-error-context-enclosing-source error-context)
527 (sb-c::compiler-error-context-source error-context)))
528 (let ((sb-int:*print-condition-references* nil))
529 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
530 enclosing source condition))))
531
532 (defun compiler-source-path (context)
533 "Return the source-path for the current compiler error.
534 Returns NIL if this cannot be determined by examining internal
535 compiler state."
536 (cond ((sb-c::node-p context)
537 (reverse
538 (sb-c::source-path-original-source
539 (sb-c::node-source-path context))))
540 ((sb-c::compiler-error-context-p context)
541 (reverse
542 (sb-c::compiler-error-context-original-source-path context)))))
543
544 (defimplementation call-with-compilation-hooks (function)
545 (declare (type function function))
546 (handler-bind
547 ;; N.B. Even though these handlers are called HANDLE-FOO they
548 ;; actually decline, i.e. the signalling of the original
549 ;; condition continues upward.
550 ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
551 (sb-c:compiler-error #'handle-notification-condition)
552 (sb-ext:compiler-note #'handle-notification-condition)
553 (warning #'handle-notification-condition))
554 (funcall function)))
555
556 (defun handle-file-compiler-termination (condition)
557 "Handle a condition that caused the file compiler to terminate."
558 (handle-notification-condition
559 (sb-int:encapsulated-condition condition)))
560
561 (defvar *trap-load-time-warnings* nil)
562
563 (defimplementation swank-compile-file (input-file output-file
564 load-p external-format)
565 (handler-case
566 (multiple-value-bind (output-file warnings-p failure-p)
567 (with-compilation-hooks ()
568 (compile-file input-file :output-file output-file
569 :external-format external-format))
570 (values output-file warnings-p
571 (or failure-p
572 (when load-p
573 ;; Cache the latest source file for definition-finding.
574 (source-cache-get input-file
575 (file-write-date input-file))
576 (not (load output-file))))))
577 ;; N.B. This comes through despite of WITH-COMPILATION-HOOKS.
578 (sb-c:fatal-compiler-error () (values nil nil t))))
579
580 ;;;; compile-string
581
582 ;;; We copy the string to a temporary file in order to get adequate
583 ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
584 ;;; which the previous approach using
585 ;;; (compile nil `(lambda () ,(read-from-string string)))
586 ;;; did not provide.
587
588 (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
589
590 (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
591 sb-alien:c-string
592 (dir sb-alien:c-string)
593 (prefix sb-alien:c-string))
594
595 )
596
597 (defun temp-file-name ()
598 "Return a temporary file name to compile strings into."
599 (tempnam nil nil))
600
601 (defun get-compiler-policy (default-policy)
602 (declare (ignorable default-policy))
603 #+#.(swank-backend::with-symbol 'restrict-compiler-policy 'sb-ext)
604 (remove-duplicates (append default-policy (sb-ext:restrict-compiler-policy))
605 :key #'car))
606
607 (defun set-compiler-policy (policy)
608 (declare (ignorable policy))
609 #+#.(swank-backend::with-symbol 'restrict-compiler-policy 'sb-ext)
610 (loop for (qual . value) in policy
611 do (sb-ext:restrict-compiler-policy qual value)))
612
613 (defimplementation swank-compile-string (string &key buffer position filename
614 policy)
615 (let ((*buffer-name* buffer)
616 (*buffer-offset* position)
617 (*buffer-substring* string)
618 (temp-file-name (temp-file-name))
619 (saved-policy (get-compiler-policy '((debug . 0) (speed . 0)))))
620 (when policy
621 (set-compiler-policy policy))
622 (flet ((load-it (filename)
623 (when filename (load filename)))
624 (compile-it (cont)
625 (with-compilation-hooks ()
626 (with-compilation-unit
627 (:source-plist (list :emacs-buffer buffer
628 :emacs-filename filename
629 :emacs-string string
630 :emacs-position position))
631 (funcall cont (compile-file temp-file-name))))))
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 (pos (if form-path
742 (with-debootstrapping
743 (source-path-string-position form-path emacs-string))
744 character-offset))
745 (snippet (string-path-snippet emacs-string form-path pos)))
746 (make-location `(:buffer ,emacs-buffer)
747 `(:offset ,emacs-position ,pos)
748 `(:snippet ,snippet))))
749 ((not pathname)
750 `(:error ,(format nil "Source definition of ~A ~A not found"
751 (string-downcase type) name)))
752 (t
753 (let* ((namestring (namestring (translate-logical-pathname pathname)))
754 (pos (source-file-position namestring file-write-date form-path
755 character-offset))
756 (snippet (source-hint-snippet namestring file-write-date pos)))
757 (make-location `(:file ,namestring)
758 ;; /file positions/ in Common Lisp start
759 ;; from 0, in Emacs they start from 1.
760 `(:position ,(1+ pos))
761 `(:snippet ,snippet))))))))
762
763 (defun string-path-snippet (string form-path position)
764 (if (null form-path)
765 (read-snippet-from-string string)
766 ;; If we have a form-path, use it to derive a more accurate
767 ;; snippet, so that we can point to the individual form rather
768 ;; than just the toplevel form.
769 (multiple-value-bind (data end)
770 (let ((*read-suppress* t))
771 (read-from-string string nil nil :start position))
772 (declare (ignore data))
773 (subseq string position (min end *source-snippet-size*)))))
774
775 (defun source-file-position (filename write-date form-path character-offset)
776 (let ((source (get-source-code filename write-date))
777 (*readtable* (guess-readtable-for-filename filename)))
778 (with-debootstrapping
779 (if form-path
780 (source-path-string-position form-path source)
781 (or character-offset 0)))))
782
783 (defun source-hint-snippet (filename write-date position)
784 (read-snippet-from-string (get-source-code filename write-date) position))
785
786 (defun function-source-location (function &optional name)
787 (declare (type function function))
788 (let ((location (sb-introspect:find-definition-source function)))
789 (make-definition-source-location location :function name)))
790
791 (defun safe-function-source-location (fun name)
792 (if *debug-definition-finding*
793 (function-source-location fun name)
794 (handler-case (function-source-location fun name)
795 (error (e)
796 (list :error (format nil "Error: ~A" e))))))
797
798 (defimplementation describe-symbol-for-emacs (symbol)
799 "Return a plist describing SYMBOL.
800 Return NIL if the symbol is unbound."
801 (let ((result '()))
802 (flet ((doc (kind)
803 (or (documentation symbol kind) :not-documented))
804 (maybe-push (property value)
805 (when value
806 (setf result (list* property value result)))))
807 (maybe-push
808 :variable (multiple-value-bind (kind recorded-p)
809 (sb-int:info :variable :kind symbol)
810 (declare (ignore kind))
811 (if (or (boundp symbol) recorded-p)
812 (doc 'variable))))
813 (when (fboundp symbol)
814 (maybe-push
815 (cond ((macro-function symbol) :macro)
816 ((special-operator-p symbol) :special-operator)
817 ((typep (fdefinition symbol) 'generic-function)
818 :generic-function)
819 (t :function))
820 (doc 'function)))
821 (maybe-push
822 :setf (if (or (sb-int:info :setf :inverse symbol)
823 (sb-int:info :setf :expander symbol))
824 (doc 'setf)))
825 (maybe-push
826 :type (if (sb-int:info :type :kind symbol)
827 (doc 'type)))
828 result)))
829
830 (defimplementation describe-definition (symbol type)
831 (case type
832 (:variable
833 (describe symbol))
834 (:function
835 (describe (symbol-function symbol)))
836 (:setf
837 (describe (or (sb-int:info :setf :inverse symbol)
838 (sb-int:info :setf :expander symbol))))
839 (:class
840 (describe (find-class symbol)))
841 (:type
842 (describe (sb-kernel:values-specifier-type symbol)))))
843
844 #+#.(swank-backend::sbcl-with-xref-p)
845 (progn
846 (defmacro defxref (name)
847 `(defimplementation ,name (what)
848 (sanitize-xrefs
849 (mapcar #'source-location-for-xref-data
850 (,(find-symbol (symbol-name name) "SB-INTROSPECT")
851 what)))))
852 (defxref who-calls)
853 (defxref who-binds)
854 (defxref who-sets)
855 (defxref who-references)
856 (defxref who-macroexpands)
857 #+#.(swank-backend::with-symbol 'who-specializes 'sb-introspect)
858 (defxref who-specializes))
859
860 (defun source-location-for-xref-data (xref-data)
861 (let ((name (car xref-data))
862 (source-location (cdr xref-data)))
863 (list name
864 (handler-case (make-definition-source-location source-location
865 'function
866 name)
867 (error (e)
868 (list :error (format nil "Error: ~A" e)))))))
869
870 (defimplementation list-callers (symbol)
871 (let ((fn (fdefinition symbol)))
872 (sanitize-xrefs
873 (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
874
875 (defimplementation list-callees (symbol)
876 (let ((fn (fdefinition symbol)))
877 (sanitize-xrefs
878 (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
879
880 (defun sanitize-xrefs (xrefs)
881 (remove-duplicates
882 (remove-if (lambda (f)
883 (member f (ignored-xref-function-names)))
884 (loop for entry in xrefs
885 for name = (car entry)
886 collect (if (and (consp name)
887 (member (car name)
888 '(sb-pcl::fast-method
889 sb-pcl::slow-method
890 sb-pcl::method)))
891 (cons (cons 'defmethod (cdr name))
892 (cdr entry))
893 entry))
894 :key #'car)
895 :test (lambda (a b)
896 (and (eq (first a) (first b))
897 (equal (second a) (second b))))))
898
899 (defun ignored-xref-function-names ()
900 #-#.(swank-backend::sbcl-with-new-stepper-p)
901 '(nil sb-c::step-form sb-c::step-values)
902 #+#.(swank-backend::sbcl-with-new-stepper-p)
903 '(nil))
904
905 (defun function-dspec (fn)
906 "Describe where the function FN was defined.
907 Return a list of the form (NAME LOCATION)."
908 (let ((name (sb-kernel:%fun-name fn)))
909 (list name (safe-function-source-location fn name))))
910
911 ;;; macroexpansion
912
913 (defimplementation macroexpand-all (form)
914 (let ((sb-walker:*walk-form-expand-macros-p* t))
915 (sb-walker:walk-form form)))
916
917
918 ;;; Debugging
919
920 (defvar *sldb-stack-top*)
921
922 (defun make-invoke-debugger-hook (hook)
923 #'(lambda (condition old-hook)
924 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
925 ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
926 ;; run when it was established locally by a user (i.e. changed meanwhile.)
927 (if *debugger-hook*
928 (funcall *debugger-hook* condition old-hook)
929 (funcall hook condition old-hook))))
930
931 (defimplementation install-debugger-globally (function)
932 (setq *debugger-hook* function)
933 (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
934
935 (defimplementation condition-extras (condition)
936 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
937 ((typep condition 'sb-impl::step-form-condition)
938 `((:show-frame-source 0)))
939 ((typep condition 'sb-int:reference-condition)
940 (let ((refs (sb-int:reference-condition-references condition)))
941 (if refs
942 `((:references ,(externalize-reference refs))))))))
943
944 (defun externalize-reference (ref)
945 (etypecase ref
946 (null nil)
947 (cons (cons (externalize-reference (car ref))
948 (externalize-reference (cdr ref))))
949 ((or string number) ref)
950 (symbol
951 (cond ((eq (symbol-package ref) (symbol-package :test))
952 ref)
953 (t (symbol-name ref))))))
954
955 (defimplementation call-with-debugging-environment (debugger-loop-fn)
956 (declare (type function debugger-loop-fn))
957 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
958 (sb-debug:*stack-top-hint* nil))
959 (handler-bind ((sb-di:debug-condition
960 (lambda (condition)
961 (signal (make-condition
962 'sldb-condition
963 :original-condition condition)))))
964 (funcall debugger-loop-fn))))
965
966 #+#.(swank-backend::sbcl-with-new-stepper-p)
967 (progn
968 (defimplementation activate-stepping (frame)
969 (declare (ignore frame))
970 (sb-impl::enable-stepping))
971 (defimplementation sldb-stepper-condition-p (condition)
972 (typep condition 'sb-ext:step-form-condition))
973 (defimplementation sldb-step-into ()
974 (invoke-restart 'sb-ext:step-into))
975 (defimplementation sldb-step-next ()
976 (invoke-restart 'sb-ext:step-next))
977 (defimplementation sldb-step-out ()
978 (invoke-restart 'sb-ext:step-out)))
979
980 (defimplementation call-with-debugger-hook (hook fun)
981 (let ((*debugger-hook* hook)
982 (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
983 #+#.(swank-backend::sbcl-with-new-stepper-p)
984 (sb-ext:*stepper-hook*
985 (lambda (condition)
986 (typecase condition
987 (sb-ext:step-form-condition
988 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
989 (sb-impl::invoke-debugger condition)))))))
990 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
991 (sb-ext:step-condition #'sb-impl::invoke-stepper))
992 (funcall fun))))
993
994 (defun nth-frame (index)
995 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
996 (i index (1- i)))
997 ((zerop i) frame)))
998
999 (defimplementation compute-backtrace (start end)
1000 "Return a list of frames starting with frame number START and
1001 continuing to frame number END or, if END is nil, the last frame on the
1002 stack."
1003 (let ((end (or end most-positive-fixnum)))
1004 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1005 for i from start below end
1006 while f collect f)))
1007
1008 (defimplementation print-frame (frame stream)
1009 (sb-debug::print-frame-call frame stream))
1010
1011 (defimplementation frame-restartable-p (frame)
1012 #+#.(swank-backend::sbcl-with-restart-frame)
1013 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1014
1015 ;;;; Code-location -> source-location translation
1016
1017 ;;; If debug-block info is avaibale, we determine the file position of
1018 ;;; the source-path for a code-location. If the code was compiled
1019 ;;; with C-c C-c, we have to search the position in the source string.
1020 ;;; If there's no debug-block info, we return the (less precise)
1021 ;;; source-location of the corresponding function.
1022
1023 (defun code-location-source-location (code-location)
1024 (let* ((dsource (sb-di:code-location-debug-source code-location))
1025 (plist (sb-c::debug-source-plist dsource)))
1026 (if (getf plist :emacs-buffer)
1027 (emacs-buffer-source-location code-location plist)
1028 #+#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
1029 (ecase (sb-di:debug-source-from dsource)
1030 (:file (file-source-location code-location))
1031 (:lisp (lisp-source-location code-location)))
1032 #-#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
1033 (if (sb-di:debug-source-namestring dsource)
1034 (file-source-location code-location)
1035 (lisp-source-location code-location)))))
1036
1037 ;;; FIXME: The naming policy of source-location functions is a bit
1038 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1039 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1040 ;;; which returns the source location for a _code-location_.
1041 ;;;
1042 ;;; Maybe these should be named code-location-file-source-location,
1043 ;;; etc, turned into generic functions, or something. In the very
1044 ;;; least the names should indicate the main entry point vs. helper
1045 ;;; status.
1046
1047 (defun file-source-location (code-location)
1048 (if (code-location-has-debug-block-info-p code-location)
1049 (source-file-source-location code-location)
1050 (fallback-source-location code-location)))
1051
1052 (defun fallback-source-location (code-location)
1053 (let ((fun (code-location-debug-fun-fun code-location)))
1054 (cond (fun (function-source-location fun))
1055 (t (error "Cannot find source location for: ~A " code-location)))))
1056
1057 (defun lisp-source-location (code-location)
1058 (let ((source (prin1-to-string
1059 (sb-debug::code-location-source-form code-location 100))))
1060 (make-location `(:source-form ,source) '(:position 1))))
1061
1062 (defun emacs-buffer-source-location (code-location plist)
1063 (if (code-location-has-debug-block-info-p code-location)
1064 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1065 &allow-other-keys)
1066 plist
1067 (let* ((pos (string-source-position code-location emacs-string))
1068 (snipped (read-snippet-from-string emacs-string pos)))
1069 (make-location `(:buffer ,emacs-buffer)
1070 `(:offset ,emacs-position ,pos)
1071 `(:snippet ,snipped))))
1072 (fallback-source-location code-location)))
1073
1074 (defun source-file-source-location (code-location)
1075 (let* ((code-date (code-location-debug-source-created code-location))
1076 (filename (code-location-debug-source-name code-location))
1077 (*readtable* (guess-readtable-for-filename filename))
1078 (source-code (get-source-code filename code-date)))
1079 (with-debootstrapping
1080 (with-input-from-string (s source-code)
1081 (let* ((pos (stream-source-position code-location s))
1082 (snippet (read-snippet s pos)))
1083 (make-location `(:file ,filename)
1084 `(:position ,pos)
1085 `(:snippet ,snippet)))))))
1086
1087 (defun code-location-debug-source-name (code-location)
1088 (namestring (truename (#+#.(swank-backend::with-symbol
1089 'debug-source-name 'sb-di)
1090 sb-c::debug-source-name
1091 #-#.(swank-backend::with-symbol
1092 'debug-source-name 'sb-di)
1093 sb-c::debug-source-namestring
1094 (sb-di::code-location-debug-source code-location)))))
1095
1096 (defun code-location-debug-source-created (code-location)
1097 (sb-c::debug-source-created
1098 (sb-di::code-location-debug-source code-location)))
1099
1100 (defun code-location-debug-fun-fun (code-location)
1101 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1102
1103 (defun code-location-has-debug-block-info-p (code-location)
1104 (handler-case
1105 (progn (sb-di:code-location-debug-block code-location)
1106 t)
1107 (sb-di:no-debug-blocks () nil)))
1108
1109 (defun stream-source-position (code-location stream)
1110 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1111 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1112 (form-number (sb-di::code-location-form-number cloc)))
1113 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1114 (let* ((path-table (sb-di::form-number-translations tlf 0))
1115 (path (cond ((<= (length path-table) form-number)
1116 (warn "inconsistent form-number-translations")
1117 (list 0))
1118 (t
1119 (reverse (cdr (aref path-table form-number)))))))
1120 (source-path-source-position path tlf pos-map)))))
1121
1122 (defun string-source-position (code-location string)
1123 (with-input-from-string (s string)
1124 (stream-source-position code-location s)))
1125
1126 ;;; source-path-file-position and friends are in swank-source-path-parser
1127
1128 (defun safe-source-location-for-emacs (code-location)
1129 (if *debug-definition-finding*
1130 (code-location-source-location code-location)
1131 (handler-case (code-location-source-location code-location)
1132 (error (c) (list :error (format nil "~A" c))))))
1133
1134 (defimplementation frame-source-location (index)
1135 (safe-source-location-for-emacs
1136 (sb-di:frame-code-location (nth-frame index))))
1137
1138 (defun frame-debug-vars (frame)
1139 "Return a vector of debug-variables in frame."
1140 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1141
1142 (defun debug-var-value (var frame location)
1143 (ecase (sb-di:debug-var-validity var location)
1144 (:valid (sb-di:debug-var-value var frame))
1145 ((:invalid :unknown) ':<not-available>)))
1146
1147 (defimplementation frame-locals (index)
1148 (let* ((frame (nth-frame index))
1149 (loc (sb-di:frame-code-location frame))
1150 (vars (frame-debug-vars frame)))
1151 (loop for v across vars collect
1152 (list :name (sb-di:debug-var-symbol v)
1153 :id (sb-di:debug-var-id v)
1154 :value (debug-var-value v frame loc)))))
1155
1156 (defimplementation frame-var-value (frame var)
1157 (let* ((frame (nth-frame frame))
1158 (dvar (aref (frame-debug-vars frame) var)))
1159 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
1160
1161 (defimplementation frame-catch-tags (index)
1162 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1163
1164 (defimplementation eval-in-frame (form index)
1165 (let ((frame (nth-frame index)))
1166 (funcall (the function
1167 (sb-di:preprocess-for-eval form
1168 (sb-di:frame-code-location frame)))
1169 frame)))
1170
1171 #+#.(swank-backend::sbcl-with-restart-frame)
1172 (progn
1173 (defimplementation return-from-frame (index form)
1174 (let* ((frame (nth-frame index)))
1175 (cond ((sb-debug:frame-has-debug-tag-p frame)
1176 (let ((values (multiple-value-list (eval-in-frame form index))))
1177 (sb-debug:unwind-to-frame-and-call frame
1178 (lambda ()
1179 (values-list values)))))
1180 (t (format nil "Cannot return from frame: ~S" frame)))))
1181
1182 (defimplementation restart-frame (index)
1183 (let* ((frame (nth-frame index)))
1184 (cond ((sb-debug:frame-has-debug-tag-p frame)
1185 (let* ((call-list (sb-debug::frame-call-as-list frame))
1186 (fun (fdefinition (car call-list)))
1187 (thunk (lambda ()
1188 ;; Ensure that the thunk gets tail-call-optimized
1189 (declare (optimize (debug 1)))
1190 (apply fun (cdr call-list)))))
1191 (sb-debug:unwind-to-frame-and-call frame thunk)))
1192 (t (format nil "Cannot restart frame: ~S" frame))))))
1193
1194 ;; FIXME: this implementation doesn't unwind the stack before
1195 ;; re-invoking the function, but it's better than no implementation at
1196 ;; all.
1197 #-#.(swank-backend::sbcl-with-restart-frame)
1198 (progn
1199 (defun sb-debug-catch-tag-p (tag)
1200 (and (symbolp tag)
1201 (not (symbol-package tag))
1202 (string= tag :sb-debug-catch-tag)))
1203
1204 (defimplementation return-from-frame (index form)
1205 (let* ((frame (nth-frame index))
1206 (probe (assoc-if #'sb-debug-catch-tag-p
1207 (sb-di::frame-catches frame))))
1208 (cond (probe (throw (car probe) (eval-in-frame form index)))
1209 (t (format nil "Cannot return from frame: ~S" frame)))))
1210
1211 (defimplementation restart-frame (index)
1212 (let ((frame (nth-frame index)))
1213 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1214
1215 ;;;;; reference-conditions
1216
1217 (defimplementation format-sldb-condition (condition)
1218 (let ((sb-int:*print-condition-references* nil))
1219 (princ-to-string condition)))
1220
1221
1222 ;;;; Profiling
1223
1224 (defimplementation profile (fname)
1225 (when fname (eval `(sb-profile:profile ,fname))))
1226
1227 (defimplementation unprofile (fname)
1228 (when fname (eval `(sb-profile:unprofile ,fname))))
1229
1230 (defimplementation unprofile-all ()
1231 (sb-profile:unprofile)
1232 "All functions unprofiled.")
1233
1234 (defimplementation profile-report ()
1235 (sb-profile:report))
1236
1237 (defimplementation profile-reset ()
1238 (sb-profile:reset)
1239 "Reset profiling counters.")
1240
1241 (defimplementation profiled-functions ()
1242 (sb-profile:profile))
1243
1244 (defimplementation profile-package (package callers methods)
1245 (declare (ignore callers methods))
1246 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1247
1248
1249 ;;;; Inspector
1250
1251 (defmethod emacs-inspect ((o t))
1252 (cond ((sb-di::indirect-value-cell-p o)
1253 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1254 (t
1255 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1256 (list* (format nil "~a~%" text)
1257 (if label
1258 (loop for (l . v) in parts
1259 append (label-value-line l v))
1260 (loop for value in parts for i from 0
1261 append (label-value-line i value))))))))
1262
1263 (defmethod emacs-inspect ((o function))
1264 (let ((header (sb-kernel:widetag-of o)))
1265 (cond ((= header sb-vm:simple-fun-header-widetag)
1266 (label-value-line*
1267 (:name (sb-kernel:%simple-fun-name o))
1268 (:arglist (sb-kernel:%simple-fun-arglist o))
1269 (:self (sb-kernel:%simple-fun-self o))
1270 (:next (sb-kernel:%simple-fun-next o))
1271 (:type (sb-kernel:%simple-fun-type o))
1272 (:code (sb-kernel:fun-code-header o))))
1273 ((= header sb-vm:closure-header-widetag)
1274 (append
1275 (label-value-line :function (sb-kernel:%closure-fun o))
1276 `("Closed over values:" (:newline))
1277 (loop for i below (1- (sb-kernel:get-closure-length o))
1278 append (label-value-line
1279 i (sb-kernel:%closure-index-ref o i)))))
1280 (t (call-next-method o)))))
1281
1282 (defmethod emacs-inspect ((o sb-kernel:code-component))
1283 (append
1284 (label-value-line*
1285 (:code-size (sb-kernel:%code-code-size o))
1286 (:entry-points (sb-kernel:%code-entry-points o))
1287 (:debug-info (sb-kernel:%code-debug-info o))
1288 (:trace-table-offset (sb-kernel:code-header-ref
1289 o sb-vm:code-trace-table-offset-slot)))
1290 `("Constants:" (:newline))
1291 (loop for i from sb-vm:code-constants-offset
1292 below (sb-kernel:get-header-data o)
1293 append (label-value-line i (sb-kernel:code-header-ref o i)))
1294 `("Code:" (:newline)
1295 , (with-output-to-string (s)
1296 (cond ((sb-kernel:%code-debug-info o)
1297 (sb-disassem:disassemble-code-component o :stream s))
1298 (t
1299 (sb-disassem:disassemble-memory
1300 (sb-disassem::align
1301 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1302 sb-vm:lowtag-mask)
1303 (* sb-vm:code-constants-offset
1304 sb-vm:n-word-bytes))
1305 (ash 1 sb-vm:n-lowtag-bits))
1306 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1307 :stream s)))))))
1308
1309 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1310 (label-value-line*
1311 (:value (sb-ext:weak-pointer-value o))))
1312
1313 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1314 (label-value-line*
1315 (:name (sb-kernel:fdefn-name o))
1316 (:function (sb-kernel:fdefn-fun o))))
1317
1318 (defmethod emacs-inspect :around ((o generic-function))
1319 (append
1320 (call-next-method)
1321 (label-value-line*
1322 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1323 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1324 )))
1325
1326
1327 ;;;; Multiprocessing
1328
1329 #+(and sb-thread
1330 #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1331 (progn
1332 (defvar *thread-id-counter* 0)
1333
1334 (defvar *thread-id-counter-lock*
1335 (sb-thread:make-mutex :name "thread id counter lock"))
1336
1337 (defun next-thread-id ()
1338 (sb-thread:with-mutex (*thread-id-counter-lock*)
1339 (incf *thread-id-counter*)))
1340
1341 (defparameter *thread-id-map* (make-hash-table))
1342
1343 ;; This should be a thread -> id map but as weak keys are not
1344 ;; supported it is id -> map instead.
1345 (defvar *thread-id-map-lock*
1346 (sb-thread:make-mutex :name "thread id map lock"))
1347
1348 (defimplementation spawn (fn &key name)
1349 (sb-thread:make-thread fn :name name))
1350
1351 (defimplementation thread-id (thread)
1352 (block thread-id
1353 (sb-thread:with-mutex (*thread-id-map-lock*)
1354 (loop for id being the hash-key in *thread-id-map*
1355 using (hash-value thread-pointer)
1356 do
1357 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1358 (cond ((null maybe-thread)
1359 ;; the value is gc'd, remove it manually
1360 (remhash id *thread-id-map*))
1361 ((eq thread maybe-thread)
1362 (return-from thread-id id)))))
1363 ;; lazy numbering
1364 (let ((id (next-thread-id)))
1365 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1366 id))))
1367
1368 (defimplementation find-thread (id)
1369 (sb-thread:with-mutex (*thread-id-map-lock*)
1370 (let ((thread-pointer (gethash id *thread-id-map*)))
1371 (if thread-pointer
1372 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1373 (if maybe-thread
1374 maybe-thread
1375 ;; the value is gc'd, remove it manually
1376 (progn
1377 (remhash id *thread-id-map*)
1378 nil)))
1379 nil))))
1380
1381 (defimplementation thread-name (thread)
1382 ;; sometimes the name is not a string (e.g. NIL)
1383 (princ-to-string (sb-thread:thread-name thread)))
1384
1385 (defimplementation thread-status (thread)
1386 (if (sb-thread:thread-alive-p thread)
1387 "RUNNING"
1388 "STOPPED"))
1389 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1390 (progn
1391 (defparameter *thread-description-map*
1392 (make-weak-key-hash-table))
1393
1394 (defvar *thread-descr-map-lock*
1395 (sb-thread:make-mutex :name "thread description map lock"))
1396
1397 (defimplementation thread-description (thread)
1398 (sb-thread:with-mutex (*thread-descr-map-lock*)
1399 (or (gethash thread *thread-description-map*)
1400 (short-backtrace thread 6 10))))
1401
1402 (defimplementation set-thread-description (thread description)
1403 (sb-thread:with-mutex (*thread-descr-map-lock*)
1404 (setf (gethash thread *thread-description-map*) description)))
1405
1406 (defun short-backtrace (thread start count)
1407 (let ((self (current-thread))
1408 (tag (get-internal-real-time)))
1409 (sb-thread:interrupt-thread
1410 thread
1411 (lambda ()
1412 (let* ((frames (nthcdr start (sb-debug:backtrace-as-list count))))
1413 (send self (cons tag frames)))))
1414 (handler-case
1415 (sb-ext:with-timeout 0.1
1416 (let ((frames (cdr (receive-if (lambda (msg)
1417 (eq (car msg) tag)))))
1418 (*print-pretty* nil))
1419 (format nil "~{~a~^ <- ~}" (mapcar #'car frames))))
1420 (sb-ext:timeout () ""))))
1421
1422 )
1423
1424 (defimplementation make-lock (&key name)
1425 (sb-thread:make-mutex :name name))
1426
1427 (defimplementation call-with-lock-held (lock function)
1428 (declare (type function function))
1429 (sb-thread:with-recursive-lock (lock) (funcall function)))
1430
1431 (defimplementation current-thread ()
1432 sb-thread:*current-thread*)
1433
1434 (defimplementation all-threads ()
1435 (sb-thread:list-all-threads))
1436
1437 (defimplementation interrupt-thread (thread fn)
1438 (sb-thread:interrupt-thread thread fn))
1439
1440 (defimplementation kill-thread (thread)
1441 (sb-thread:terminate-thread thread))
1442
1443 (defimplementation thread-alive-p (thread)
1444 (sb-thread:thread-alive-p thread))
1445
1446 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1447 (defvar *mailboxes* (list))
1448 (declaim (type list *mailboxes*))
1449
1450 (defstruct (mailbox (:conc-name mailbox.))
1451 thread
1452 (mutex (sb-thread:make-mutex))
1453 (waitqueue (sb-thread:make-waitqueue))
1454 (queue '() :type list))
1455
1456 (defun mailbox (thread)
1457 "Return THREAD's mailbox."
1458 (sb-thread:with-mutex (*mailbox-lock*)
1459 (or (find thread *mailboxes* :key #'mailbox.thread)
1460 (let ((mb (make-mailbox :thread thread)))
1461 (push mb *mailboxes*)
1462 mb))))
1463
1464 (defimplementation send (thread message)
1465 (let* ((mbox (mailbox thread))
1466 (mutex (mailbox.mutex mbox)))
1467 (sb-thread:with-mutex (mutex)
1468 (setf (mailbox.queue mbox)
1469 (nconc (mailbox.queue mbox) (list message)))
1470 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1471
1472 (defimplementation receive-if (test &optional timeout)
1473 (let* ((mbox (mailbox (current-thread)))
1474 (mutex (mailbox.mutex mbox)))
1475 (assert (or (not timeout) (eq timeout t)))
1476 (loop
1477 (check-slime-interrupts)
1478 (sb-thread:with-mutex (mutex)
1479 (let* ((q (mailbox.queue mbox))
1480 (tail (member-if test q)))
1481 (when tail
1482 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1483 (return (car tail))))
1484 (when (eq timeout t) (return (values nil t)))
1485 ;; FIXME: with-timeout doesn't work properly on Darwin
1486 #+linux
1487 (handler-case (sb-ext:with-timeout 0.2
1488 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1489 mutex))
1490 (sb-ext:timeout ()))
1491 #-linux
1492 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1493 mutex)))))
1494 )
1495
1496 (defimplementation quit-lisp ()
1497 #+sb-thread
1498 (dolist (thread (remove (current-thread) (all-threads)))
1499 (ignore-errors (sb-thread:interrupt-thread
1500 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1501 (sb-ext:quit))
1502
1503
1504
1505 ;;Trace implementations
1506 ;;In SBCL, we have:
1507 ;; (trace <name>)
1508 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1509 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1510 ;; <name> can be a normal name or a (setf name)
1511
1512 (defun toggle-trace-aux (fspec &rest args)
1513 (cond ((member fspec (eval '(trace)) :test #'equal)
1514 (eval `(untrace ,fspec))
1515 (format nil "~S is now untraced." fspec))
1516 (t
1517 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1518 (format nil "~S is now traced." fspec))))
1519
1520 (defun process-fspec (fspec)
1521 (cond ((consp fspec)
1522 (ecase (first fspec)
1523 ((:defun :defgeneric) (second fspec))
1524 ((:defmethod) `(method ,@(rest fspec)))
1525 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1526 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1527 (t
1528 fspec)))
1529
1530 (defimplementation toggle-trace (spec)
1531 (ecase (car spec)
1532 ((setf)
1533 (toggle-trace-aux spec))
1534 ((:defmethod)
1535 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1536 ((:defgeneric)
1537 (toggle-trace-aux (second spec) :methods t))
1538 ((:call)
1539 (destructuring-bind (caller callee) (cdr spec)
1540 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1541
1542 ;;; Weak datastructures
1543
1544 (defimplementation make-weak-key-hash-table (&rest args)
1545 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1546 (apply #'make-hash-table :weakness :key args)
1547 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1548 (apply #'make-hash-table args))
1549
1550 (defimplementation make-weak-value-hash-table (&rest args)
1551 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1552 (apply #'make-hash-table :weakness :value args)
1553 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1554 (apply #'make-hash-table args))
1555
1556 (defimplementation hash-table-weakness (hashtable)
1557 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1558 (sb-ext:hash-table-weakness hashtable))
1559
1560 #-win32
1561 (defimplementation save-image (filename &optional restart-function)
1562 (let ((pid (sb-posix:fork)))
1563 (cond ((= pid 0)
1564 (let ((args `(,filename
1565 ,@(if restart-function
1566 `((:toplevel ,restart-function))))))
1567 (apply #'sb-ext:save-lisp-and-die args)))
1568 (t
1569 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1570 (assert (= pid rpid))
1571 (assert (and (sb-posix:wifexited status)
1572 (zerop (sb-posix:wexitstatus status)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5