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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5