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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.286 - (show annotations)
Tue Aug 9 10:27:25 2011 UTC (2 years, 8 months ago) by nsiivola
Branch: MAIN
Changes since 1.285: +2 -1 lines
sbcl: use explicit :SERVE-EVENTS T with sockets when necessary

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

  ViewVC Help
Powered by ViewVC 1.1.5