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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5