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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.274 - (show annotations)
Sat Aug 21 06:39:59 2010 UTC (3 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.273: +91 -11 lines
Snapshot restore support for SBCL.

* swank-backend.lisp (background-save-image): New.
* swank-sbcl.lisp (command-line-args, dup, sys-execv, exec-image)
(make-fd-stream, background-save-image): New.

Add support to save snapshots in backround.

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

  ViewVC Help
Powered by ViewVC 1.1.5