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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5