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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.250 - (show annotations)
Wed Sep 23 11:20:02 2009 UTC (4 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.249: +5 -3 lines
* swank-sbcl.lisp (receive-if): Bind *break-on-signals* to
nil before using with-timeout.
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 (unless failurep
635 (funcall cont output-file)))))))
636 (with-open-file (s temp-file-name :direction :output :if-exists :error)
637 (write-string string s))
638 (unwind-protect
639 (if *trap-load-time-warnings*
640 (compile-it #'load-it)
641 (load-it (compile-it #'identity)))
642 (ignore-errors
643 (set-compiler-policy saved-policy)
644 (delete-file temp-file-name)
645 (delete-file (compile-file-pathname temp-file-name)))))))
646
647 ;;;; Definitions
648
649 (defvar *debug-definition-finding* nil
650 "When true don't handle errors while looking for definitions.
651 This is useful when debugging the definition-finding code.")
652
653 (defparameter *definition-types*
654 '(:variable defvar
655 :constant defconstant
656 :type deftype
657 :symbol-macro define-symbol-macro
658 :macro defmacro
659 :compiler-macro define-compiler-macro
660 :function defun
661 :generic-function defgeneric
662 :method defmethod
663 :setf-expander define-setf-expander
664 :structure defstruct
665 :condition define-condition
666 :class defclass
667 :method-combination define-method-combination
668 :package defpackage
669 :transform :deftransform
670 :optimizer :defoptimizer
671 :vop :define-vop
672 :source-transform :define-source-transform)
673 "Map SB-INTROSPECT definition type names to Slime-friendly forms")
674
675 (defun definition-specifier (type name)
676 "Return a pretty specifier for NAME representing a definition of type TYPE."
677 (if (and (symbolp name)
678 (eq type :function)
679 (sb-int:info :function :ir1-convert name))
680 :def-ir1-translator
681 (getf *definition-types* type)))
682
683
684 (defimplementation find-definitions (name)
685 (loop for type in *definition-types* by #'cddr
686 for locations = (sb-introspect:find-definition-sources-by-name
687 name type)
688 append (loop for source-location in locations collect
689 (make-source-location-specification type name
690 source-location))))
691
692 (defimplementation find-source-location (obj)
693 (flet ((general-type-of (obj)
694 (typecase obj
695 (method :method)
696 (generic-function :generic-function)
697 (function :function)
698 (structure-class :structure-class)
699 (class :class)
700 (method-combination :method-combination)
701 (package :package)
702 (condition :condition)
703 (structure-object :structure-object)
704 (standard-object :standard-object)
705 (t :thing)))
706 (to-string (obj)
707 (typecase obj
708 (package (princ-to-string obj)) ; Packages are possibly named entities.
709 ((or structure-object standard-object condition)
710 (with-output-to-string (s)
711 (print-unreadable-object (obj s :type t :identity t))))
712 (t (princ-to-string obj)))))
713 (handler-case
714 (make-definition-source-location
715 (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))
716 (error (e)
717 (list :error (format nil "Error: ~A" e))))))
718
719
720 (defun make-source-location-specification (type name source-location)
721 (list (make-dspec type name source-location)
722 (if *debug-definition-finding*
723 (make-definition-source-location source-location type name)
724 (handler-case
725 (make-definition-source-location source-location type name)
726 (error (e)
727 (list :error (format nil "Error: ~A" e)))))))
728
729 (defun make-dspec (type name source-location)
730 (list* (definition-specifier type name)
731 name
732 (sb-introspect::definition-source-description source-location)))
733
734 (defun make-definition-source-location (definition-source type name)
735 (with-struct (sb-introspect::definition-source-
736 pathname form-path character-offset plist
737 file-write-date)
738 definition-source
739 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
740 emacs-string &allow-other-keys)
741 plist
742 (cond
743 (emacs-buffer
744 (let* ((*readtable* (guess-readtable-for-filename emacs-directory))
745 (pos (if form-path
746 (with-debootstrapping
747 (source-path-string-position form-path emacs-string))
748 character-offset))
749 (snippet (string-path-snippet emacs-string form-path pos)))
750 (make-location `(:buffer ,emacs-buffer)
751 `(:offset ,emacs-position ,pos)
752 `(:snippet ,snippet))))
753 ((not pathname)
754 `(:error ,(format nil "Source definition of ~A ~A not found"
755 (string-downcase type) name)))
756 (t
757 (let* ((namestring (namestring (translate-logical-pathname pathname)))
758 (pos (source-file-position namestring file-write-date form-path
759 character-offset))
760 (snippet (source-hint-snippet namestring file-write-date pos)))
761 (make-location `(:file ,namestring)
762 ;; /file positions/ in Common Lisp start
763 ;; from 0, in Emacs they start from 1.
764 `(:position ,(1+ pos))
765 `(:snippet ,snippet))))))))
766
767 (defun string-path-snippet (string form-path position)
768 (if (null form-path)
769 (read-snippet-from-string string)
770 ;; If we have a form-path, use it to derive a more accurate
771 ;; snippet, so that we can point to the individual form rather
772 ;; than just the toplevel form.
773 (multiple-value-bind (data end)
774 (let ((*read-suppress* t))
775 (read-from-string string nil nil :start position))
776 (declare (ignore data))
777 (subseq string position (min end *source-snippet-size*)))))
778
779 (defun source-file-position (filename write-date form-path character-offset)
780 (let ((source (get-source-code filename write-date))
781 (*readtable* (guess-readtable-for-filename filename)))
782 (with-debootstrapping
783 (if form-path
784 (source-path-string-position form-path source)
785 (or character-offset 0)))))
786
787 (defun source-hint-snippet (filename write-date position)
788 (read-snippet-from-string (get-source-code filename write-date) position))
789
790 (defun function-source-location (function &optional name)
791 (declare (type function function))
792 (let ((location (sb-introspect:find-definition-source function)))
793 (make-definition-source-location location :function name)))
794
795 (defun safe-function-source-location (fun name)
796 (if *debug-definition-finding*
797 (function-source-location fun name)
798 (handler-case (function-source-location fun name)
799 (error (e)
800 (list :error (format nil "Error: ~A" e))))))
801
802 (defimplementation describe-symbol-for-emacs (symbol)
803 "Return a plist describing SYMBOL.
804 Return NIL if the symbol is unbound."
805 (let ((result '()))
806 (flet ((doc (kind)
807 (or (documentation symbol kind) :not-documented))
808 (maybe-push (property value)
809 (when value
810 (setf result (list* property value result)))))
811 (maybe-push
812 :variable (multiple-value-bind (kind recorded-p)
813 (sb-int:info :variable :kind symbol)
814 (declare (ignore kind))
815 (if (or (boundp symbol) recorded-p)
816 (doc 'variable))))
817 (when (fboundp symbol)
818 (maybe-push
819 (cond ((macro-function symbol) :macro)
820 ((special-operator-p symbol) :special-operator)
821 ((typep (fdefinition symbol) 'generic-function)
822 :generic-function)
823 (t :function))
824 (doc 'function)))
825 (maybe-push
826 :setf (if (or (sb-int:info :setf :inverse symbol)
827 (sb-int:info :setf :expander symbol))
828 (doc 'setf)))
829 (maybe-push
830 :type (if (sb-int:info :type :kind symbol)
831 (doc 'type)))
832 result)))
833
834 (defimplementation describe-definition (symbol type)
835 (case type
836 (:variable
837 (describe symbol))
838 (:function
839 (describe (symbol-function symbol)))
840 (:setf
841 (describe (or (sb-int:info :setf :inverse symbol)
842 (sb-int:info :setf :expander symbol))))
843 (:class
844 (describe (find-class symbol)))
845 (:type
846 (describe (sb-kernel:values-specifier-type symbol)))))
847
848 #+#.(swank-backend::sbcl-with-xref-p)
849 (progn
850 (defmacro defxref (name)
851 `(defimplementation ,name (what)
852 (sanitize-xrefs
853 (mapcar #'source-location-for-xref-data
854 (,(find-symbol (symbol-name name) "SB-INTROSPECT")
855 what)))))
856 (defxref who-calls)
857 (defxref who-binds)
858 (defxref who-sets)
859 (defxref who-references)
860 (defxref who-macroexpands)
861 #+#.(swank-backend::with-symbol 'who-specializes 'sb-introspect)
862 (defxref who-specializes))
863
864 (defun source-location-for-xref-data (xref-data)
865 (let ((name (car xref-data))
866 (source-location (cdr xref-data)))
867 (list name
868 (handler-case (make-definition-source-location source-location
869 'function
870 name)
871 (error (e)
872 (list :error (format nil "Error: ~A" e)))))))
873
874 (defimplementation list-callers (symbol)
875 (let ((fn (fdefinition symbol)))
876 (sanitize-xrefs
877 (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
878
879 (defimplementation list-callees (symbol)
880 (let ((fn (fdefinition symbol)))
881 (sanitize-xrefs
882 (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
883
884 (defun sanitize-xrefs (xrefs)
885 (remove-duplicates
886 (remove-if (lambda (f)
887 (member f (ignored-xref-function-names)))
888 (loop for entry in xrefs
889 for name = (car entry)
890 collect (if (and (consp name)
891 (member (car name)
892 '(sb-pcl::fast-method
893 sb-pcl::slow-method
894 sb-pcl::method)))
895 (cons (cons 'defmethod (cdr name))
896 (cdr entry))
897 entry))
898 :key #'car)
899 :test (lambda (a b)
900 (and (eq (first a) (first b))
901 (equal (second a) (second b))))))
902
903 (defun ignored-xref-function-names ()
904 #-#.(swank-backend::sbcl-with-new-stepper-p)
905 '(nil sb-c::step-form sb-c::step-values)
906 #+#.(swank-backend::sbcl-with-new-stepper-p)
907 '(nil))
908
909 (defun function-dspec (fn)
910 "Describe where the function FN was defined.
911 Return a list of the form (NAME LOCATION)."
912 (let ((name (sb-kernel:%fun-name fn)))
913 (list name (safe-function-source-location fn name))))
914
915 ;;; macroexpansion
916
917 (defimplementation macroexpand-all (form)
918 (let ((sb-walker:*walk-form-expand-macros-p* t))
919 (sb-walker:walk-form form)))
920
921
922 ;;; Debugging
923
924 (defvar *sldb-stack-top*)
925
926 (defun make-invoke-debugger-hook (hook)
927 #'(lambda (condition old-hook)
928 ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before
929 ;; *DEBUGGER-HOOK*, so we have to make sure that the latter gets
930 ;; run when it was established locally by a user (i.e. changed meanwhile.)
931 (if *debugger-hook*
932 (funcall *debugger-hook* condition old-hook)
933 (funcall hook condition old-hook))))
934
935 (defimplementation install-debugger-globally (function)
936 (setq *debugger-hook* function)
937 (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook function)))
938
939 (defimplementation condition-extras (condition)
940 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
941 ((typep condition 'sb-impl::step-form-condition)
942 `((:show-frame-source 0)))
943 ((typep condition 'sb-int:reference-condition)
944 (let ((refs (sb-int:reference-condition-references condition)))
945 (if refs
946 `((:references ,(externalize-reference refs))))))))
947
948 (defun externalize-reference (ref)
949 (etypecase ref
950 (null nil)
951 (cons (cons (externalize-reference (car ref))
952 (externalize-reference (cdr ref))))
953 ((or string number) ref)
954 (symbol
955 (cond ((eq (symbol-package ref) (symbol-package :test))
956 ref)
957 (t (symbol-name ref))))))
958
959 (defimplementation call-with-debugging-environment (debugger-loop-fn)
960 (declare (type function debugger-loop-fn))
961 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
962 (sb-debug:*stack-top-hint* nil))
963 (handler-bind ((sb-di:debug-condition
964 (lambda (condition)
965 (signal (make-condition
966 'sldb-condition
967 :original-condition condition)))))
968 (funcall debugger-loop-fn))))
969
970 #+#.(swank-backend::sbcl-with-new-stepper-p)
971 (progn
972 (defimplementation activate-stepping (frame)
973 (declare (ignore frame))
974 (sb-impl::enable-stepping))
975 (defimplementation sldb-stepper-condition-p (condition)
976 (typep condition 'sb-ext:step-form-condition))
977 (defimplementation sldb-step-into ()
978 (invoke-restart 'sb-ext:step-into))
979 (defimplementation sldb-step-next ()
980 (invoke-restart 'sb-ext:step-next))
981 (defimplementation sldb-step-out ()
982 (invoke-restart 'sb-ext:step-out)))
983
984 (defimplementation call-with-debugger-hook (hook fun)
985 (let ((*debugger-hook* hook)
986 (sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook))
987 #+#.(swank-backend::sbcl-with-new-stepper-p)
988 (sb-ext:*stepper-hook*
989 (lambda (condition)
990 (typecase condition
991 (sb-ext:step-form-condition
992 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
993 (sb-impl::invoke-debugger condition)))))))
994 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
995 (sb-ext:step-condition #'sb-impl::invoke-stepper))
996 (funcall fun))))
997
998 (defun nth-frame (index)
999 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1000 (i index (1- i)))
1001 ((zerop i) frame)))
1002
1003 (defimplementation compute-backtrace (start end)
1004 "Return a list of frames starting with frame number START and
1005 continuing to frame number END or, if END is nil, the last frame on the
1006 stack."
1007 (let ((end (or end most-positive-fixnum)))
1008 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1009 for i from start below end
1010 while f collect f)))
1011
1012 (defimplementation print-frame (frame stream)
1013 (sb-debug::print-frame-call frame stream))
1014
1015 (defimplementation frame-restartable-p (frame)
1016 #+#.(swank-backend::sbcl-with-restart-frame)
1017 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1018
1019 ;;;; Code-location -> source-location translation
1020
1021 ;;; If debug-block info is avaibale, we determine the file position of
1022 ;;; the source-path for a code-location. If the code was compiled
1023 ;;; with C-c C-c, we have to search the position in the source string.
1024 ;;; If there's no debug-block info, we return the (less precise)
1025 ;;; source-location of the corresponding function.
1026
1027 (defun code-location-source-location (code-location)
1028 (let* ((dsource (sb-di:code-location-debug-source code-location))
1029 (plist (sb-c::debug-source-plist dsource)))
1030 (if (getf plist :emacs-buffer)
1031 (emacs-buffer-source-location code-location plist)
1032 #+#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
1033 (ecase (sb-di:debug-source-from dsource)
1034 (:file (file-source-location code-location))
1035 (:lisp (lisp-source-location code-location)))
1036 #-#.(swank-backend::with-symbol 'debug-source-from 'sb-di)
1037 (if (sb-di:debug-source-namestring dsource)
1038 (file-source-location code-location)
1039 (lisp-source-location code-location)))))
1040
1041 ;;; FIXME: The naming policy of source-location functions is a bit
1042 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1043 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1044 ;;; which returns the source location for a _code-location_.
1045 ;;;
1046 ;;; Maybe these should be named code-location-file-source-location,
1047 ;;; etc, turned into generic functions, or something. In the very
1048 ;;; least the names should indicate the main entry point vs. helper
1049 ;;; status.
1050
1051 (defun file-source-location (code-location)
1052 (if (code-location-has-debug-block-info-p code-location)
1053 (source-file-source-location code-location)
1054 (fallback-source-location code-location)))
1055
1056 (defun fallback-source-location (code-location)
1057 (let ((fun (code-location-debug-fun-fun code-location)))
1058 (cond (fun (function-source-location fun))
1059 (t (error "Cannot find source location for: ~A " code-location)))))
1060
1061 (defun lisp-source-location (code-location)
1062 (let ((source (prin1-to-string
1063 (sb-debug::code-location-source-form code-location 100))))
1064 (make-location `(:source-form ,source) '(:position 1))))
1065
1066 (defun emacs-buffer-source-location (code-location plist)
1067 (if (code-location-has-debug-block-info-p code-location)
1068 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1069 &allow-other-keys)
1070 plist
1071 (let* ((pos (string-source-position code-location emacs-string))
1072 (snipped (read-snippet-from-string emacs-string pos)))
1073 (make-location `(:buffer ,emacs-buffer)
1074 `(:offset ,emacs-position ,pos)
1075 `(:snippet ,snipped))))
1076 (fallback-source-location code-location)))
1077
1078 (defun source-file-source-location (code-location)
1079 (let* ((code-date (code-location-debug-source-created code-location))
1080 (filename (code-location-debug-source-name code-location))
1081 (*readtable* (guess-readtable-for-filename filename))
1082 (source-code (get-source-code filename code-date)))
1083 (with-debootstrapping
1084 (with-input-from-string (s source-code)
1085 (let* ((pos (stream-source-position code-location s))
1086 (snippet (read-snippet s pos)))
1087 (make-location `(:file ,filename)
1088 `(:position ,pos)
1089 `(:snippet ,snippet)))))))
1090
1091 (defun code-location-debug-source-name (code-location)
1092 (namestring (truename (#+#.(swank-backend::with-symbol
1093 'debug-source-name 'sb-di)
1094 sb-c::debug-source-name
1095 #-#.(swank-backend::with-symbol
1096 'debug-source-name 'sb-di)
1097 sb-c::debug-source-namestring
1098 (sb-di::code-location-debug-source code-location)))))
1099
1100 (defun code-location-debug-source-created (code-location)
1101 (sb-c::debug-source-created
1102 (sb-di::code-location-debug-source code-location)))
1103
1104 (defun code-location-debug-fun-fun (code-location)
1105 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1106
1107 (defun code-location-has-debug-block-info-p (code-location)
1108 (handler-case
1109 (progn (sb-di:code-location-debug-block code-location)
1110 t)
1111 (sb-di:no-debug-blocks () nil)))
1112
1113 (defun stream-source-position (code-location stream)
1114 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1115 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1116 (form-number (sb-di::code-location-form-number cloc)))
1117 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1118 (let* ((path-table (sb-di::form-number-translations tlf 0))
1119 (path (cond ((<= (length path-table) form-number)
1120 (warn "inconsistent form-number-translations")
1121 (list 0))
1122 (t
1123 (reverse (cdr (aref path-table form-number)))))))
1124 (source-path-source-position path tlf pos-map)))))
1125
1126 (defun string-source-position (code-location string)
1127 (with-input-from-string (s string)
1128 (stream-source-position code-location s)))
1129
1130 ;;; source-path-file-position and friends are in swank-source-path-parser
1131
1132 (defun safe-source-location-for-emacs (code-location)
1133 (if *debug-definition-finding*
1134 (code-location-source-location code-location)
1135 (handler-case (code-location-source-location code-location)
1136 (error (c) (list :error (format nil "~A" c))))))
1137
1138 (defimplementation frame-source-location (index)
1139 (safe-source-location-for-emacs
1140 (sb-di:frame-code-location (nth-frame index))))
1141
1142 (defun frame-debug-vars (frame)
1143 "Return a vector of debug-variables in frame."
1144 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1145
1146 (defun debug-var-value (var frame location)
1147 (ecase (sb-di:debug-var-validity var location)
1148 (:valid (sb-di:debug-var-value var frame))
1149 ((:invalid :unknown) ':<not-available>)))
1150
1151 (defimplementation frame-locals (index)
1152 (let* ((frame (nth-frame index))
1153 (loc (sb-di:frame-code-location frame))
1154 (vars (frame-debug-vars frame)))
1155 (loop for v across vars collect
1156 (list :name (sb-di:debug-var-symbol v)
1157 :id (sb-di:debug-var-id v)
1158 :value (debug-var-value v frame loc)))))
1159
1160 (defimplementation frame-var-value (frame var)
1161 (let* ((frame (nth-frame frame))
1162 (dvar (aref (frame-debug-vars frame) var)))
1163 (debug-var-value dvar frame (sb-di:frame-code-location frame))))
1164
1165 (defimplementation frame-catch-tags (index)
1166 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1167
1168 (defimplementation eval-in-frame (form index)
1169 (let ((frame (nth-frame index)))
1170 (funcall (the function
1171 (sb-di:preprocess-for-eval form
1172 (sb-di:frame-code-location frame)))
1173 frame)))
1174
1175 #+#.(swank-backend::sbcl-with-restart-frame)
1176 (progn
1177 (defimplementation return-from-frame (index form)
1178 (let* ((frame (nth-frame index)))
1179 (cond ((sb-debug:frame-has-debug-tag-p frame)
1180 (let ((values (multiple-value-list (eval-in-frame form index))))
1181 (sb-debug:unwind-to-frame-and-call frame
1182 (lambda ()
1183 (values-list values)))))
1184 (t (format nil "Cannot return from frame: ~S" frame)))))
1185
1186 (defimplementation restart-frame (index)
1187 (let* ((frame (nth-frame index)))
1188 (cond ((sb-debug:frame-has-debug-tag-p frame)
1189 (let* ((call-list (sb-debug::frame-call-as-list frame))
1190 (fun (fdefinition (car call-list)))
1191 (thunk (lambda ()
1192 ;; Ensure that the thunk gets tail-call-optimized
1193 (declare (optimize (debug 1)))
1194 (apply fun (cdr call-list)))))
1195 (sb-debug:unwind-to-frame-and-call frame thunk)))
1196 (t (format nil "Cannot restart frame: ~S" frame))))))
1197
1198 ;; FIXME: this implementation doesn't unwind the stack before
1199 ;; re-invoking the function, but it's better than no implementation at
1200 ;; all.
1201 #-#.(swank-backend::sbcl-with-restart-frame)
1202 (progn
1203 (defun sb-debug-catch-tag-p (tag)
1204 (and (symbolp tag)
1205 (not (symbol-package tag))
1206 (string= tag :sb-debug-catch-tag)))
1207
1208 (defimplementation return-from-frame (index form)
1209 (let* ((frame (nth-frame index))
1210 (probe (assoc-if #'sb-debug-catch-tag-p
1211 (sb-di::frame-catches frame))))
1212 (cond (probe (throw (car probe) (eval-in-frame form index)))
1213 (t (format nil "Cannot return from frame: ~S" frame)))))
1214
1215 (defimplementation restart-frame (index)
1216 (let ((frame (nth-frame index)))
1217 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1218
1219 ;;;;; reference-conditions
1220
1221 (defimplementation format-sldb-condition (condition)
1222 (let ((sb-int:*print-condition-references* nil))
1223 (princ-to-string condition)))
1224
1225
1226 ;;;; Profiling
1227
1228 (defimplementation profile (fname)
1229 (when fname (eval `(sb-profile:profile ,fname))))
1230
1231 (defimplementation unprofile (fname)
1232 (when fname (eval `(sb-profile:unprofile ,fname))))
1233
1234 (defimplementation unprofile-all ()
1235 (sb-profile:unprofile)
1236 "All functions unprofiled.")
1237
1238 (defimplementation profile-report ()
1239 (sb-profile:report))
1240
1241 (defimplementation profile-reset ()
1242 (sb-profile:reset)
1243 "Reset profiling counters.")
1244
1245 (defimplementation profiled-functions ()
1246 (sb-profile:profile))
1247
1248 (defimplementation profile-package (package callers methods)
1249 (declare (ignore callers methods))
1250 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1251
1252
1253 ;;;; Inspector
1254
1255 (defmethod emacs-inspect ((o t))
1256 (cond ((sb-di::indirect-value-cell-p o)
1257 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1258 (t
1259 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1260 (list* (format nil "~a~%" text)
1261 (if label
1262 (loop for (l . v) in parts
1263 append (label-value-line l v))
1264 (loop for value in parts for i from 0
1265 append (label-value-line i value))))))))
1266
1267 (defmethod emacs-inspect ((o function))
1268 (let ((header (sb-kernel:widetag-of o)))
1269 (cond ((= header sb-vm:simple-fun-header-widetag)
1270 (label-value-line*
1271 (:name (sb-kernel:%simple-fun-name o))
1272 (:arglist (sb-kernel:%simple-fun-arglist o))
1273 (:self (sb-kernel:%simple-fun-self o))
1274 (:next (sb-kernel:%simple-fun-next o))
1275 (:type (sb-kernel:%simple-fun-type o))
1276 (:code (sb-kernel:fun-code-header o))))
1277 ((= header sb-vm:closure-header-widetag)
1278 (append
1279 (label-value-line :function (sb-kernel:%closure-fun o))
1280 `("Closed over values:" (:newline))
1281 (loop for i below (1- (sb-kernel:get-closure-length o))
1282 append (label-value-line
1283 i (sb-kernel:%closure-index-ref o i)))))
1284 (t (call-next-method o)))))
1285
1286 (defmethod emacs-inspect ((o sb-kernel:code-component))
1287 (append
1288 (label-value-line*
1289 (:code-size (sb-kernel:%code-code-size o))
1290 (:entry-points (sb-kernel:%code-entry-points o))
1291 (:debug-info (sb-kernel:%code-debug-info o))
1292 (:trace-table-offset (sb-kernel:code-header-ref
1293 o sb-vm:code-trace-table-offset-slot)))
1294 `("Constants:" (:newline))
1295 (loop for i from sb-vm:code-constants-offset
1296 below (sb-kernel:get-header-data o)
1297 append (label-value-line i (sb-kernel:code-header-ref o i)))
1298 `("Code:" (:newline)
1299 , (with-output-to-string (s)
1300 (cond ((sb-kernel:%code-debug-info o)
1301 (sb-disassem:disassemble-code-component o :stream s))
1302 (t
1303 (sb-disassem:disassemble-memory
1304 (sb-disassem::align
1305 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1306 sb-vm:lowtag-mask)
1307 (* sb-vm:code-constants-offset
1308 sb-vm:n-word-bytes))
1309 (ash 1 sb-vm:n-lowtag-bits))
1310 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1311 :stream s)))))))
1312
1313 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1314 (label-value-line*
1315 (:value (sb-ext:weak-pointer-value o))))
1316
1317 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1318 (label-value-line*
1319 (:name (sb-kernel:fdefn-name o))
1320 (:function (sb-kernel:fdefn-fun o))))
1321
1322 (defmethod emacs-inspect :around ((o generic-function))
1323 (append
1324 (call-next-method)
1325 (label-value-line*
1326 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1327 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1328 )))
1329
1330
1331 ;;;; Multiprocessing
1332
1333 #+(and sb-thread
1334 #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1335 (progn
1336 (defvar *thread-id-counter* 0)
1337
1338 (defvar *thread-id-counter-lock*
1339 (sb-thread:make-mutex :name "thread id counter lock"))
1340
1341 (defun next-thread-id ()
1342 (sb-thread:with-mutex (*thread-id-counter-lock*)
1343 (incf *thread-id-counter*)))
1344
1345 (defparameter *thread-id-map* (make-hash-table))
1346
1347 ;; This should be a thread -> id map but as weak keys are not
1348 ;; supported it is id -> map instead.
1349 (defvar *thread-id-map-lock*
1350 (sb-thread:make-mutex :name "thread id map lock"))
1351
1352 (defimplementation spawn (fn &key name)
1353 (sb-thread:make-thread fn :name name))
1354
1355 (defimplementation thread-id (thread)
1356 (block thread-id
1357 (sb-thread:with-mutex (*thread-id-map-lock*)
1358 (loop for id being the hash-key in *thread-id-map*
1359 using (hash-value thread-pointer)
1360 do
1361 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1362 (cond ((null maybe-thread)
1363 ;; the value is gc'd, remove it manually
1364 (remhash id *thread-id-map*))
1365 ((eq thread maybe-thread)
1366 (return-from thread-id id)))))
1367 ;; lazy numbering
1368 (let ((id (next-thread-id)))
1369 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1370 id))))
1371
1372 (defimplementation find-thread (id)
1373 (sb-thread:with-mutex (*thread-id-map-lock*)
1374 (let ((thread-pointer (gethash id *thread-id-map*)))
1375 (if thread-pointer
1376 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1377 (if maybe-thread
1378 maybe-thread
1379 ;; the value is gc'd, remove it manually
1380 (progn
1381 (remhash id *thread-id-map*)
1382 nil)))
1383 nil))))
1384
1385 (defimplementation thread-name (thread)
1386 ;; sometimes the name is not a string (e.g. NIL)
1387 (princ-to-string (sb-thread:thread-name thread)))
1388
1389 (defimplementation thread-status (thread)
1390 (if (sb-thread:thread-alive-p thread)
1391 "RUNNING"
1392 "STOPPED"))
1393 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1394 (progn
1395 (defparameter *thread-description-map*
1396 (make-weak-key-hash-table))
1397
1398 (defvar *thread-descr-map-lock*
1399 (sb-thread:make-mutex :name "thread description map lock"))
1400
1401 (defimplementation thread-description (thread)
1402 (sb-thread:with-mutex (*thread-descr-map-lock*)
1403 (or (gethash thread *thread-description-map*)
1404 (short-backtrace thread 6 10))))
1405
1406 (defimplementation set-thread-description (thread description)
1407 (sb-thread:with-mutex (*thread-descr-map-lock*)
1408 (setf (gethash thread *thread-description-map*) description)))
1409
1410 (defun short-backtrace (thread start count)
1411 (let ((self (current-thread))
1412 (tag (get-internal-real-time)))
1413 (sb-thread:interrupt-thread
1414 thread
1415 (lambda ()
1416 (let* ((frames (nthcdr start (sb-debug:backtrace-as-list count))))
1417 (send self (cons tag frames)))))
1418 (handler-case
1419 (sb-ext:with-timeout 0.1
1420 (let ((frames (cdr (receive-if (lambda (msg)
1421 (eq (car msg) tag)))))
1422 (*print-pretty* nil))
1423 (format nil "~{~a~^ <- ~}" (mapcar #'car frames))))
1424 (sb-ext:timeout () ""))))
1425
1426 )
1427
1428 (defimplementation make-lock (&key name)
1429 (sb-thread:make-mutex :name name))
1430
1431 (defimplementation call-with-lock-held (lock function)
1432 (declare (type function function))
1433 (sb-thread:with-recursive-lock (lock) (funcall function)))
1434
1435 (defimplementation current-thread ()
1436 sb-thread:*current-thread*)
1437
1438 (defimplementation all-threads ()
1439 (sb-thread:list-all-threads))
1440
1441 (defimplementation interrupt-thread (thread fn)
1442 (sb-thread:interrupt-thread thread fn))
1443
1444 (defimplementation kill-thread (thread)
1445 (sb-thread:terminate-thread thread))
1446
1447 (defimplementation thread-alive-p (thread)
1448 (sb-thread:thread-alive-p thread))
1449
1450 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1451 (defvar *mailboxes* (list))
1452 (declaim (type list *mailboxes*))
1453
1454 (defstruct (mailbox (:conc-name mailbox.))
1455 thread
1456 (mutex (sb-thread:make-mutex))
1457 (waitqueue (sb-thread:make-waitqueue))
1458 (queue '() :type list))
1459
1460 (defun mailbox (thread)
1461 "Return THREAD's mailbox."
1462 (sb-thread:with-mutex (*mailbox-lock*)
1463 (or (find thread *mailboxes* :key #'mailbox.thread)
1464 (let ((mb (make-mailbox :thread thread)))
1465 (push mb *mailboxes*)
1466 mb))))
1467
1468 (defimplementation send (thread message)
1469 (let* ((mbox (mailbox thread))
1470 (mutex (mailbox.mutex mbox)))
1471 (sb-thread:with-mutex (mutex)
1472 (setf (mailbox.queue mbox)
1473 (nconc (mailbox.queue mbox) (list message)))
1474 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1475
1476 (defimplementation receive-if (test &optional timeout)
1477 (let* ((mbox (mailbox (current-thread)))
1478 (mutex (mailbox.mutex mbox)))
1479 (assert (or (not timeout) (eq timeout t)))
1480 (loop
1481 (check-slime-interrupts)
1482 (sb-thread:with-mutex (mutex)
1483 (let* ((q (mailbox.queue mbox))
1484 (tail (member-if test q)))
1485 (when tail
1486 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1487 (return (car tail))))
1488 (when (eq timeout t) (return (values nil t)))
1489 ;; FIXME: with-timeout doesn't work properly on Darwin
1490 #+linux
1491 (handler-case
1492 (let ((*break-on-signals* nil))
1493 (sb-ext:with-timeout 0.2
1494 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1495 mutex)))
1496 (sb-ext:timeout ()))
1497 #-linux
1498 (sb-thread:condition-wait (mailbox.waitqueue mbox)
1499 mutex)))))
1500 )
1501
1502 (defimplementation quit-lisp ()
1503 #+sb-thread
1504 (dolist (thread (remove (current-thread) (all-threads)))
1505 (ignore-errors (sb-thread:interrupt-thread
1506 thread (lambda () (sb-ext:quit :recklessly-p t)))))
1507 (sb-ext:quit))
1508
1509
1510
1511 ;;Trace implementations
1512 ;;In SBCL, we have:
1513 ;; (trace <name>)
1514 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1515 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1516 ;; <name> can be a normal name or a (setf name)
1517
1518 (defun toggle-trace-aux (fspec &rest args)
1519 (cond ((member fspec (eval '(trace)) :test #'equal)
1520 (eval `(untrace ,fspec))
1521 (format nil "~S is now untraced." fspec))
1522 (t
1523 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1524 (format nil "~S is now traced." fspec))))
1525
1526 (defun process-fspec (fspec)
1527 (cond ((consp fspec)
1528 (ecase (first fspec)
1529 ((:defun :defgeneric) (second fspec))
1530 ((:defmethod) `(method ,@(rest fspec)))
1531 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1532 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1533 (t
1534 fspec)))
1535
1536 (defimplementation toggle-trace (spec)
1537 (ecase (car spec)
1538 ((setf)
1539 (toggle-trace-aux spec))
1540 ((:defmethod)
1541 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1542 ((:defgeneric)
1543 (toggle-trace-aux (second spec) :methods t))
1544 ((:call)
1545 (destructuring-bind (caller callee) (cdr spec)
1546 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1547
1548 ;;; Weak datastructures
1549
1550 (defimplementation make-weak-key-hash-table (&rest args)
1551 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1552 (apply #'make-hash-table :weakness :key args)
1553 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1554 (apply #'make-hash-table args))
1555
1556 (defimplementation make-weak-value-hash-table (&rest args)
1557 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1558 (apply #'make-hash-table :weakness :value args)
1559 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1560 (apply #'make-hash-table args))
1561
1562 (defimplementation hash-table-weakness (hashtable)
1563 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1564 (sb-ext:hash-table-weakness hashtable))
1565
1566 #-win32
1567 (defimplementation save-image (filename &optional restart-function)
1568 (let ((pid (sb-posix:fork)))
1569 (cond ((= pid 0)
1570 (let ((args `(,filename
1571 ,@(if restart-function
1572 `((:toplevel ,restart-function))))))
1573 (apply #'sb-ext:save-lisp-and-die args)))
1574 (t
1575 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1576 (assert (= pid rpid))
1577 (assert (and (sb-posix:wifexited status)
1578 (zerop (sb-posix:wexitstatus status)))))))))

  ViewVC Help
Powered by ViewVC 1.1.5