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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.124 - (show annotations)
Fri Mar 18 22:23:36 2005 UTC (9 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.123: +279 -208 lines
(swank-compile-string): Re-implemented.  This time with temp-files and
proper source-location tracking.
(install-debug-source-patch, debug-source-for-info-advice): Patch
SBCL's debug-source-for-info so that we can dump our own bits of debug
info.
(temp-file-name, call/temp-file): New utilities.

(function-source-location, code-location-source-path): Rewritten to
handle C-c C-c functions.  Also use the source-path to locate the
position.

(locate-compiler-note): Renamed from resolve-note-location.

(file-source-location, lisp-source-location)
(temp-file-source-location, source-file-source-location)
(string-source-position, code-location-debug-source-info)
(code-location-debug-source-name, code-location-debug-source-created,)
(code-location-debug-fun-fun, code-location-from-emacs-buffer-p)
(function-from-emacs-buffer-p, function-debug-source-info)
(info-from-emacs-buffer-p, code-location-has-debug-block-info-p)
(stream-source-position): Lots of new helper functions.

(with-debootstrapping): Moved upwards so that it can be used for
source location searching.

(source-location-for-emacs): Deleted
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 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require 'sb-bsd-sockets)
16 (require 'sb-introspect)
17 (require 'sb-posix)
18 )
19
20
21 (in-package :swank-backend)
22 (declaim (optimize (debug 2)))
23
24 (import
25 '(sb-gray:fundamental-character-output-stream
26 sb-gray:stream-write-char
27 sb-gray:stream-line-length
28 sb-gray:stream-force-output
29 sb-gray:fundamental-character-input-stream
30 sb-gray:stream-read-char
31 sb-gray:stream-listen
32 sb-gray:stream-unread-char
33 sb-gray:stream-clear-input
34 sb-gray:stream-line-column
35 sb-gray:stream-line-length))
36
37 ;;; swank-mop
38
39 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
40
41 (defun swank-mop:slot-definition-documentation (slot)
42 (sb-pcl::documentation slot t))
43
44 ;;; TCP Server
45
46 (defimplementation preferred-communication-style ()
47 (if (and (sb-int:featurep :sb-thread)
48 (sb-int:featurep :sb-futex))
49 :spawn
50 :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
73 &key (external-format :iso-latin-1-unix))
74 (make-socket-io-stream (accept socket) external-format))
75
76 (defvar *sigio-handlers* '()
77 "List of (key . fn) pairs to be called on SIGIO.")
78
79 (defun sigio-handler (signal code scp)
80 (declare (ignore signal code scp))
81 (mapc (lambda (handler)
82 (funcall (the function (cdr handler))))
83 *sigio-handlers*))
84
85 (defun set-sigio-handler ()
86 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
87 (sigio-handler signal code scp))))
88
89 (defun enable-sigio-on-fd (fd)
90 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
91 (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
92
93 (defimplementation add-sigio-handler (socket fn)
94 (set-sigio-handler)
95 (let ((fd (socket-fd socket)))
96 (format *debug-io* "Adding sigio handler: ~S ~%" fd)
97 (enable-sigio-on-fd fd)
98 (push (cons fd fn) *sigio-handlers*)))
99
100 (defimplementation remove-sigio-handlers (socket)
101 (let ((fd (socket-fd socket)))
102 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
103 (sb-sys:invalidate-descriptor fd))
104 (close socket))
105
106 (defimplementation add-fd-handler (socket fn)
107 (declare (type function fn))
108 (let ((fd (socket-fd socket)))
109 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
110 (sb-sys:add-fd-handler fd :input (lambda (_)
111 _
112 (funcall fn)))))
113
114 (defimplementation remove-fd-handlers (socket)
115 (sb-sys:invalidate-descriptor (socket-fd socket)))
116
117 (defun socket-fd (socket)
118 (etypecase socket
119 (fixnum socket)
120 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
121 (file-stream (sb-sys:fd-stream-fd socket))))
122
123 (defun make-socket-io-stream (socket external-format)
124 (let ((encoding (ecase external-format
125 (:iso-latin-1-unix :iso-8859-1)
126 #+sb-unicode
127 (:utf-8-unix :utf-8))))
128 (sb-bsd-sockets:socket-make-stream socket
129 :output t
130 :input t
131 :element-type 'character
132 #+sb-unicode :external-format
133 #+sb-unicode encoding
134 )))
135
136 (defun accept (socket)
137 "Like socket-accept, but retry on EAGAIN."
138 (loop (handler-case
139 (return (sb-bsd-sockets:socket-accept socket))
140 (sb-bsd-sockets:interrupted-error ()))))
141
142 (defmethod call-without-interrupts (fn)
143 (declare (type function fn))
144 (sb-sys:without-interrupts (funcall fn)))
145
146 (defimplementation getpid ()
147 (sb-posix:getpid))
148
149 (defimplementation lisp-implementation-type-name ()
150 "sbcl")
151
152 (defimplementation quit-lisp ()
153 (sb-ext:quit))
154
155
156 ;;;; Support for SBCL syntax
157
158 (defun feature-in-list-p (feature list)
159 (etypecase feature
160 (symbol (member feature list :test #'eq))
161 (cons (flet ((subfeature-in-list-p (subfeature)
162 (feature-in-list-p subfeature list)))
163 (ecase (first feature)
164 (:or (some #'subfeature-in-list-p (rest feature)))
165 (:and (every #'subfeature-in-list-p (rest feature)))
166 (:not (destructuring-bind (e) (cdr feature)
167 (not (subfeature-in-list-p e)))))))))
168
169 (defun shebang-reader (stream sub-character infix-parameter)
170 (declare (ignore sub-character))
171 (when infix-parameter
172 (error "illegal read syntax: #~D!" infix-parameter))
173 (let ((next-char (read-char stream)))
174 (unless (find next-char "+-")
175 (error "illegal read syntax: #!~C" next-char))
176 ;; When test is not satisfied
177 ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
178 ;; would become "unless test is satisfied"..
179 (when (let* ((*package* (find-package "KEYWORD"))
180 (*read-suppress* nil)
181 (not-p (char= next-char #\-))
182 (feature (read stream)))
183 (if (feature-in-list-p feature *features*)
184 not-p
185 (not not-p)))
186 ;; Read (and discard) a form from input.
187 (let ((*read-suppress* t))
188 (read stream t nil t))))
189 (values))
190
191 (defvar *shebang-readtable*
192 (let ((*readtable* (copy-readtable nil)))
193 (set-dispatch-macro-character #\# #\!
194 (lambda (s c n) (shebang-reader s c n))
195 *readtable*)
196 *readtable*))
197
198 (defun shebang-readtable ()
199 *shebang-readtable*)
200
201 (defun sbcl-package-p (package)
202 (let ((name (package-name package)))
203 (eql (mismatch "SB-" name) 3)))
204
205 (defvar *debootstrap-packages* t)
206
207 (defmacro with-debootstrapping (&body body)
208 (let ((not-found (find-symbol "BOOTSTRAP-PACKAGE-NOT-FOUND" "SB-INT"))
209 (debootstrap (find-symbol "DEBOOTSTRAP-PACKAGE" "SB-INT")))
210 (if (and not-found debootstrap)
211 `(handler-bind ((,not-found #',debootstrap)) ,@body)
212 `(progn ,@body))))
213
214 (defimplementation call-with-syntax-hooks (fn)
215 (cond ((and *debootstrap-packages*
216 (sbcl-package-p *package*))
217 (with-debootstrapping (funcall fn)))
218 (t
219 (funcall fn))))
220
221 (defimplementation default-readtable-alist ()
222 (let ((readtable (shebang-readtable)))
223 (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
224 collect (cons (package-name p) readtable))))
225
226 ;;; Utilities
227
228 (defimplementation arglist ((fname t))
229 (sb-introspect:function-arglist fname))
230
231 (defimplementation function-name ((f function))
232 (sb-impl::%fun-name f))
233
234 (defvar *buffer-name* nil)
235 (defvar *buffer-offset*)
236 (defvar *buffer-substring* nil)
237
238 (defvar *previous-compiler-condition* nil
239 "Used to detect duplicates.")
240
241 (defun handle-notification-condition (condition)
242 "Handle a condition caused by a compiler warning.
243 This traps all compiler conditions at a lower-level than using
244 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
245 craft our own error messages, which can omit a lot of redundant
246 information."
247 (let ((context (sb-c::find-error-context nil)))
248 (unless (eq condition *previous-compiler-condition*)
249 (setq *previous-compiler-condition* condition)
250 (signal-compiler-condition condition context))))
251
252 (defun signal-compiler-condition (condition context)
253 (signal (make-condition
254 'compiler-condition
255 :original-condition condition
256 :severity (etypecase condition
257 (sb-c:compiler-error :error)
258 (sb-ext:compiler-note :note)
259 (style-warning :style-warning)
260 (warning :warning)
261 (error :error))
262 :short-message (brief-compiler-message-for-emacs condition)
263 :references (condition-references (real-condition condition))
264 :message (long-compiler-message-for-emacs condition context)
265 :location (compiler-note-location context))))
266
267 (defun real-condition (condition)
268 "Return the encapsulated condition or CONDITION itself."
269 (typecase condition
270 (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
271 (t condition)))
272
273 (defun compiler-note-location (context)
274 (if context
275 (with-struct (sb-c::compiler-error-context- file-name) context
276 (locate-compiler-note file-name (compiler-source-path context)))
277 (list :error "No error location available")))
278
279 (defun locate-compiler-note (file source-path)
280 (cond ((and (pathnamep file) *buffer-name*)
281 ;; Compiling from a buffer
282 (let ((position (+ *buffer-offset*
283 (source-path-string-position
284 source-path *buffer-substring*))))
285 (make-location (list :buffer *buffer-name*)
286 (list :position position))))
287 ((and (pathnamep file) (null *buffer-name*))
288 ;; Compiling from a file
289 (make-location (list :file (namestring file))
290 (list :position
291 (1+ (source-path-file-position
292 source-path file)))))
293 (t
294 (error "unhandled case"))))
295
296 (defun brief-compiler-message-for-emacs (condition)
297 "Briefly describe a compiler error for Emacs.
298 When Emacs presents the message it already has the source popped up
299 and the source form highlighted. This makes much of the information in
300 the error-context redundant."
301 (let ((sb-int:*print-condition-references* nil))
302 (princ-to-string condition)))
303
304 (defun long-compiler-message-for-emacs (condition error-context)
305 "Describe a compiler error for Emacs including context information."
306 (declare (type (or sb-c::compiler-error-context null) error-context))
307 (multiple-value-bind (enclosing source)
308 (if error-context
309 (values (sb-c::compiler-error-context-enclosing-source error-context)
310 (sb-c::compiler-error-context-source error-context)))
311 (let ((sb-int:*print-condition-references* nil))
312 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
313 enclosing source condition))))
314
315 (defun compiler-source-path (context)
316 "Return the source-path for the current compiler error.
317 Returns NIL if this cannot be determined by examining internal
318 compiler state."
319 (cond ((sb-c::node-p context)
320 (reverse
321 (sb-c::source-path-original-source
322 (sb-c::node-source-path context))))
323 ((sb-c::compiler-error-context-p context)
324 (reverse
325 (sb-c::compiler-error-context-original-source-path context)))))
326
327 (defimplementation call-with-compilation-hooks (function)
328 (declare (type function function))
329 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
330 (sb-c:compiler-error #'handle-notification-condition)
331 (sb-ext:compiler-note #'handle-notification-condition)
332 (style-warning #'handle-notification-condition)
333 (warning #'handle-notification-condition))
334 (funcall function)))
335
336 (defun handle-file-compiler-termination (condition)
337 "Handle a condition that caused the file compiler to terminate."
338 (handle-notification-condition
339 (sb-int:encapsulated-condition condition)))
340
341 (defvar *trap-load-time-warnings* nil)
342
343 (defimplementation swank-compile-file (filename load-p)
344 (handler-case
345 (let ((output-file (with-compilation-hooks ()
346 (compile-file filename))))
347 (when output-file
348 ;; Cache the latest source file for definition-finding.
349 (source-cache-get filename (file-write-date filename))
350 (when load-p
351 (load output-file))))
352 (sb-c:fatal-compiler-error () nil)))
353
354 ;;;; compile-string
355
356 ;;; We patch sb-c::debug-source-for-info so that we can dump our own
357 ;;; bits of source info. Our *user-source-info* is stored in the
358 ;;; debug-source-info slot.
359
360 (defvar *real-debug-source-for-info*)
361 (defvar *user-source-info*)
362
363 (defun debug-source-for-info-advice (info)
364 (destructuring-bind (source) (funcall *real-debug-source-for-info* info)
365 (when (boundp '*user-source-info*)
366 (setf (sb-c::debug-source-info source) *user-source-info*))
367 (list source)))
368
369 (defun install-debug-source-patch ()
370 (unless (boundp '*real-debug-source-for-info*)
371 (setq *real-debug-source-for-info* #'sb-c::debug-source-for-info))
372 (sb-ext:without-package-locks
373 (setf (symbol-function 'sb-c::debug-source-for-info)
374 #'debug-source-for-info-advice)))
375
376 (defimplementation swank-compile-string (string &key buffer position directory)
377 (declare (ignore directory))
378 (install-debug-source-patch)
379 (call/temp-file
380 string
381 (lambda (filename)
382 (let ((*user-source-info* (list :emacs-buffer buffer :emacs-string string
383 :emacs-position position))
384 (*buffer-name* buffer)
385 (*buffer-offset* position)
386 (*buffer-substring* string))
387 (let ((fasl (with-compilation-hooks ()
388 (compile-file filename))))
389 (load fasl)
390 (delete-file fasl))))))
391
392 (defun call/temp-file (string fun)
393 (let ((filename (temp-file-name)))
394 (unwind-protect
395 (with-open-file (s filename :direction :output :if-exists :error)
396 (write-string string s)
397 (finish-output s)
398 (funcall fun filename))
399 (when (probe-file filename)
400 (delete-file filename)))))
401
402 (defun temp-file-name ()
403 "Return a temporary file name to compile strings into."
404 (sb-alien:alien-funcall
405 (sb-alien:extern-alien
406 "tmpnam"
407 (function sb-alien:c-string sb-alien:system-area-pointer))
408 (sb-sys:int-sap 0)))
409
410 ;;;; Definitions
411
412 (defvar *debug-definition-finding* nil
413 "When true don't handle errors while looking for definitions.
414 This is useful when debugging the definition-finding code.")
415
416 (defimplementation find-definitions (name)
417 (append (function-definitions name)
418 (compiler-definitions name)))
419
420 ;;;;; Function definitions
421
422 (defun function-definitions (name)
423 (flet ((loc (fn name) (safe-function-source-location fn name)))
424 (append
425 (cond ((and (symbolp name) (macro-function name))
426 (list (list `(defmacro ,name)
427 (loc (macro-function name) name))))
428 ((fboundp name)
429 (let ((fn (fdefinition name)))
430 (typecase fn
431 (generic-function
432 (cons (list `(defgeneric ,name) (loc fn name))
433 (method-definitions fn)))
434 (t
435 (list (list `(function ,name) (loc fn name))))))))
436 (when (compiler-macro-function name)
437 (list (list `(define-compiler-macro ,name)
438 (loc (compiler-macro-function name) name)))))))
439
440 (defun safe-function-source-location (fun name)
441 (if *debug-definition-finding*
442 (function-source-location fun name)
443 (handler-case (function-source-location fun name)
444 (error (e)
445 (list (list :error (format nil "Error: ~A" e)))))))
446
447 ;;; FIXME we don't handle the compiled-interactively case yet. That
448 ;;; should have NIL :filename & :position, and non-NIL :source-form
449 (defun function-source-location (function &optional name)
450 "Try to find the canonical source location of FUNCTION."
451 (let* ((def (sb-introspect:find-definition-source function))
452 (stamp (definition-source-file-write-date def)))
453 (with-struct (sb-introspect::definition-source-
454 pathname form-path character-offset) def
455 (cond ((function-from-emacs-buffer-p function)
456 (let ((info (function-debug-source-info function)))
457 (destructuring-bind (&key emacs-buffer emacs-position
458 emacs-string) info
459 (let ((pos (if form-path
460 (with-debootstrapping
461 (source-path-string-position
462 form-path emacs-string))
463 character-offset)))
464 (make-location `(:buffer ,(getf info :emacs-buffer))
465 `(:position ,(+ pos emacs-position)))))))
466 (t
467 (let* ((filename (namestring (truename pathname)))
468 (pos (if form-path
469 (with-debootstrapping
470 (source-path-file-position form-path filename) )
471 character-offset)))
472 (make-location
473 `(:file ,filename)
474 (if pos
475 `(:position ,pos)
476 `(:function-name
477 ,(or (and name (string name))
478 (string (sb-kernel:%fun-name function)))))
479 (let ((source (get-source-code pathname stamp)))
480 (if source
481 (with-input-from-string (stream source)
482 (file-position stream pos)
483 (list :snippet (read-snippet stream))))))))))))
484
485 ;; FIXME: Symbol doesn't exist in released SBCL yet.
486 (defun definition-source-file-write-date (def)
487 (let ((sym (find-symbol "DEFINITION-SOURCE-FILE-WRITE-DATE"
488 (find-package "SB-INTROSPECT"))))
489 (when sym (funcall sym def))))
490
491 (defun method-definitions (gf)
492 (let ((methods (sb-mop:generic-function-methods gf))
493 (name (sb-mop:generic-function-name gf)))
494 (loop for method in methods
495 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
496 (safe-function-source-location method name)))))
497
498 ;;;;; Compiler definitions
499
500 (defun compiler-definitions (name)
501 (let ((fun-info (sb-int:info :function :info name)))
502 (when fun-info
503 (append (transform-definitions fun-info name)
504 (optimizer-definitions fun-info name)))))
505
506 (defun transform-definitions (fun-info name)
507 (loop for xform in (sb-c::fun-info-transforms fun-info)
508 for loc = (safe-function-source-location
509 (sb-c::transform-function xform) name)
510 for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
511 for note = (sb-c::transform-note xform)
512 for spec = (if (consp typespec)
513 `(sb-c:deftransform ,(second typespec) ,note)
514 `(sb-c:deftransform ,note))
515 collect `(,spec ,loc)))
516
517 (defun optimizer-definitions (fun-info fun-name)
518 (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
519 (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
520 (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
521 (sb-c::fun-info-optimizer . sb-c:optimizer))))
522 (loop for (reader . name) in otypes
523 for fn = (funcall reader fun-info)
524 when fn collect `((sb-c:defoptimizer ,name)
525 ,(safe-function-source-location fn fun-name)))))
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 (labels ((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 (maybe-push
543 :function (if (fboundp symbol)
544 (doc 'function)))
545 (maybe-push
546 :setf (if (or (sb-int:info :setf :inverse symbol)
547 (sb-int:info :setf :expander symbol))
548 (doc 'setf)))
549 (maybe-push
550 :type (if (sb-int:info :type :kind symbol)
551 (doc 'type)))
552 result)))
553
554 (defimplementation describe-definition (symbol type)
555 (case type
556 (:variable
557 (describe symbol))
558 (:function
559 (describe (symbol-function symbol)))
560 (:setf
561 (describe (or (sb-int:info :setf :inverse symbol)
562 (sb-int:info :setf :expander symbol))))
563 (:class
564 (describe (find-class symbol)))
565 (:type
566 (describe (sb-kernel:values-specifier-type symbol)))))
567
568 (defimplementation list-callers (symbol)
569 (let ((fn (fdefinition symbol)))
570 (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
571
572 (defimplementation list-callees (symbol)
573 (let ((fn (fdefinition symbol)))
574 (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
575
576 (defun function-dspec (fn)
577 "Describe where the function FN was defined.
578 Return a list of the form (NAME LOCATION)."
579 (let ((name (sb-kernel:%fun-name fn)))
580 (list name (safe-function-source-location fn name))))
581
582 ;;; macroexpansion
583
584 (defimplementation macroexpand-all (form)
585 (let ((sb-walker:*walk-form-expand-macros-p* t))
586 (sb-walker:walk-form form)))
587
588
589 ;;; Debugging
590
591 (defvar *sldb-stack-top*)
592
593 (defimplementation call-with-debugging-environment (debugger-loop-fn)
594 (declare (type function debugger-loop-fn))
595 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
596 (sb-debug:*stack-top-hint* nil))
597 (handler-bind ((sb-di:debug-condition
598 (lambda (condition)
599 (signal (make-condition
600 'sldb-condition
601 :original-condition condition)))))
602 (funcall debugger-loop-fn))))
603
604 (defimplementation call-with-debugger-hook (hook fun)
605 (let ((sb-ext:*invoke-debugger-hook* hook))
606 (funcall fun)))
607
608 (defun nth-frame (index)
609 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
610 (i index (1- i)))
611 ((zerop i) frame)))
612
613 (defimplementation compute-backtrace (start end)
614 "Return a list of frames starting with frame number START and
615 continuing to frame number END or, if END is nil, the last frame on the
616 stack."
617 (let ((end (or end most-positive-fixnum)))
618 (loop for f = (nth-frame start) then (sb-di:frame-down f)
619 for i from start below end
620 while f
621 collect f)))
622
623 (defimplementation print-frame (frame stream)
624 (macrolet ((printer-form ()
625 ;; MEGAKLUDGE: As SBCL 0.8.20.1 fixed its debug IO style
626 ;; our usage of unexported interfaces came back to haunt
627 ;; us. And since we still use the same interfaces it will
628 ;; haunt us again.
629 (let ((print-sym (find-symbol "PRINT-FRAME-CALL" :sb-debug)))
630 (if (fboundp print-sym)
631 (let* ((args (sb-introspect:function-arglist print-sym))
632 (key-pos (position '&key args)))
633 (cond ((eql 2 key-pos)
634 `(,print-sym frame stream))
635 ((eql 1 key-pos)
636 `(let ((*standard-output* stream))
637 (,print-sym frame)))
638 (t
639 (error "*THWAP* SBCL changes internals ~
640 again!"))))
641 (error "You're in a twisty little maze of unsupported
642 SBCL interfaces, all different.")))))
643 (printer-form)))
644
645 ;;;; Code-location -> source-location translation
646
647 (defun code-location-source-location (code-location)
648 (let ((dsource (sb-di:code-location-debug-source code-location)))
649 (ecase (sb-di:debug-source-from dsource)
650 (:file (file-source-location code-location))
651 (:lisp (lisp-source-location code-location)))))
652
653 (defun file-source-location (code-location)
654 (cond ((code-location-has-debug-block-info-p code-location)
655 (if (code-location-from-emacs-buffer-p code-location)
656 (temp-file-source-location code-location)
657 (source-file-source-location code-location)))
658 (t
659 (let ((fun (code-location-debug-fun-fun code-location)))
660 (cond (fun (function-source-location fun))
661 (t (error "Cannot find source location for: ~A "
662 code-location)))))))
663
664 (defun lisp-source-location (code-location)
665 (let ((source (with-output-to-string (*standard-output*)
666 (print-code-location-source-form code-location 100))))
667 (make-location `(:source-form ,source) '(:position 0))))
668
669 (defun temp-file-source-location (code-location)
670 (let ((info (code-location-debug-source-info code-location)))
671 (destructuring-bind (&key emacs-buffer emacs-position emacs-string) info
672 (let* ((pos (string-source-position code-location emacs-string))
673 (snipped (with-input-from-string (s emacs-string)
674 (file-position s pos)
675 (read-snippet s))))
676 (make-location `(:buffer ,emacs-buffer)
677 `(:position ,(+ emacs-position pos))
678 `(:snippet ,snipped))))))
679
680 (defun source-file-source-location (code-location)
681 (let* ((code-date (code-location-debug-source-created code-location))
682 (filename (code-location-debug-source-name code-location))
683 (source-code (get-source-code filename code-date))
684 (cloc code-location))
685 (with-input-from-string (s source-code)
686 (make-location `(:file ,filename)
687 `(:position ,(1+ (stream-source-position cloc s)))
688 `(:snippet ,(read-snippet s))))))
689
690 (defun string-source-position (code-location string)
691 (with-input-from-string (s string)
692 (stream-source-position code-location s)))
693
694 (defun code-location-debug-source-info (code-location)
695 (sb-c::debug-source-info (sb-di::code-location-debug-source code-location)))
696
697 (defun code-location-debug-source-name (code-location)
698 (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
699
700 (defun code-location-debug-source-created (code-location)
701 (sb-c::debug-source-created
702 (sb-di::code-location-debug-source code-location)))
703
704 (defun code-location-debug-fun-fun (code-location)
705 (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
706
707 (defun code-location-from-emacs-buffer-p (code-location)
708 (info-from-emacs-buffer-p (code-location-debug-source-info code-location)))
709
710 (defun function-from-emacs-buffer-p (function)
711 (info-from-emacs-buffer-p (function-debug-source-info function)))
712
713 (defun function-debug-source-info (function)
714 (let* ((comp (sb-di::compiled-debug-fun-component
715 (sb-di::fun-debug-fun function))))
716 (sb-c::debug-source-info (car (sb-c::debug-info-source
717 (sb-kernel:%code-debug-info comp))))))
718
719 (defun info-from-emacs-buffer-p (info)
720 (and info
721 (consp info)
722 (eq :emacs-buffer (car info))))
723
724 (defun code-location-has-debug-block-info-p (code-location)
725 (handler-case
726 (progn (sb-di:code-location-debug-block code-location)
727 t)
728 (sb-di:no-debug-blocks () nil)))
729
730 (defun stream-source-position (code-location stream)
731 (let* ((cloc (sb-debug::maybe-block-start-location code-location))
732 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
733 (form-number (sb-di::code-location-form-number cloc)))
734 (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
735 (let* ((path-table (sb-di::form-number-translations tlf 0))
736 (source-path (if (<= (length path-table) form-number)
737 (list 0) ; file is out of sync
738 (reverse (cdr (aref path-table form-number))))))
739 (source-path-source-position source-path tlf pos-map)))))
740
741 ;;; source-path-file-position and friends are in swank-source-path-parser
742
743 (defun print-code-location-source-form (code-location context)
744 (macrolet ((printer-form ()
745 ;; KLUDGE: These are both unexported interfaces, used
746 ;; by different versions of SBCL. ...sooner or later
747 ;; this will change again: hopefully by then we have
748 ;; figured out the interface we want to drive the
749 ;; debugger with and requested it from the SBCL
750 ;; folks.
751 (let ((print-code-sym
752 (find-symbol "PRINT-CODE-LOCATION-SOURCE-FORM"
753 :sb-debug))
754 (code-sym
755 (find-symbol "CODE-LOCATION-SOURCE-FORM"
756 :sb-debug)))
757 (cond ((fboundp print-code-sym)
758 `(,print-code-sym code-location context))
759 ((fboundp code-sym)
760 `(prin1 (,code-sym code-location context)))
761 (t
762 (error
763 "*THWAP* SBCL changes its debugger interface ~
764 again!"))))))
765 (printer-form)))
766
767 (defun safe-source-location-for-emacs (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 ;;;;; reference-conditions
821
822 (defimplementation format-sldb-condition (condition)
823 (let ((sb-int:*print-condition-references* nil))
824 (princ-to-string condition)))
825
826 (defimplementation condition-references (condition)
827 (if (typep condition 'sb-int:reference-condition)
828 (sb-int:reference-condition-references condition)
829 '()))
830
831
832 ;;;; Profiling
833
834 (defimplementation profile (fname)
835 (when fname (eval `(sb-profile:profile ,fname))))
836
837 (defimplementation unprofile (fname)
838 (when fname (eval `(sb-profile:unprofile ,fname))))
839
840 (defimplementation unprofile-all ()
841 (sb-profile:unprofile)
842 "All functions unprofiled.")
843
844 (defimplementation profile-report ()
845 (sb-profile:report))
846
847 (defimplementation profile-reset ()
848 (sb-profile:reset)
849 "Reset profiling counters.")
850
851 (defimplementation profiled-functions ()
852 (sb-profile:profile))
853
854 (defimplementation profile-package (package callers methods)
855 (declare (ignore callers methods))
856 (eval `(sb-profile:profile ,(package-name (find-package package)))))
857
858
859 ;;;; Inspector
860
861 (defclass sbcl-inspector (inspector)
862 ())
863
864 (defimplementation make-default-inspector ()
865 (make-instance 'sbcl-inspector))
866
867 (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
868 (declare (ignore inspector))
869 (cond ((sb-di::indirect-value-cell-p o)
870 (values "A value cell."
871 `("Value: " (:value ,(sb-kernel:value-cell-ref o)))))
872 (t
873 (multiple-value-bind (text labeledp parts)
874 (sb-impl::inspected-parts o)
875 (if labeledp
876 (values text
877 (loop for (label . value) in parts
878 collect `(:value ,label)
879 collect " = "
880 collect `(:value ,value)
881 collect '(:newline)))
882 (values text
883 (loop for value in parts
884 for i from 0
885 collect (princ-to-string i)
886 collect " = "
887 collect `(:value ,value)
888 collect '(:newline))))))))
889
890 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
891 (declare (ignore inspector))
892 (let ((header (sb-kernel:widetag-of o)))
893 (cond ((= header sb-vm:simple-fun-header-widetag)
894 (values "A simple-fun."
895 `("Name: " (:value ,(sb-kernel:%simple-fun-name o))
896 (:newline)
897 "Arglist: " (:value ,(sb-kernel:%simple-fun-arglist o))
898 (:newline)
899 ,@(when (documentation o t)
900 `("Documentation: " (:newline) ,(documentation o t) (:newline)))
901 "Self: " (:value ,(sb-kernel:%simple-fun-self o))
902 (:newline)
903 "Next: " (:value ,(sb-kernel:%simple-fun-next o))
904 (:newline)
905 "Type: " (:value ,(sb-kernel:%simple-fun-type o))
906 (:newline)
907 "Code Object: " (:value ,(sb-kernel:fun-code-header o)))))
908 ((= header sb-vm:closure-header-widetag)
909 (values "A closure."
910 `("Function: " (:value ,(sb-kernel:%closure-fun o))
911 (:newline)
912 ,@(when (documentation o t)
913 `("Documentation: " (:newline) ,(documentation o t) (:newline)))
914 "Closed over values:"
915 (:newline)
916 ,@(loop for i from 0
917 below (- (sb-kernel:get-closure-length o)
918 (1- sb-vm:closure-info-offset))
919 collect (princ-to-string i)
920 collect " = "
921 collect `(:value ,(sb-kernel:%closure-index-ref o i))
922 collect '(:newline)))))
923 (t (call-next-method o)))))
924
925 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
926 (declare (ignore _))
927 (values (format nil "~A is a code data-block." o)
928 (append
929 (label-value-line*
930 (:code-size (sb-kernel:%code-code-size o))
931 (:entry-points (sb-kernel:%code-entry-points o))
932 (:debug-info (sb-kernel:%code-debug-info o))
933 (:trace-table-offset (sb-kernel:code-header-ref
934 o sb-vm:code-trace-table-offset-slot)))
935 `("Constants:" (:newline))
936 (loop for i from sb-vm:code-constants-offset
937 below (sb-kernel:get-header-data o)
938 append (label-value-line i (sb-kernel:code-header-ref o i)))
939 `("Code:" (:newline)
940 , (with-output-to-string (s)
941 (cond ((sb-kernel:%code-debug-info o)
942 (sb-disassem:disassemble-code-component o :stream s))
943 (t
944 (sb-disassem:disassemble-memory
945 (sb-disassem::align
946 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
947 sb-vm:lowtag-mask)
948 (* sb-vm:code-constants-offset sb-vm:n-word-bytes))
949 (ash 1 sb-vm:n-lowtag-bits))
950 (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
951 :stream s))))))))
952
953 (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
954 (declare (ignore inspector))
955 (values "A fdefn object."
956 `("Name: " (:value ,(sb-kernel:fdefn-name o))
957 (:newline)
958 "Function" (:value,(sb-kernel:fdefn-fun o))
959 (:newline)
960 ,@(when (documentation o t)
961 `("Documentation: " (:newline) ,(documentation o t) (:newline))))))
962
963 (defmethod inspect-for-emacs :around ((o generic-function) (inspector sbcl-inspector))
964 (declare (ignore inspector))
965 (multiple-value-bind (title contents)
966 (call-next-method)
967 (values title
968 (append contents
969 `("Pretty arglist: " (:value ,(sb-pcl::generic-function-pretty-arglist o))
970 (:newline)
971 "Initial methods: " (:value ,(sb-pcl::generic-function-initial-methods o)))))))
972
973
974 ;;;; Multiprocessing
975
976 #+sb-thread
977 (progn
978 (defimplementation spawn (fn &key name)
979 (declare (ignore name))
980 (sb-thread:make-thread fn))
981
982 (defimplementation startup-multiprocessing ())
983
984 (defimplementation thread-id (thread)
985 thread)
986
987 (defimplementation find-thread (id)
988 (if (member id (all-threads))
989 id))
990
991 (defimplementation thread-name (thread)
992 (format nil "Thread ~D" thread))
993
994 (defun %thread-state-slot (thread)
995 (sb-sys:without-gcing
996 (sb-kernel:make-lisp-obj
997 (sb-sys:sap-int
998 (sb-sys:sap-ref-sap (sb-thread::thread-sap-from-id thread)
999 (* sb-vm::thread-state-slot
1000 sb-vm::n-word-bytes))))))
1001
1002 (defun %thread-state (thread)
1003 (ecase (%thread-state-slot thread)
1004 (0 :running)
1005 (1 :stopping)
1006 (2 :stopped)
1007 (3 :dead)))
1008
1009 (defimplementation thread-status (thread)
1010 (string (%thread-state thread)))
1011
1012 (defimplementation make-lock (&key name)
1013 (sb-thread:make-mutex :name name))
1014
1015 (defimplementation call-with-lock-held (lock function)
1016 (declare (type function function))
1017 (sb-thread:with-mutex (lock) (funcall function)))
1018
1019 (defimplementation current-thread ()
1020 (sb-thread:current-thread-id))
1021
1022 (defimplementation all-threads ()
1023 (let ((pids (sb-sys:without-gcing
1024 (sb-thread::mapcar-threads
1025 (lambda (sap)
1026 (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
1027 sb-vm::thread-pid-slot)))))))
1028 (remove :dead pids :key #'%thread-state)))
1029
1030 (defimplementation interrupt-thread (thread fn)
1031 (sb-thread:interrupt-thread thread fn))
1032
1033 (defimplementation kill-thread (thread)
1034 (sb-thread:terminate-thread thread))
1035
1036 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1037 (defvar *mailboxes* (list))
1038 (declaim (type list *mailboxes*))
1039
1040 (defstruct (mailbox (:conc-name mailbox.))
1041 thread
1042 (mutex (sb-thread:make-mutex))
1043 (waitqueue (sb-thread:make-waitqueue))
1044 (queue '() :type list))
1045
1046 (defun mailbox (thread)
1047 "Return THREAD's mailbox."
1048 (sb-thread:with-mutex (*mailbox-lock*)
1049 (or (find thread *mailboxes* :key #'mailbox.thread)
1050 (let ((mb (make-mailbox :thread thread)))
1051 (push mb *mailboxes*)
1052 mb))))
1053
1054 (defimplementation send (thread message)
1055 (let* ((mbox (mailbox thread))
1056 (mutex (mailbox.mutex mbox)))
1057 (sb-thread:with-mutex (mutex)
1058 (setf (mailbox.queue mbox)
1059 (nconc (mailbox.queue mbox) (list message)))
1060 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1061
1062 (defimplementation receive ()
1063 (let* ((mbox (mailbox (sb-thread:current-thread-id)))
1064 (mutex (mailbox.mutex mbox)))
1065 (sb-thread:with-mutex (mutex)
1066 (loop
1067 (let ((q (mailbox.queue mbox)))
1068 (cond (q (return (pop (mailbox.queue mbox))))
1069 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1070 mutex))))))))
1071
1072 )
1073
1074
1075 ;;Trace implementations
1076 ;;In SBCL, we have:
1077 ;; (trace <name>)
1078 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1079 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1080 ;; <name> can be a normal name or a (setf name)
1081
1082 (defun toggle-trace-aux (fspec &rest args)
1083 (cond ((member fspec (eval '(trace)) :test #'equal)
1084 (eval `(untrace ,fspec))
1085 (format nil "~S is now untraced." fspec))
1086 (t
1087 (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1088 (format nil "~S is now traced." fspec))))
1089
1090 (defun process-fspec (fspec)
1091 (cond ((consp fspec)
1092 (ecase (first fspec)
1093 ((:defun :defgeneric) (second fspec))
1094 ((:defmethod) `(method ,@(rest fspec)))
1095 ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1096 ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1097 (t
1098 fspec)))
1099
1100 (defimplementation toggle-trace (spec)
1101 (ecase (car spec)
1102 ((setf)
1103 (toggle-trace-aux spec))
1104 ((:defmethod)
1105 (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1106 ((:defgeneric)
1107 (toggle-trace-aux (second spec) :methods t))
1108 ((:call)
1109 (destructuring-bind (caller callee) (cdr spec)
1110 (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))

  ViewVC Help
Powered by ViewVC 1.1.5