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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5