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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5