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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5