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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5