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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.214 - (show annotations)
Tue Aug 12 17:54:44 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.213: +15 -0 lines
Add a dump-image function to the loader.

* swank-loader.lisp (dump-image): New.

* swank-backend.lisp (save-image): New interface.

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

  ViewVC Help
Powered by ViewVC 1.1.5