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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5