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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5