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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.237 - (show annotations)
Sat Mar 7 19:08:03 2009 UTC (5 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.236: +6 -1 lines
	* slime.el (slime-choose-overlay-region): Special case :read-error
	notes regardless of position kind.

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

  ViewVC Help
Powered by ViewVC 1.1.5