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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5