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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.264 - (show annotations)
Sun Jan 3 10:05:05 2010 UTC (4 years, 3 months ago) by trittweiler
Branch: MAIN
Changes since 1.263: +13 -16 lines
        * slime.el (compile-defun [test]): Also test proper notification
        after reader-error. Additionally: bind font-lock-verbose to nil to
        prevent annoying font-lock messages during the test.

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

  ViewVC Help
Powered by ViewVC 1.1.5