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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5