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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.301 - (show annotations)
Fri Jan 6 09:02:43 2012 UTC (2 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.300: +20 -0 lines
Add a "sentinel thread" to protect access to global lists.

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

  ViewVC Help
Powered by ViewVC 1.1.5