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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5