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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.297 - (show annotations)
Fri Dec 2 20:24:03 2011 UTC (2 years, 4 months ago) by sboukarev
Branch: MAIN
Changes since 1.296: +3 -2 lines
* swank-sbcl.lisp (wait-for-input): Define only if
#+os-provides-poll or #+win32.
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 ;;; UTF8
65
66 (defimplementation string-to-utf8 (string)
67 (sb-ext:string-to-octets string :external-format :utf8))
68
69 (defimplementation utf8-to-string (octets)
70 (sb-ext:octets-to-string octets :external-format :utf8))
71
72 ;;; TCP Server
73
74 (defimplementation preferred-communication-style ()
75 (cond
76 ;; fixme: when SBCL/win32 gains better select() support, remove
77 ;; this.
78 ((member :sb-thread *features*) :spawn)
79 ((member :win32 *features*) nil)
80 (t :fd-handler)))
81
82 (defun resolve-hostname (name)
83 (car (sb-bsd-sockets:host-ent-addresses
84 (sb-bsd-sockets:get-host-by-name name))))
85
86 (defimplementation create-socket (host port &key backlog)
87 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
88 :type :stream
89 :protocol :tcp)))
90 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
91 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
92 (sb-bsd-sockets:socket-listen socket (or backlog 5))
93 socket))
94
95 (defimplementation local-port (socket)
96 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
97
98 (defimplementation close-socket (socket)
99 (sb-sys:invalidate-descriptor (socket-fd socket))
100 (sb-bsd-sockets:socket-close socket))
101
102 (defimplementation accept-connection (socket &key
103 external-format
104 buffering timeout)
105 (declare (ignore timeout))
106 (make-socket-io-stream (accept socket) external-format
107 (ecase buffering
108 ((t :full) :full)
109 ((nil :none) :none)
110 ((:line) :line))))
111
112 #-win32
113 (defimplementation install-sigint-handler (function)
114 (sb-sys:enable-interrupt sb-unix:sigint
115 (lambda (&rest args)
116 (declare (ignore args))
117 (sb-sys:invoke-interruption
118 (lambda ()
119 (sb-sys:with-interrupts
120 (funcall function)))))))
121
122 (defvar *sigio-handlers* '()
123 "List of (key . fn) pairs to be called on SIGIO.")
124
125 (defun sigio-handler (signal code scp)
126 (declare (ignore signal code scp))
127 (mapc (lambda (handler)
128 (funcall (the function (cdr handler))))
129 *sigio-handlers*))
130
131 (defun set-sigio-handler ()
132 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
133 (sigio-handler signal code scp))))
134
135 (defun enable-sigio-on-fd (fd)
136 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
137 (sb-posix::fcntl fd sb-posix::f-setown (getpid))
138 (values))
139
140 (defimplementation add-sigio-handler (socket fn)
141 (set-sigio-handler)
142 (let ((fd (socket-fd socket)))
143 (enable-sigio-on-fd fd)
144 (push (cons fd fn) *sigio-handlers*)))
145
146 (defimplementation remove-sigio-handlers (socket)
147 (let ((fd (socket-fd socket)))
148 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
149 (sb-sys:invalidate-descriptor fd))
150 (close socket))
151
152 (defimplementation add-fd-handler (socket fun)
153 (let ((fd (socket-fd socket))
154 (handler nil))
155 (labels ((add ()
156 (setq handler (sb-sys:add-fd-handler fd :input #'run)))
157 (run (fd)
158 (sb-sys:remove-fd-handler handler) ; prevent recursion
159 (unwind-protect
160 (funcall fun)
161 (when (sb-unix:unix-fstat fd) ; still open?
162 (add)))))
163 (add))))
164
165 (defimplementation remove-fd-handlers (socket)
166 (sb-sys:invalidate-descriptor (socket-fd socket)))
167
168 (defimplementation socket-fd (socket)
169 (etypecase socket
170 (fixnum socket)
171 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
172 (file-stream (sb-sys:fd-stream-fd socket))))
173
174 (defimplementation command-line-args ()
175 sb-ext:*posix-argv*)
176
177 (defimplementation dup (fd)
178 (sb-posix:dup fd))
179
180 (defvar *wait-for-input-called*)
181
182 #+(or win32 os-provides-poll)
183 (defimplementation wait-for-input (streams &optional timeout)
184 (assert (member timeout '(nil t)))
185 (when (boundp '*wait-for-input-called*)
186 (setq *wait-for-input-called* t))
187 (let ((*wait-for-input-called* nil))
188 (loop
189 (let ((ready (remove-if-not #'input-ready-p streams)))
190 (when ready (return ready)))
191 (when (check-slime-interrupts) (return :interrupt))
192 (when *wait-for-input-called* (return :interrupt))
193 #+os-provides-poll
194 (let ((readable (poll streams () (ecase timeout
195 ((nil) nil)
196 ((t) 0)))))
197 (when readable (return readable))
198 (when timeout (return nil)))
199
200 #-os-provides-poll
201 (progn
202 (when timeout (return nil))
203 (sleep 0.1)))))
204
205 (defun fd-stream-input-buffer-empty-p (stream)
206 (let ((buffer (sb-impl::fd-stream-ibuf stream)))
207 (or (not buffer)
208 (= (sb-impl::buffer-head buffer)
209 (sb-impl::buffer-tail buffer)))))
210
211 #+os-provides-poll
212 (progn
213 (defun input-ready-p (stream)
214 (not (fd-stream-input-buffer-empty-p stream)))
215
216 (sb-alien:define-alien-type pollfd (sb-alien:struct sb-unix::pollfd))
217 (sb-alien:define-alien-routine ("poll" poll%) sb-alien:int
218 (descs (sb-alien:* pollfd)) (ndescs sb-alien:int) (millis sb-alien:int))
219
220 (defun poll (read-streams write-streams milliseconds)
221 (let* ((rlen (length read-streams))
222 (wlen (length write-streams))
223 (len (+ rlen wlen)))
224 (assert (< len 10))
225 (sb-alien:with-alien ((pollfds (sb-alien:array pollfd 10)))
226 (flet ((set-events (i stream flags)
227 (symbol-macrolet ((pfd (sb-alien:deref pollfds i)))
228 (setf (sb-alien:slot pfd 'sb-unix::fd)
229 (sb-impl::fd-stream-fd stream))
230 (setf (sb-alien:slot pfd 'sb-unix::events) flags)
231 (setf (sb-alien:slot pfd 'sb-unix::revents) 0)))
232 (revents? (i)
233 (let ((revents (sb-alien:slot (sb-alien:deref pollfds i)
234 'sb-unix::revents)))
235 (not (zerop revents)))))
236 (declare (inline set-events revents?))
237 (loop with rflags = (logior sb-unix::pollin
238 #+linux #x2000 #|POLLRDHUP|#)
239 for i below rlen for s in read-streams
240 do (set-events i s rflags))
241 (loop for i from rlen below len for s in write-streams
242 do (set-events i s sb-unix::pollout))
243 (let* ((timeout (etypecase milliseconds
244 (null -1)
245 (integer milliseconds)))
246 (code (poll% (sb-alien:addr (sb-alien:deref pollfds 0))
247 len timeout))
248 (errno (sb-alien:get-errno)))
249 (cond ((zerop code)
250 (values () ()))
251 ((plusp code)
252 (values
253 (loop for i below rlen for s in read-streams
254 if (revents? i) collect s)
255 (loop for i from rlen below len for s in write-streams
256 if (revents? i) collect s)))
257 ((= errno sb-posix:eintr)
258 :interrupt)
259 (t
260 (error "~a" (sb-int:strerror errno)))))))))
261 )
262
263 #+win32
264 (progn
265 (defun input-ready-p (stream)
266 (or (not (fd-stream-input-buffer-empty-p stream))
267 (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
268
269 (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
270 sb-win32:handle)
271
272 (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
273 sb-alien:int
274 (event sb-win32:handle))
275
276 (defconstant +fd-read+ #.(ash 1 0))
277 (defconstant +fd-close+ #.(ash 1 5))
278
279 (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
280 sb-alien:int
281 (fd sb-alien:int)
282 (handle sb-win32:handle)
283 (mask sb-alien:long))
284
285 (sb-alien:load-shared-object "kernel32.dll")
286 (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
287 wait-for-single-object-ex)
288 sb-alien:int
289 (event sb-win32:handle)
290 (milliseconds sb-alien:long)
291 (alertable sb-alien:int))
292
293 ;; see SB-WIN32:HANDLE-LISTEN
294 (defun handle-listen (handle)
295 (sb-alien:with-alien ((avail sb-win32:dword)
296 (buf (array char #.sb-win32::input-record-size)))
297 (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
298 (sb-alien:alien-sap
299 (sb-alien:addr avail))
300 nil))
301 (return-from handle-listen (plusp avail)))
302
303 (unless (zerop (sb-win32:peek-console-input handle
304 (sb-alien:alien-sap buf)
305 sb-win32::input-record-size
306 (sb-alien:alien-sap
307 (sb-alien:addr avail))))
308 (return-from handle-listen (plusp avail))))
309
310 (let ((event (wsa-create-event)))
311 (wsa-event-select handle event (logior +fd-read+ +fd-close+))
312 (let ((val (wait-for-single-object-ex event 0 0)))
313 (wsa-close-event event)
314 (unless (= val -1)
315 (return-from handle-listen (zerop val)))))
316
317 nil)
318
319 )
320
321 (defvar *external-format-to-coding-system*
322 '((:iso-8859-1
323 "latin-1" "latin-1-unix" "iso-latin-1-unix"
324 "iso-8859-1" "iso-8859-1-unix")
325 (:utf-8 "utf-8" "utf-8-unix")
326 (:euc-jp "euc-jp" "euc-jp-unix")
327 (:us-ascii "us-ascii" "us-ascii-unix")))
328
329 ;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general, 2008-08-22.
330 (defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
331
332 (defimplementation filename-to-pathname (filename)
333 (sb-ext:parse-native-namestring filename *physical-pathname-host*))
334
335 (defimplementation find-external-format (coding-system)
336 (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
337 *external-format-to-coding-system*)))
338
339 (defun make-socket-io-stream (socket external-format buffering)
340 (let ((args `(,@()
341 :output t
342 :input t
343 :element-type ,(if external-format
344 'character
345 '(unsigned-byte 8))
346 :buffering ,buffering
347 ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
348 `(:external-format ,external-format))
349 (t '()))
350 :serve-events ,(eq :fd-handler
351 ;; KLUDGE: SWANK package isn't
352 ;; available when backend is loaded.
353 (symbol-value
354 (intern "*COMMUNICATION-STYLE*" :swank)))
355 ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS
356 ;; argument.
357 :allow-other-keys t)))
358 (apply #'sb-bsd-sockets:socket-make-stream socket args)))
359
360 (defun accept (socket)
361 "Like socket-accept, but retry on EAGAIN."
362 (loop (handler-case
363 (return (sb-bsd-sockets:socket-accept socket))
364 (sb-bsd-sockets:interrupted-error ()))))
365
366
367 ;;;; Support for SBCL syntax
368
369 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
370 ;;; containing `!' have special meaning. We have to work long and
371 ;;; hard to be able to read the source. To deal with #! reader
372 ;;; macros, we use a special readtable. The special symbols are
373 ;;; converted by a condition handler.
374
375 (defun feature-in-list-p (feature list)
376 (etypecase feature
377 (symbol (member feature list :test #'eq))
378 (cons (flet ((subfeature-in-list-p (subfeature)
379 (feature-in-list-p subfeature list)))
380 (ecase (first feature)
381 (:or (some #'subfeature-in-list-p (rest feature)))
382 (:and (every #'subfeature-in-list-p (rest feature)))
383 (:not (destructuring-bind (e) (cdr feature)
384 (not (subfeature-in-list-p e)))))))))
385
386 (defun shebang-reader (stream sub-character infix-parameter)
387 (declare (ignore sub-character))
388 (when infix-parameter
389 (error "illegal read syntax: #~D!" infix-parameter))
390 (let ((next-char (read-char stream)))
391 (unless (find next-char "+-")
392 (error "illegal read syntax: #!~C" next-char))
393 ;; When test is not satisfied
394 ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
395 ;; would become "unless test is satisfied"..
396 (when (let* ((*package* (find-package "KEYWORD"))
397 (*read-suppress* nil)
398 (not-p (char= next-char #\-))
399 (feature (read stream)))
400 (if (feature-in-list-p feature *features*)
401 not-p
402 (not not-p)))
403 ;; Read (and discard) a form from input.
404 (let ((*read-suppress* t))
405 (read stream t nil t))))
406 (values))
407
408 (defvar *shebang-readtable*
409 (let ((*readtable* (copy-readtable nil)))
410 (set-dispatch-macro-character #\# #\!
411 (lambda (s c n) (shebang-reader s c n))
412 *readtable*)
413 *readtable*))
414
415 (defun shebang-readtable ()
416 *shebang-readtable*)
417
418 (defun sbcl-package-p (package)
419 (let ((name (package-name package)))
420 (eql (mismatch "SB-" name) 3)))
421
422 (defun sbcl-source-file-p (filename)
423 (when filename
424 (loop for (nil pattern) in (logical-pathname-translations "SYS")
425 thereis (pathname-match-p filename pattern))))
426
427 (defun guess-readtable-for-filename (filename)
428 (if (sbcl-source-file-p filename)
429 (shebang-readtable)
430 *readtable*))
431
432 (defvar *debootstrap-packages* t)
433
434 (defun call-with-debootstrapping (fun)
435 (handler-bind ((sb-int:bootstrap-package-not-found
436 #'sb-int:debootstrap-package))
437 (funcall fun)))
438
439 (defmacro with-debootstrapping (&body body)
440 `(call-with-debootstrapping (lambda () ,@body)))
441
442 (defimplementation call-with-syntax-hooks (fn)
443 (cond ((and *debootstrap-packages*
444 (sbcl-package-p *package*))
445 (with-debootstrapping (funcall fn)))
446 (t
447 (funcall fn))))
448
449 (defimplementation default-readtable-alist ()
450 (let ((readtable (shebang-readtable)))
451 (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
452 collect (cons (package-name p) readtable))))
453
454 ;;; Utilities
455
456 #+#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
457 (defimplementation arglist (fname)
458 (sb-introspect:function-lambda-list fname))
459
460 #-#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
461 (defimplementation arglist (fname)
462 (sb-introspect:function-arglist fname))
463
464 (defimplementation function-name (f)
465 (check-type f function)
466 (sb-impl::%fun-name f))
467
468 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
469 (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
470 (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
471 (if flags
472 ;; Symbols aren't printed with package qualifiers, but the FLAGS would
473 ;; have to be fully qualified when used inside a declaration. So we
474 ;; strip those as long as there's no better way. (FIXME)
475 `(&any ,@(remove-if-not #'(lambda (qualifier)
476 (find-symbol (symbol-name (first qualifier)) :cl))
477 flags :key #'ensure-list))
478 (call-next-method)))))
479
480 #+#.(swank-backend:with-symbol 'deftype-lambda-list 'sb-introspect)
481 (defmethod type-specifier-arglist :around (typespec-operator)
482 (multiple-value-bind (arglist foundp)
483 (sb-introspect:deftype-lambda-list typespec-operator)
484 (if foundp arglist (call-next-method))))
485
486
487 (defvar *buffer-name* nil)
488 (defvar *buffer-tmpfile* nil)
489 (defvar *buffer-offset*)
490 (defvar *buffer-substring* nil)
491
492 (defvar *previous-compiler-condition* nil
493 "Used to detect duplicates.")
494
495 (defun handle-notification-condition (condition)
496 "Handle a condition caused by a compiler warning.
497 This traps all compiler conditions at a lower-level than using
498 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
499 craft our own error messages, which can omit a lot of redundant
500 information."
501 (unless (or (eq condition *previous-compiler-condition*))
502 ;; First resignal warnings, so that outer handlers -- which may choose to
503 ;; muffle this -- get a chance to run.
504 (when (typep condition 'warning)
505 (signal condition))
506 (setq *previous-compiler-condition* condition)
507 (signal-compiler-condition (real-condition condition)
508 (sb-c::find-error-context nil))))
509
510 (defun signal-compiler-condition (condition context)
511 (signal (make-condition
512 'compiler-condition
513 :original-condition condition
514 :severity (etypecase condition
515 (sb-ext:compiler-note :note)
516 (sb-c:compiler-error :error)
517 (reader-error :read-error)
518 (error :error)
519 #+#.(swank-backend:with-symbol redefinition-warning sb-kernel)
520 (sb-kernel:redefinition-warning
521 :redefinition)
522 (style-warning :style-warning)
523 (warning :warning))
524 :references (condition-references condition)
525 :message (brief-compiler-message-for-emacs condition)
526 :source-context (compiler-error-context context)
527 :location (compiler-note-location condition context))))
528
529 (defun real-condition (condition)
530 "Return the encapsulated condition or CONDITION itself."
531 (typecase condition
532 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
533 (t condition)))
534
535 (defun condition-references (condition)
536 (if (typep condition 'sb-int:reference-condition)
537 (externalize-reference
538 (sb-int:reference-condition-references condition))))
539
540 (defun compiler-note-location (condition context)
541 (flet ((bailout ()
542 (return-from compiler-note-location
543 (make-error-location "No error location available"))))
544 (cond (context
545 (locate-compiler-note
546 (sb-c::compiler-error-context-file-name context)
547 (compiler-source-path context)
548 (sb-c::compiler-error-context-original-source context)))
549 ((typep condition 'reader-error)
550 (let* ((stream (stream-error-stream condition))
551 (file (pathname stream)))
552 (unless (open-stream-p stream)
553 (bailout))
554 (if (compiling-from-buffer-p file)
555 ;; The stream position for e.g. "comma not inside backquote"
556 ;; is at the character following the comma, :offset is 0-based,
557 ;; hence the 1-.
558 (make-location (list :buffer *buffer-name*)
559 (list :offset *buffer-offset*
560 (1- (file-position stream))))
561 (progn
562 (assert (compiling-from-file-p file))
563 ;; No 1- because :position is 1-based.
564 (make-location (list :file (namestring file))
565 (list :position (file-position stream)))))))
566 (t (bailout)))))
567
568 (defun compiling-from-buffer-p (filename)
569 (and *buffer-name*
570 ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
571 ;; in LOCATE-COMPILER-NOTE, and allows handling nested
572 ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
573 ;;
574 ;; PROBE-FILE to handle tempfile directory being a symlink.
575 (pathnamep filename)
576 (let ((true1 (probe-file filename))
577 (true2 (probe-file *buffer-tmpfile*)))
578 (and true1 (equal true1 true2)))))
579
580 (defun compiling-from-file-p (filename)
581 (and (pathnamep filename)
582 (or (null *buffer-name*)
583 (null *buffer-tmpfile*)
584 (let ((true1 (probe-file filename))
585 (true2 (probe-file *buffer-tmpfile*)))
586 (not (and true1 (equal true1 true2)))))))
587
588 (defun compiling-from-generated-code-p (filename source)
589 (and (eq filename :lisp) (stringp source)))
590
591 (defun locate-compiler-note (file source-path source)
592 (cond ((compiling-from-buffer-p file)
593 (make-location (list :buffer *buffer-name*)
594 (list :offset *buffer-offset*
595 (source-path-string-position
596 source-path *buffer-substring*))))
597 ((compiling-from-file-p file)
598 (make-location (list :file (namestring file))
599 (list :position (1+ (source-path-file-position
600 source-path file)))))
601 ((compiling-from-generated-code-p file source)
602 (make-location (list :source-form source)
603 (list :position 1)))
604 (t
605 (error "unhandled case in compiler note ~S ~S ~S" file source-path source))))
606
607 (defun brief-compiler-message-for-emacs (condition)
608 "Briefly describe a compiler error for Emacs.
609 When Emacs presents the message it already has the source popped up
610 and the source form highlighted. This makes much of the information in
611 the error-context redundant."
612 (let ((sb-int:*print-condition-references* nil))
613 (princ-to-string condition)))
614
615 (defun compiler-error-context (error-context)
616 "Describe a compiler error for Emacs including context information."
617 (declare (type (or sb-c::compiler-error-context null) error-context))
618 (multiple-value-bind (enclosing source)
619 (if error-context
620 (values (sb-c::compiler-error-context-enclosing-source error-context)
621 (sb-c::compiler-error-context-source error-context)))
622 (and (or enclosing source)
623 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
624 enclosing source))))
625
626 (defun compiler-source-path (context)
627 "Return the source-path for the current compiler error.
628 Returns NIL if this cannot be determined by examining internal
629 compiler state."
630 (cond ((sb-c::node-p context)
631 (reverse
632 (sb-c::source-path-original-source
633 (sb-c::node-source-path context))))
634 ((sb-c::compiler-error-context-p context)
635 (reverse
636 (sb-c::compiler-error-context-original-source-path context)))))
637
638 (defimplementation call-with-compilation-hooks (function)
639 (declare (type function function))
640 (handler-bind
641 ;; N.B. Even though these handlers are called HANDLE-FOO they
642 ;; actually decline, i.e. the signalling of the original
643 ;; condition continues upward.
644 ((sb-c:fatal-compiler-error #'handle-notification-condition)
645 (sb-c:compiler-error #'handle-notification-condition)
646 (sb-ext:compiler-note #'handle-notification-condition)
647 (error #'handle-notification-condition)
648 (warning #'handle-notification-condition))
649 (funcall function)))
650
651
652 (defvar *trap-load-time-warnings* t)
653
654 (defun compiler-policy (qualities)
655 "Return compiler policy qualities present in the QUALITIES alist.
656 QUALITIES is an alist with (quality . value)"
657 #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
658 (loop with policy = (sb-ext:restrict-compiler-policy)
659 for (quality) in qualities
660 collect (cons quality
661 (or (cdr (assoc quality policy))
662 0))))
663
664 (defun (setf compiler-policy) (policy)
665 (declare (ignorable policy))
666 #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
667 (loop for (qual . value) in policy
668 do (sb-ext:restrict-compiler-policy qual value)))
669
670 (defmacro with-compiler-policy (policy &body body)
671 (let ((current-policy (gensym)))
672 `(let ((,current-policy (compiler-policy ,policy)))
673 (setf (compiler-policy) ,policy)
674 (unwind-protect (progn ,@body)
675 (setf (compiler-policy) ,current-policy)))))
676
677 (defimplementation swank-compile-file (input-file output-file
678 load-p external-format
679 &key policy)
680 (multiple-value-bind (output-file warnings-p failure-p)
681 (with-compiler-policy policy
682 (with-compilation-hooks ()
683 (compile-file input-file :output-file output-file
684 :external-format external-format)))
685 (values output-file warnings-p
686 (or failure-p
687 (when load-p
688 ;; Cache the latest source file for definition-finding.
689 (source-cache-get input-file
690 (file-write-date input-file))
691 (not (load output-file)))))))
692
693 ;;;; compile-string
694
695 ;;; We copy the string to a temporary file in order to get adequate
696 ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
697 ;;; which the previous approach using
698 ;;; (compile nil `(lambda () ,(read-from-string string)))
699 ;;; did not provide.
700
701 (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
702
703 (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
704 sb-alien:c-string
705 (dir sb-alien:c-string)
706 (prefix sb-alien:c-string))
707
708 )
709
710 (defun temp-file-name ()
711 "Return a temporary file name to compile strings into."
712 (tempnam nil nil))
713
714 (defimplementation swank-compile-string (string &key buffer position filename
715 policy)
716 (let ((*buffer-name* buffer)
717 (*buffer-offset* position)
718 (*buffer-substring* string)
719 (*buffer-tmpfile* (temp-file-name)))
720 (flet ((load-it (filename)
721 (when filename (load filename)))
722 (compile-it (cont)
723 (with-compilation-hooks ()
724 (with-compilation-unit
725 (:source-plist (list :emacs-buffer buffer
726 :emacs-filename filename
727 :emacs-string string
728 :emacs-position position)
729 :source-namestring filename
730 :allow-other-keys t)
731 (multiple-value-bind (output-file warningsp failurep)
732 (compile-file *buffer-tmpfile*)
733 (declare (ignore warningsp))
734 (unless failurep
735 (funcall cont output-file)))))))
736 (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error)
737 (write-string string s))
738 (unwind-protect
739 (with-compiler-policy policy
740 (if *trap-load-time-warnings*
741 (compile-it #'load-it)
742 (load-it (compile-it #'identity))))
743 (ignore-errors
744 (delete-file *buffer-tmpfile*)
745 (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
746
747 ;;;; Definitions
748
749 (defparameter *definition-types*
750 '(:variable defvar
751 :constant defconstant
752 :type deftype
753 :symbol-macro define-symbol-macro
754 :macro defmacro
755 :compiler-macro define-compiler-macro
756 :function defun
757 :generic-function defgeneric
758 :method defmethod
759 :setf-expander define-setf-expander
760 :structure defstruct
761 :condition define-condition
762 :class defclass
763 :method-combination define-method-combination
764 :package defpackage
765 :transform :deftransform
766 :optimizer :defoptimizer
767 :vop :define-vop
768 :source-transform :define-source-transform)
769 "Map SB-INTROSPECT definition type names to Slime-friendly forms")
770
771 (defun definition-specifier (type name)
772 "Return a pretty specifier for NAME representing a definition of type TYPE."
773 (if (and (symbolp name)
774 (eq type :function)
775 (sb-int:info :function :ir1-convert name))
776 :def-ir1-translator
777 (getf *definition-types* type)))
778
779 (defun make-dspec (type name source-location)
780 (let ((spec (definition-specifier type name))
781 (desc (sb-introspect::definition-source-description source-location)))
782 (if (eq :define-vop spec)
783 ;; The first part of the VOP description is the name of the template
784 ;; -- which is actually good information and often long. So elide the
785 ;; original name in favor of making the interesting bit more visible.
786 ;;
787 ;; The second part of the VOP description is the associated compiler note, or
788 ;; NIL -- which is quite uninteresting and confuses the eye when reading the actual
789 ;; name which usually has a worthwhile postfix. So drop the note.
790 (list spec (car desc))
791 (list* spec name desc))))
792
793 (defimplementation find-definitions (name)
794 (loop for type in *definition-types* by #'cddr
795 for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
796 append (loop for defsrc in defsrcs collect
797 (list (make-dspec type name defsrc)
798 (converting-errors-to-error-location
799 (definition-source-for-emacs defsrc type name))))))
800
801 (defimplementation find-source-location (obj)
802 (flet ((general-type-of (obj)
803 (typecase obj
804 (method :method)
805 (generic-function :generic-function)
806 (function :function)
807 (structure-class :structure-class)
808 (class :class)
809 (method-combination :method-combination)
810 (package :package)
811 (condition :condition)
812 (structure-object :structure-object)
813 (standard-object :standard-object)
814 (t :thing)))
815 (to-string (obj)
816 (typecase obj
817 (package (princ-to-string obj)) ; Packages are possibly named entities.
818 ((or structure-object standard-object condition)
819 (with-output-to-string (s)
820 (print-unreadable-object (obj s :type t :identity t))))
821 (t (princ-to-string obj)))))
822 (converting-errors-to-error-location
823 (let ((defsrc (sb-introspect:find-definition-source obj)))
824 (definition-source-for-emacs defsrc
825 (general-type-of obj)
826 (to-string obj))))))
827
828
829 (defun categorize-definition-source (definition-source)
830 (with-struct (sb-introspect::definition-source-
831 pathname form-path character-offset plist)
832 definition-source
833 (cond ((getf plist :emacs-buffer) :buffer)
834 ((and pathname (or form-path character-offset)) :file)
835 (pathname :file-without-position)
836 (t :invalid))))
837
838 (defun definition-source-for-emacs (definition-source type name)
839 (with-struct (sb-introspect::definition-source-
840 pathname form-path character-offset plist
841 file-write-date)
842 definition-source
843 (ecase (categorize-definition-source definition-source)
844 (:buffer
845 (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
846 emacs-string &allow-other-keys)
847 plist
848 (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
849 (multiple-value-bind (start end)
850 (if form-path
851 (with-debootstrapping
852 (source-path-string-position form-path emacs-string))
853 (values character-offset most-positive-fixnum))
854 (make-location
855 `(:buffer ,emacs-buffer)
856 `(:offset ,emacs-position ,start)
857 `(:snippet
858 ,(subseq emacs-string
859 start
860 (min end (+ start *source-snippet-size*)))))))))
861 (:file
862 (let* ((namestring (namestring (translate-logical-pathname pathname)))
863 (pos (if form-path
864 (source-file-position namestring file-write-date form-path)
865 character-offset))
866 (snippet (source-hint-snippet namestring file-write-date pos)))
867 (make-location `(:file ,namestring)
868 ;; /file positions/ in Common Lisp start from
869 ;; 0, buffer positions in Emacs start from 1.
870 `(:position ,(1+ pos))
871 `(:snippet ,snippet))))
872 (:file-without-position
873 (make-location `(:file ,(namestring (translate-logical-pathname pathname)))
874 '(:position 1)
875 (when (eql type :function)
876 `(:snippet ,(format nil "(defun ~a " (symbol-name name))))))
877 (:invalid
878 (error "DEFINITION-SOURCE of ~A ~A did not contain ~
879 meaningful information."
880 (string-downcase type) name)))))
881
882 (defun source-file-position (filename write-date form-path)
883 (let ((source (get-source-code filename write-date))
884 (*readtable* (guess-readtable-for-filename filename)))
885 (with-debootstrapping
886 (source-path-string-position form-path source))))
887
888 (defun source-hint-snippet (filename write-date position)
889 (read-snippet-from-string (get-source-code filename write-date) position))
890
891 (defun function-source-location (function &optional name)
892 (declare (type function function))
893 (definition-source-for-emacs (sb-introspect:find-definition-source function)
894 :function
895 (or name (function-name function))))
896
897 (defimplementation describe-symbol-for-emacs (symbol)
898 "Return a plist describing SYMBOL.
899 Return NIL if the symbol is unbound."
900 (let ((result '()))
901 (flet ((doc (kind)
902 (or (documentation symbol kind) :not-documented))
903 (maybe-push (property value)
904 (when value
905 (setf result (list* property value result)))))
906 (maybe-push
907 :variable (multiple-value-bind (kind recorded-p)
908 (sb-int:info :variable :kind symbol)
909 (declare (ignore kind))
910 (if (or (boundp symbol) recorded-p)
911 (doc 'variable))))
912 (when (fboundp symbol)
913 (maybe-push
914 (cond ((macro-function symbol) :macro)
915 ((special-operator-p symbol) :special-operator)
916 ((typep (fdefinition symbol) 'generic-function)
917 :generic-function)
918 (t :function))
919 (doc 'function)))
920 (maybe-push
921 :setf (if (or (sb-int:info :setf :inverse symbol)
922 (sb-int:info :setf :expander symbol))
923 (doc 'setf)))
924 (maybe-push
925 :type (if (sb-int:info :type :kind symbol)
926 (doc 'type)))
927 result)))
928
929 (defimplementation describe-definition (symbol type)
930 (case type
931 (:variable
932 (describe symbol))
933 (:function
934 (describe (symbol-function symbol)))
935 (:setf
936 (describe (or (sb-int:info :setf :inverse symbol)
937 (sb-int:info :setf :expander symbol))))
938 (:class
939 (describe (find-class symbol)))
940 (:type
941 (describe (sb-kernel:values-specifier-type symbol)))))
942
943 #+#.(swank-backend::sbcl-with-xref-p)
944 (progn
945 (defmacro defxref (name &optional fn-name)
946 `(defimplementation ,name (what)
947 (sanitize-xrefs
948 (mapcar #'source-location-for-xref-data
949 (,(find-symbol (symbol-name (if fn-name
950 fn-name
951 name))
952 "SB-INTROSPECT")
953 what)))))
954 (defxref who-calls)
955 (defxref who-binds)
956 (defxref who-sets)
957 (defxref who-references)
958 (defxref who-macroexpands)
959 #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
960 (defxref who-specializes who-specializes-directly))
961
962 (defun source-location-for-xref-data (xref-data)
963 (destructuring-bind (name . defsrc) xref-data
964 (list name (converting-errors-to-error-location
965 (definition-source-for-emacs defsrc 'function name)))))
966
967 (defimplementation list-callers (symbol)
968 (let ((fn (fdefinition symbol)))
969 (sanitize-xrefs
970 (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
971
972 (defimplementation list-callees (symbol)
973 (let ((fn (fdefinition symbol)))
974 (sanitize-xrefs
975 (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
976
977 (defun sanitize-xrefs (xrefs)
978 (remove-duplicates
979 (remove-if (lambda (f)
980 (member f (ignored-xref-function-names)))
981 (loop for entry in xrefs
982 for name = (car entry)
983 collect (if (and (consp name)
984 (member (car name)
985 '(sb-pcl::fast-method
986 sb-pcl::slow-method
987 sb-pcl::method)))
988 (cons (cons 'defmethod (cdr name))
989 (cdr entry))
990 entry))
991 :key #'car)
992 :test (lambda (a b)
993 (and (eq (first a) (first b))
994 (equal (second a) (second b))))))
995
996 (defun ignored-xref-function-names ()
997 #-#.(swank-backend::sbcl-with-new-stepper-p)
998 '(nil sb-c::step-form sb-c::step-values)
999 #+#.(swank-backend::sbcl-with-new-stepper-p)
1000 '(nil))
1001
1002 (defun function-dspec (fn)
1003 "Describe where the function FN was defined.
1004 Return a list of the form (NAME LOCATION)."
1005 (let ((name (function-name fn)))
1006 (list name (converting-errors-to-error-location
1007 (function-source-location fn name)))))
1008
1009 ;;; macroexpansion
1010
1011 (defimplementation macroexpand-all (form)
1012 (let ((sb-walker:*walk-form-expand-macros-p* t))
1013 (sb-walker:walk-form form)))
1014
1015
1016 ;;; Debugging
1017
1018 ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
1019 ;;; than just a hook into BREAK. In particular, it'll make
1020 ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1021 ;;; than the native debugger. That should probably be considered a
1022 ;;; feature.
1023
1024 (defun make-invoke-debugger-hook (hook)
1025 (when hook
1026 #'(sb-int:named-lambda swank-invoke-debugger-hook
1027 (condition old-hook)
1028 (if *debugger-hook*
1029 nil ; decline, *DEBUGGER-HOOK* will be tried next.
1030 (funcall hook condition old-hook)))))
1031
1032 (defun set-break-hook (hook)
1033 (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1034
1035 (defun call-with-break-hook (hook continuation)
1036 (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1037 (funcall continuation)))
1038
1039 (defimplementation install-debugger-globally (function)
1040 (setq *debugger-hook* function)
1041 (set-break-hook function))
1042
1043 (defimplementation condition-extras (condition)
1044 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1045 ((typep condition 'sb-impl::step-form-condition)
1046 `((:show-frame-source 0)))
1047 ((typep condition 'sb-int:reference-condition)
1048 (let ((refs (sb-int:reference-condition-references condition)))
1049 (if refs
1050 `((:references ,(externalize-reference refs))))))))
1051
1052 (defun externalize-reference (ref)
1053 (etypecase ref
1054 (null nil)
1055 (cons (cons (externalize-reference (car ref))
1056 (externalize-reference (cdr ref))))
1057 ((or string number) ref)
1058 (symbol
1059 (cond ((eq (symbol-package ref) (symbol-package :test))
1060 ref)
1061 (t (symbol-name ref))))))
1062
1063 (defvar *sldb-stack-top*)
1064
1065 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1066 (declare (type function debugger-loop-fn))
1067 (let* ((*sldb-stack-top* (if *debug-swank-backend*
1068 (sb-di:top-frame)
1069 (or sb-debug:*stack-top-hint* (sb-di:top-frame))))
1070 (sb-debug:*stack-top-hint* nil))
1071 (handler-bind ((sb-di:debug-condition
1072 (lambda (condition)
1073 (signal (make-condition
1074 'sldb-condition
1075 :original-condition condition)))))
1076 (funcall debugger-loop-fn))))
1077
1078 #+#.(swank-backend::sbcl-with-new-stepper-p)
1079 (progn
1080 (defimplementation activate-stepping (frame)
1081 (declare (ignore frame))
1082 (sb-impl::enable-stepping))
1083 (defimplementation sldb-stepper-condition-p (condition)
1084 (typep condition 'sb-ext:step-form-condition))
1085 (defimplementation sldb-step-into ()
1086 (invoke-restart 'sb-ext:step-into))
1087 (defimplementation sldb-step-next ()
1088 (invoke-restart 'sb-ext:step-next))
1089 (defimplementation sldb-step-out ()
1090 (invoke-restart 'sb-ext:step-out)))
1091
1092 (defimplementation call-with-debugger-hook (hook fun)
1093 (let ((*debugger-hook* hook)
1094 #+#.(swank-backend::sbcl-with-new-stepper-p)
1095 (sb-ext:*stepper-hook*
1096 (lambda (condition)
1097 (typecase condition
1098 (sb-ext:step-form-condition
1099 (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1100 (sb-impl::invoke-debugger condition)))))))
1101 (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1102 (sb-ext:step-condition #'sb-impl::invoke-stepper))
1103 (call-with-break-hook hook fun))))
1104
1105 (defun nth-frame (index)
1106 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1107 (i index (1- i)))
1108 ((zerop i) frame)))
1109
1110 (defimplementation compute-backtrace (start end)
1111 "Return a list of frames starting with frame number START and
1112 continuing to frame number END or, if END is nil, the last frame on the
1113 stack."
1114 (let ((end (or end most-positive-fixnum)))
1115 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1116 for i from start below end
1117 while f collect f)))
1118
1119 (defimplementation print-frame (frame stream)
1120 (sb-debug::print-frame-call frame stream))
1121
1122 (defimplementation frame-restartable-p (frame)
1123 #+#.(swank-backend::sbcl-with-restart-frame)
1124 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1125
1126 (defimplementation frame-call (frame-number)
1127 (multiple-value-bind (name args)
1128 (sb-debug::frame-call (nth-frame frame-number))
1129 (with-output-to-string (stream)
1130 (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1131 (let ((*print-length* nil)
1132 (*print-level* nil))
1133 (prin1 (sb-debug::ensure-printable-object name) stream))
1134 (let ((args (sb-debug::ensure-printable-object args)))
1135 (if (listp args)
1136 (format stream "~{ ~_~S~}" args)
1137 (format stream " ~S" args)))))))
1138
1139 ;;;; Code-location -> source-location translation
1140
1141 ;;; If debug-block info is avaibale, we determine the file position of
1142 ;;; the source-path for a code-location. If the code was compiled
1143 ;;; with C-c C-c, we have to search the position in the source string.
1144 ;;; If there's no debug-block info, we return the (less precise)
1145 ;;; source-location of the corresponding function.
1146
1147 (defun code-location-source-location (code-location)
1148 (let* ((dsource (sb-di:code-location-debug-source code-location))
1149 (plist (sb-c::debug-source-plist dsource)))
1150 (if (getf plist :emacs-buffer)
1151 (emacs-buffer-source-location code-location plist)
1152 #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1153 (ecase (sb-di:debug-source-from dsource)
1154 (:file (file-source-location code-location))
1155 (:lisp (lisp-source-location code-location)))
1156 #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1157 (if (sb-di:debug-source-namestring dsource)
1158 (file-source-location code-location)
1159 (lisp-source-location code-location)))))
1160
1161 ;;; FIXME: The naming policy of source-location functions is a bit
1162 ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1163 ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1164 ;;; which returns the source location for a _code-location_.
1165 ;;;
1166 ;;; Maybe these should be named code-location-file-source-location,
1167 ;;; etc, turned into generic functions, or something. In the very
1168 ;;; least the names should indicate the main entry point vs. helper
1169 ;;; status.
1170
1171 (defun file-source-location (code-location)
1172 (if (code-location-has-debug-block-info-p code-location)
1173 (source-file-source-location code-location)
1174 (fallback-source-location code-location)))
1175
1176 (defun fallback-source-location (code-location)
1177 (let ((fun (code-location-debug-fun-fun code-location)))
1178 (cond (fun (function-source-location fun))
1179 (t (error "Cannot find source location for: ~A " code-location)))))
1180
1181 (defun lisp-source-location (code-location)
1182 (let ((source (prin1-to-string
1183 (sb-debug::code-location-source-form code-location 100))))
1184 (make-location `(:source-form ,source) '(:position 1))))
1185
1186 (defun emacs-buffer-source-location (code-location plist)
1187 (if (code-location-has-debug-block-info-p code-location)
1188 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1189 &allow-other-keys)
1190 plist
1191 (let* ((pos (string-source-position code-location emacs-string))
1192 (snipped (read-snippet-from-string emacs-string pos)))
1193 (make-location `(:buffer ,emacs-buffer)
1194 `(:offset ,emacs-position ,pos)
1195 `(:snippet ,snipped))))
1196 (fallback-source-location code-location)))
1197
1198 (defun source-file-source-location (code-location)
1199 (let* ((code-date (code-location-debug-source-created code-location))
1200 (filename (code-location-debug-source-name code-location))
1201 (*readtable* (guess-readtable-for-filename filename))
1202 (source-code (get-source-code filename code-date)))
1203 (with-debootstrapping
1204 (with-input-from-string (s source-code)
1205 (let* ((pos (stream-source-position code-location s))
1206 (snippet (read-snippet s pos)))
1207 (make-location `(:file ,filename)
1208 `(:position ,pos)
1209 `(:snippet ,snippet)))))))
1210
1211 (defun code-location-debug-source-name (code-location)
1212 (namestring (truename (#+#.(swank-backend:with-symbol
1213 'debug-source-name 'sb-di)
1214 sb-c::debug-source-name
1215 #-#.(swank-backend:with-symbol
1216 'debug-source-name 'sb-di)
1217 sb-c::debug-source-namestring
1218 (sb-di::code-location-debug-source code-location)))))
1219
1220 (defun code-location-debug-source-created (code-location)
1221 (sb-c::debug-source-created
1222 (sb-di::code-location-debug-source code-location)))
1223
1224 (defun code-location-debug-fun-fun (code-location)
1225 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1226
1227 (defun code-location-has-debug-block-info-p (code-location)
1228 (handler-case
1229 (progn (sb-di:code-location-debug-block code-location)
1230 t)
1231 (sb-di:no-debug-blocks () nil)))
1232
1233 (defun stream-source-position (code-location stream)
1234 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1235 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1236 (form-number (sb-di::code-location-form-number cloc)))
1237 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1238 (let* ((path-table (sb-di::form-number-translations tlf 0))
1239 (path (cond ((<= (length path-table) form-number)
1240 (warn "inconsistent form-number-translations")
1241 (list 0))
1242 (t
1243 (reverse (cdr (aref path-table form-number)))))))
1244 (source-path-source-position path tlf pos-map)))))
1245
1246 (defun string-source-position (code-location string)
1247 (with-input-from-string (s string)
1248 (stream-source-position code-location s)))
1249
1250 ;;; source-path-file-position and friends are in swank-source-path-parser
1251
1252 (defimplementation frame-source-location (index)
1253 (converting-errors-to-error-location
1254 (code-location-source-location
1255 (sb-di:frame-code-location (nth-frame index)))))
1256
1257 (defun frame-debug-vars (frame)
1258 "Return a vector of debug-variables in frame."
1259 (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1260
1261 (defun debug-var-value (var frame location)
1262 (ecase (sb-di:debug-var-validity var location)
1263 (:valid (sb-di:debug-var-value var frame))
1264 ((:invalid :unknown) ':<not-available>)))
1265
1266 (defun debug-var-info (var)
1267 ;; Introduced by SBCL 1.0.49.76.
1268 (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1269 (when (and s (fboundp s))
1270 (funcall s var))))
1271
1272 (defimplementation frame-locals (index)
1273 (let* ((frame (nth-frame index))
1274 (loc (sb-di:frame-code-location frame))
1275 (vars (frame-debug-vars frame))
1276 ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1277 ;; specially.
1278 (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1279 (more-context nil)
1280 (more-count nil)
1281 (more-id 0))
1282 (when vars
1283 (let ((locals
1284 (loop for v across vars
1285 do (when (eq (sb-di:debug-var-symbol v) more-name)
1286 (incf more-id))
1287 (case (debug-var-info v)
1288 (:more-context
1289 (setf more-context (debug-var-value v frame loc)))
1290 (:more-count
1291 (setf more-count (debug-var-value v frame loc))))
1292 collect
1293 (list :name (sb-di:debug-var-symbol v)
1294 :id (sb-di:debug-var-id v)
1295 :value (debug-var-value v frame loc)))))
1296 (when (and more-context more-count)
1297 (setf locals (append locals
1298 (list
1299 (list :name more-name
1300 :id more-id
1301 :value (multiple-value-list
1302 (sb-c:%more-arg-values more-context
1303 0 more-count)))))))
1304 locals))))
1305
1306 (defimplementation frame-var-value (frame var)
1307 (let* ((frame (nth-frame frame))
1308 (vars (frame-debug-vars frame))
1309 (loc (sb-di:frame-code-location frame))
1310 (dvar (if (= var (length vars))
1311 ;; If VAR is out of bounds, it must be the fake var we made up for
1312 ;; &MORE.
1313 (let* ((context-var (find :more-context vars :key #'debug-var-info))
1314 (more-context (debug-var-value context-var frame loc))
1315 (count-var (find :more-count vars :key #'debug-var-info))
1316 (more-count (debug-var-value count-var frame loc)))
1317 (return-from frame-var-value
1318 (multiple-value-list (sb-c:%more-arg-values more-context
1319 0 more-count))))
1320 (aref vars var))))
1321 (debug-var-value dvar frame loc)))
1322
1323 (defimplementation frame-catch-tags (index)
1324 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1325
1326 (defimplementation eval-in-frame (form index)
1327 (let ((frame (nth-frame index)))
1328 (funcall (the function
1329 (sb-di:preprocess-for-eval form
1330 (sb-di:frame-code-location frame)))
1331 frame)))
1332
1333 #+#.(swank-backend::sbcl-with-restart-frame)
1334 (progn
1335 (defimplementation return-from-frame (index form)
1336 (let* ((frame (nth-frame index)))
1337 (cond ((sb-debug:frame-has-debug-tag-p frame)
1338 (let ((values (multiple-value-list (eval-in-frame form index))))
1339 (sb-debug:unwind-to-frame-and-call frame
1340 (lambda ()
1341 (values-list values)))))
1342 (t (format nil "Cannot return from frame: ~S" frame)))))
1343
1344 (defimplementation restart-frame (index)
1345 (let ((frame (nth-frame index)))
1346 (when (sb-debug:frame-has-debug-tag-p frame)
1347 (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1348 (multiple-value-bind (fun arglist)
1349 (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1350 (values (fdefinition fname) args)
1351 (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1352 (sb-debug::frame-args-as-list frame)))
1353 (when (functionp fun)
1354 (sb-debug:unwind-to-frame-and-call frame
1355 (lambda ()
1356 ;; Ensure TCO.
1357 (declare (optimize (debug 0)))
1358 (apply fun arglist)))))))
1359 (format nil "Cannot restart frame: ~S" frame))))
1360
1361 ;; FIXME: this implementation doesn't unwind the stack before
1362 ;; re-invoking the function, but it's better than no implementation at
1363 ;; all.
1364 #-#.(swank-backend::sbcl-with-restart-frame)
1365 (progn
1366 (defun sb-debug-catch-tag-p (tag)
1367 (and (symbolp tag)
1368 (not (symbol-package tag))
1369 (string= tag :sb-debug-catch-tag)))
1370
1371 (defimplementation return-from-frame (index form)
1372 (let* ((frame (nth-frame index))
1373 (probe (assoc-if #'sb-debug-catch-tag-p
1374 (sb-di::frame-catches frame))))
1375 (cond (probe (throw (car probe) (eval-in-frame form index)))
1376 (t (format nil "Cannot return from frame: ~S" frame)))))
1377
1378 (defimplementation restart-frame (index)
1379 (let ((frame (nth-frame index)))
1380 (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1381
1382 ;;;;; reference-conditions
1383
1384 (defimplementation format-sldb-condition (condition)
1385 (let ((sb-int:*print-condition-references* nil))
1386 (princ-to-string condition)))
1387
1388
1389 ;;;; Profiling
1390
1391 (defimplementation profile (fname)
1392 (when fname (eval `(sb-profile:profile ,fname))))
1393
1394 (defimplementation unprofile (fname)
1395 (when fname (eval `(sb-profile:unprofile ,fname))))
1396
1397 (defimplementation unprofile-all ()
1398 (sb-profile:unprofile)
1399 "All functions unprofiled.")
1400
1401 (defimplementation profile-report ()
1402 (sb-profile:report))
1403
1404 (defimplementation profile-reset ()
1405 (sb-profile:reset)
1406 "Reset profiling counters.")
1407
1408 (defimplementation profiled-functions ()
1409 (sb-profile:profile))
1410
1411 (defimplementation profile-package (package callers methods)
1412 (declare (ignore callers methods))
1413 (eval `(sb-profile:profile ,(package-name (find-package package)))))
1414
1415
1416 ;;;; Inspector
1417
1418 (defmethod emacs-inspect ((o t))
1419 (cond ((sb-di::indirect-value-cell-p o)
1420 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1421 (t
1422 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1423 (list* (string-right-trim '(#\Newline) text)
1424 '(:newline)
1425 (if label
1426 (loop for (l . v) in parts
1427 append (label-value-line l v))
1428 (loop for value in parts
1429 for i from 0
1430 append (label-value-line i value))))))))
1431
1432 (defmethod emacs-inspect ((o function))
1433 (let ((header (sb-kernel:widetag-of o)))
1434 (cond ((= header sb-vm:simple-fun-header-widetag)
1435 (label-value-line*
1436 (:name (sb-kernel:%simple-fun-name o))
1437 (:arglist (sb-kernel:%simple-fun-arglist o))
1438 (:self (sb-kernel:%simple-fun-self o))
1439 (:next (sb-kernel:%simple-fun-next o))
1440 (:type (sb-kernel:%simple-fun-type o))
1441 (:code (sb-kernel:fun-code-header o))))
1442 ((= header sb-vm:closure-header-widetag)
1443 (append
1444 (label-value-line :function (sb-kernel:%closure-fun o))
1445 `("Closed over values:" (:newline))
1446 (loop for i below (1- (sb-kernel:get-closure-length o))
1447 append (label-value-line
1448 i (sb-kernel:%closure-index-ref o i)))))
1449 (t (call-next-method o)))))
1450
1451 (defmethod emacs-inspect ((o sb-kernel:code-component))
1452 (append
1453 (label-value-line*
1454 (:code-size (sb-kernel:%code-code-size o))
1455 (:entry-points (sb-kernel:%code-entry-points o))
1456 (:debug-info (sb-kernel:%code-debug-info o))
1457 (:trace-table-offset (sb-kernel:code-header-ref
1458 o sb-vm:code-trace-table-offset-slot)))
1459 `("Constants:" (:newline))
1460 (loop for i from sb-vm:code-constants-offset
1461 below (sb-kernel:get-header-data o)
1462 append (label-value-line i (sb-kernel:code-header-ref o i)))
1463 `("Code:" (:newline)
1464 , (with-output-to-string (s)
1465 (cond ((sb-kernel:%code-debug-info o)
1466 (sb-disassem:disassemble-code-component o :stream s))
1467 (t
1468 (sb-disassem:disassemble-memory
1469 (sb-disassem::align
1470 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1471 sb-vm:lowtag-mask)
1472 (* sb-vm:code-constants-offset
1473 sb-vm:n-word-bytes))
1474 (ash 1 sb-vm:n-lowtag-bits))
1475 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1476 :stream s)))))))
1477
1478 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1479 (label-value-line*
1480 (:value (sb-ext:weak-pointer-value o))))
1481
1482 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1483 (label-value-line*
1484 (:name (sb-kernel:fdefn-name o))
1485 (:function (sb-kernel:fdefn-fun o))))
1486
1487 (defmethod emacs-inspect :around ((o generic-function))
1488 (append
1489 (call-next-method)
1490 (label-value-line*
1491 (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1492 (:initial-methods (sb-pcl::generic-function-initial-methods o))
1493 )))
1494
1495
1496 ;;;; Multiprocessing
1497
1498 #+(and sb-thread
1499 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1500 (progn
1501 (defvar *thread-id-counter* 0)
1502
1503 (defvar *thread-id-counter-lock*
1504 (sb-thread:make-mutex :name "thread id counter lock"))
1505
1506 (defun next-thread-id ()
1507 (sb-thread:with-mutex (*thread-id-counter-lock*)
1508 (incf *thread-id-counter*)))
1509
1510 (defparameter *thread-id-map* (make-hash-table))
1511
1512 ;; This should be a thread -> id map but as weak keys are not
1513 ;; supported it is id -> map instead.
1514 (defvar *thread-id-map-lock*
1515 (sb-thread:make-mutex :name "thread id map lock"))
1516
1517 (defimplementation spawn (fn &key name)
1518 (sb-thread:make-thread fn :name name))
1519
1520 (defimplementation thread-id (thread)
1521 (block thread-id
1522 (sb-thread:with-mutex (*thread-id-map-lock*)
1523 (loop for id being the hash-key in *thread-id-map*
1524 using (hash-value thread-pointer)
1525 do
1526 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1527 (cond ((null maybe-thread)
1528 ;; the value is gc'd, remove it manually
1529 (remhash id *thread-id-map*))
1530 ((eq thread maybe-thread)
1531 (return-from thread-id id)))))
1532 ;; lazy numbering
1533 (let ((id (next-thread-id)))
1534 (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1535 id))))
1536
1537 (defimplementation find-thread (id)
1538 (sb-thread:with-mutex (*thread-id-map-lock*)
1539 (let ((thread-pointer (gethash id *thread-id-map*)))
1540 (if thread-pointer
1541 (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1542 (if maybe-thread
1543 maybe-thread
1544 ;; the value is gc'd, remove it manually
1545 (progn
1546 (remhash id *thread-id-map*)
1547 nil)))
1548 nil))))
1549
1550 (defimplementation thread-name (thread)
1551 ;; sometimes the name is not a string (e.g. NIL)
1552 (princ-to-string (sb-thread:thread-name thread)))
1553
1554 (defimplementation thread-status (thread)
1555 (if (sb-thread:thread-alive-p thread)
1556 "Running"
1557 "Stopped"))
1558
1559 (defimplementation make-lock (&key name)
1560 (sb-thread:make-mutex :name name))
1561
1562 (defimplementation call-with-lock-held (lock function)
1563 (declare (type function function))
1564 (sb-thread:with-recursive-lock (lock) (funcall function)))
1565
1566 (defimplementation current-thread ()
1567 sb-thread:*current-thread*)
1568
1569 (defimplementation all-threads ()
1570 (sb-thread:list-all-threads))
1571
1572 (defimplementation interrupt-thread (thread fn)
1573 (sb-thread:interrupt-thread thread fn))
1574
1575 (defimplementation kill-thread (thread)
1576 (sb-thread:terminate-thread thread))
1577
1578 (defimplementation thread-alive-p (thread)
1579 (sb-thread:thread-alive-p thread))
1580
1581 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1582 (defvar *mailboxes* (list))
1583 (declaim (type list *mailboxes*))
1584
1585 (defstruct (mailbox (:conc-name mailbox.))
1586 thread
1587 (mutex (sb-thread:make-mutex))
1588 (waitqueue (sb-thread:make-waitqueue))
1589 (queue '() :type list))
1590
1591 (defun mailbox (thread)
1592 "Return THREAD's mailbox."
1593 (sb-thread:with-mutex (*mailbox-lock*)
1594 (or (find thread *mailboxes* :key #'mailbox.thread)
1595 (let ((mb (make-mailbox :thread thread)))
1596 (push mb *mailboxes*)
1597 mb))))
1598
1599 (defimplementation send (thread message)
1600 (let* ((mbox (mailbox thread))
1601 (mutex (mailbox.mutex mbox)))
1602 (sb-thread:with-mutex (mutex)
1603 (setf (mailbox.queue mbox)
1604 (nconc (mailbox.queue mbox) (list message)))
1605 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1606 #-sb-lutex
1607 (defun condition-timed-wait (waitqueue mutex timeout)
1608 (handler-case
1609 (let ((*break-on-signals* nil))
1610 (sb-sys:with-deadline (:seconds timeout :override t)
1611 (sb-thread:condition-wait waitqueue mutex) t))
1612 (sb-ext:timeout ()
1613 nil)))
1614
1615 ;; FIXME: with-timeout doesn't work properly on Darwin
1616 #+sb-lutex
1617 (defun condition-timed-wait (waitqueue mutex timeout)
1618 (declare (ignore timeout))
1619 (sb-thread:condition-wait waitqueue mutex))
1620
1621 (defimplementation receive-if (test &optional timeout)
1622 (let* ((mbox (mailbox (current-thread)))
1623 (mutex (mailbox.mutex mbox))
1624 (waitq (mailbox.waitqueue mbox)))
1625 (assert (or (not timeout) (eq timeout t)))
1626 (loop
1627 (check-slime-interrupts)
1628 (sb-thread:with-mutex (mutex)
1629 (let* ((q (mailbox.queue mbox))
1630 (tail (member-if test q)))
1631 (when tail
1632 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1633 (return (car tail))))
1634 (when (eq timeout t) (return (values nil t)))
1635 (condition-timed-wait waitq mutex 0.2)))))
1636 )
1637
1638 (defimplementation quit-lisp ()
1639 #+sb-thread
1640 (dolist (thread (remove (current-thread) (all-threads)))
1641 (ignore-errors (sb-thread:terminate-thread thread)))
1642 (sb-ext:quit))
1643
1644
1645
1646 ;;Trace implementations
1647 ;;In SBCL, we have:
1648 ;; (trace <name>)
1649 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1650 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1651 ;; <name> can be a normal name or a (setf name)
1652
1653 (defun toggle-trace-aux (fspec &rest args)
1654 (cond ((member fspec (eval '(trace)) :test #'equal)
1655 (eval `(untrace ,fspec))
1656 (format nil "~S is now untraced." fspec))
1657 (t
1658 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1659 (format nil "~S is now traced." fspec))))
1660
1661 (defun process-fspec (fspec)
1662 (cond ((consp fspec)
1663 (ecase (first fspec)
1664 ((:defun :defgeneric) (second fspec))
1665 ((:defmethod) `(method ,@(rest fspec)))
1666 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1667 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1668 (t
1669 fspec)))
1670
1671 (defimplementation toggle-trace (spec)
1672 (ecase (car spec)
1673 ((setf)
1674 (toggle-trace-aux spec))
1675 ((:defmethod)
1676 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1677 ((:defgeneric)
1678 (toggle-trace-aux (second spec) :methods t))
1679 ((:call)
1680 (destructuring-bind (caller callee) (cdr spec)
1681 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1682
1683 ;;; Weak datastructures
1684
1685 (defimplementation make-weak-key-hash-table (&rest args)
1686 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1687 (apply #'make-hash-table :weakness :key args)
1688 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1689 (apply #'make-hash-table args))
1690
1691 (defimplementation make-weak-value-hash-table (&rest args)
1692 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1693 (apply #'make-hash-table :weakness :value args)
1694 #-#.(swank-backend::sbcl-with-weak-hash-tables)
1695 (apply #'make-hash-table args))
1696
1697 (defimplementation hash-table-weakness (hashtable)
1698 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1699 (sb-ext:hash-table-weakness hashtable))
1700
1701 #-win32
1702 (defimplementation save-image (filename &optional restart-function)
1703 (flet ((restart-sbcl ()
1704 (sb-debug::enable-debugger)
1705 (setf sb-impl::*descriptor-handlers* nil)
1706 (funcall restart-function)))
1707 (let ((pid (sb-posix:fork)))
1708 (cond ((= pid 0)
1709 (sb-debug::disable-debugger)
1710 (apply #'sb-ext:save-lisp-and-die filename
1711 (when restart-function
1712 (list :toplevel #'restart-sbcl))))
1713 (t
1714 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1715 (assert (= pid rpid))
1716 (assert (and (sb-posix:wifexited status)
1717 (zerop (sb-posix:wexitstatus status))))))))))
1718
1719 #+unix
1720 (progn
1721 (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1722 (program sb-alien:c-string)
1723 (argv (* sb-alien:c-string)))
1724
1725 (defun execv (program args)
1726 "Replace current executable with another one."
1727 (let ((a-args (sb-alien:make-alien sb-alien:c-string
1728 (+ 1 (length args)))))
1729 (unwind-protect
1730 (progn
1731 (loop for index from 0 by 1
1732 and item in (append args '(nil))
1733 do (setf (sb-alien:deref a-args index)
1734 item))
1735 (when (minusp
1736 (sys-execv program a-args))
1737 (error "execv(3) returned.")))
1738 (sb-alien:free-alien a-args))))
1739
1740 (defun runtime-pathname ()
1741 #+#.(swank-backend:with-symbol
1742 '*runtime-pathname* 'sb-ext)
1743 sb-ext:*runtime-pathname*
1744 #-#.(swank-backend:with-symbol
1745 '*runtime-pathname* 'sb-ext)
1746 (car sb-ext:*posix-argv*))
1747
1748 (defimplementation exec-image (image-file args)
1749 (loop with fd-arg =
1750 (loop for arg in args
1751 and key = "" then arg
1752 when (string-equal key "--swank-fd")
1753 return (parse-integer arg))
1754 for my-fd from 3 to 1024
1755 when (/= my-fd fd-arg)
1756 do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1757 (let* ((self-string (pathname-to-filename (runtime-pathname))))
1758 (execv
1759 self-string
1760 (apply 'list self-string "--core" image-file args)))))
1761
1762 (defimplementation make-fd-stream (fd external-format)
1763 (sb-sys:make-fd-stream fd :input t :output t
1764 :element-type 'character
1765 :buffering :full
1766 :dual-channel-p t
1767 :external-format external-format))
1768
1769 (defimplementation call-with-io-timeout (function &key seconds)
1770 (handler-case
1771 (sb-sys:with-deadline (:seconds seconds)
1772 (funcall function))
1773 (sb-sys:deadline-timeout ()
1774 nil)))
1775
1776 #-win32
1777 (defimplementation background-save-image (filename &key restart-function
1778 completion-function)
1779 (flet ((restart-sbcl ()
1780 (sb-debug::enable-debugger)
1781 (setf sb-impl::*descriptor-handlers* nil)
1782 (funcall restart-function)))
1783 (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1784 (let ((pid (sb-posix:fork)))
1785 (cond ((= pid 0)
1786 (sb-posix:close pipe-in)
1787 (sb-debug::disable-debugger)
1788 (apply #'sb-ext:save-lisp-and-die filename
1789 (when restart-function
1790 (list :toplevel #'restart-sbcl))))
1791 (t
1792 (sb-posix:close pipe-out)
1793 (sb-sys:add-fd-handler
1794 pipe-in :input
1795 (lambda (fd)
1796 (sb-sys:invalidate-descriptor fd)
1797 (sb-posix:close fd)
1798 (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1799 (assert (= pid rpid))
1800 (assert (sb-posix:wifexited status))
1801 (funcall completion-function
1802 (zerop (sb-posix:wexitstatus status))))))))))))
1803
1804 (defun deinit-log-output ()
1805 ;; Can't hang on to an fd-stream from a previous session.
1806 (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1807 nil))
1808
1809 (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5