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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5