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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.200 - (show annotations)
Sat Jul 26 23:05:59 2008 UTC (5 years, 8 months ago) by trittweiler
Branch: MAIN
Changes since 1.199: +11 -7 lines
* swank.lisp (swank-compiler): Fix bug when invoking an abort
restart on a failed compilation attempt.

* swank-sbcl.lisp (swank-compile-string): If a compilation attempt
fails, COMPILE-FILE returns NIL which we tried to LOAD. Fix that.

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

  ViewVC Help
Powered by ViewVC 1.1.5