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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.84 - (show annotations)
Fri Apr 30 23:19:50 2004 UTC (9 years, 11 months ago) by lgorrie
Branch: MAIN
Changes since 1.83: +0 -27 lines
Removed obsolete `swank-compile-system'.
Removed some stale comments about supported features.
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 ;;; This is a Slime backend for SBCL. Requires SBCL 0.8.5 or later
11 ;;; for the SB-INTROSPECT contrib
12
13
14 ;;; Administrivia
15
16 (eval-when (:compile-toplevel :load-toplevel :execute)
17 (require 'sb-bsd-sockets)
18 (require 'sb-introspect)
19 (require 'sb-posix)
20 )
21
22 (declaim (optimize (debug 3)))
23 (in-package :swank-backend)
24
25 (import
26 '(sb-gray:fundamental-character-output-stream
27 sb-gray:stream-write-char
28 sb-gray:stream-line-length
29 sb-gray:stream-force-output
30 sb-gray:fundamental-character-input-stream
31 sb-gray:stream-read-char
32 sb-gray:stream-listen
33 sb-gray:stream-unread-char
34 sb-gray:stream-clear-input
35 sb-gray:stream-line-column
36 sb-gray:stream-line-length))
37
38 ;;; TCP Server
39
40 (defimplementation preferred-communication-style ()
41 (cond ((and (sb-int:featurep :sb-thread)
42 (sb-int:featurep :sb-futex))
43 :spawn)
44 ((fboundp 'sb-posix::fcntl)
45 :sigio)
46 (t
47 :fd-handler)))
48
49 (defun resolve-hostname (name)
50 (car (sb-bsd-sockets:host-ent-addresses
51 (sb-bsd-sockets:get-host-by-name name))))
52
53 (defimplementation create-socket (host port)
54 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
55 :type :stream
56 :protocol :tcp)))
57 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
58 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
59 (sb-bsd-sockets:socket-listen socket 5)
60 socket))
61
62 (defimplementation local-port (socket)
63 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
64
65 (defimplementation close-socket (socket)
66 (sb-bsd-sockets:socket-close socket))
67
68 (defimplementation accept-connection (socket)
69 (make-socket-io-stream (accept socket)))
70
71 (defvar *sigio-handlers* '()
72 "List of (key . fn) pairs to be called on SIGIO.")
73
74 (defun sigio-handler (signal code scp)
75 (declare (ignore signal code scp))
76 (mapc (lambda (handler)
77 (funcall (the function (cdr handler))))
78 *sigio-handlers*))
79
80 (defun set-sigio-handler ()
81 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
82 (sigio-handler signal code scp))))
83
84 (defun enable-sigio-on-fd (fd)
85 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
86 (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
87
88 (defimplementation add-sigio-handler (socket fn)
89 (set-sigio-handler)
90 (let ((fd (socket-fd socket)))
91 (format *debug-io* "Adding sigio handler: ~S ~%" fd)
92 (enable-sigio-on-fd fd)
93 (push (cons fd fn) *sigio-handlers*)))
94
95 (defimplementation remove-sigio-handlers (socket)
96 (let ((fd (socket-fd socket)))
97 (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
98 (sb-sys:invalidate-descriptor fd))
99 (close socket))
100
101 (defimplementation add-fd-handler (socket fn)
102 (declare (type function fn))
103 (let ((fd (socket-fd socket)))
104 (format *debug-io* "; Adding fd handler: ~S ~%" fd)
105 (sb-sys:add-fd-handler fd :input (lambda (_)
106 _
107 (funcall fn)))))
108
109 (defimplementation remove-fd-handlers (socket)
110 (sb-sys:invalidate-descriptor (socket-fd socket)))
111
112 (defun socket-fd (socket)
113 (etypecase socket
114 (fixnum socket)
115 (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
116 (file-stream (sb-sys:fd-stream-fd socket))))
117
118 (defun make-socket-io-stream (socket)
119 (sb-bsd-sockets:socket-make-stream socket
120 :output t
121 :input t
122 :element-type 'base-char))
123
124 (defun accept (socket)
125 "Like socket-accept, but retry on EAGAIN."
126 (loop (handler-case
127 (return (sb-bsd-sockets:socket-accept socket))
128 (sb-bsd-sockets:interrupted-error ()))))
129
130 (defmethod call-without-interrupts (fn)
131 (declare (type function fn))
132 (sb-sys:without-interrupts (funcall fn)))
133
134 (defimplementation getpid ()
135 (sb-posix:getpid))
136
137 (defimplementation lisp-implementation-type-name ()
138 "sbcl")
139
140 ;;; Utilities
141
142 (defvar *swank-debugger-stack-frame*)
143
144 (defimplementation arglist (fname)
145 (sb-introspect:function-arglist fname))
146
147 (defvar *buffer-name* nil)
148 (defvar *buffer-offset*)
149 (defvar *buffer-substring* nil)
150
151 (defvar *previous-compiler-condition* nil
152 "Used to detect duplicates.")
153
154 (defun handle-notification-condition (condition)
155 "Handle a condition caused by a compiler warning.
156 This traps all compiler conditions at a lower-level than using
157 C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
158 craft our own error messages, which can omit a lot of redundant
159 information."
160 (let ((context (sb-c::find-error-context nil)))
161 (unless (eq condition *previous-compiler-condition*)
162 (setq *previous-compiler-condition* condition)
163 (signal-compiler-condition condition context))))
164
165 (defun signal-compiler-condition (condition context)
166 (signal (make-condition
167 'compiler-condition
168 :original-condition condition
169 :severity (etypecase condition
170 (sb-c:compiler-error :error)
171 (sb-ext:compiler-note :note)
172 (style-warning :style-warning)
173 (warning :warning))
174 :short-message (brief-compiler-message-for-emacs condition)
175 :message (long-compiler-message-for-emacs condition context)
176 :location (compiler-note-location context))))
177
178
179
180 (defun compiler-note-location (context)
181 (cond (context
182 (resolve-note-location
183 *buffer-name*
184 (sb-c::compiler-error-context-file-name context)
185 (sb-c::compiler-error-context-file-position context)
186 (current-compiler-error-source-path context)
187 (sb-c::compiler-error-context-original-source context)))
188 (t
189 (resolve-note-location *buffer-name* nil nil nil nil))))
190
191 (defgeneric resolve-note-location (buffer file-name file-position
192 source-path source))
193
194 (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
195 (make-location
196 `(:file ,(namestring (truename f)))
197 `(:position ,(1+ (source-path-file-position path f)))))
198
199 (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
200 (make-location
201 `(:buffer ,b)
202 `(:position ,(+ *buffer-offset*
203 (source-path-string-position path *buffer-substring*)))))
204
205 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
206 (make-location
207 `(:source-form ,source)
208 `(:position 1)))
209
210 (defmethod resolve-note-location (buffer
211 (file (eql nil))
212 (pos (eql nil))
213 (path (eql nil))
214 (source (eql nil)))
215 (list :error "No error location available"))
216
217 (defun brief-compiler-message-for-emacs (condition)
218 "Briefly describe a compiler error for Emacs.
219 When Emacs presents the message it already has the source popped up
220 and the source form highlighted. This makes much of the information in
221 the error-context redundant."
222 (princ-to-string condition))
223
224 (defun long-compiler-message-for-emacs (condition error-context)
225 "Describe a compiler error for Emacs including context information."
226 (declare (type (or sb-c::compiler-error-context null) error-context))
227 (multiple-value-bind (enclosing source)
228 (if error-context
229 (values (sb-c::compiler-error-context-enclosing-source error-context)
230 (sb-c::compiler-error-context-source error-context)))
231 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
232 enclosing source condition)))
233
234 (defun current-compiler-error-source-path (context)
235 "Return the source-path for the current compiler error.
236 Returns NIL if this cannot be determined by examining internal
237 compiler state."
238 (cond ((sb-c::node-p context)
239 (reverse
240 (sb-c::source-path-original-source
241 (sb-c::node-source-path context))))
242 ((sb-c::compiler-error-context-p context)
243 (reverse
244 (sb-c::compiler-error-context-original-source-path context)))))
245
246 (defimplementation call-with-compilation-hooks (function)
247 (declare (type function function))
248 (handler-bind ((sb-c:compiler-error #'handle-notification-condition)
249 (sb-ext:compiler-note #'handle-notification-condition)
250 (style-warning #'handle-notification-condition)
251 (warning #'handle-notification-condition))
252 (funcall function)))
253
254 (defimplementation swank-compile-file (filename load-p)
255 (with-compilation-hooks ()
256 (let ((fasl-file (compile-file filename)))
257 (when (and load-p fasl-file)
258 (load fasl-file)))))
259
260 (defimplementation swank-compile-string (string &key buffer position)
261 (with-compilation-hooks ()
262 (let ((*buffer-name* buffer)
263 (*buffer-offset* position)
264 (*buffer-substring* string))
265 (funcall (compile nil (read-from-string
266 (format nil "(~S () ~A)" 'lambda string)))))))
267
268 ;;;; Definitions
269
270 (defvar *debug-definition-finding* nil
271 "When true don't handle errors while looking for definitions.
272 This is useful when debugging the definition-finding code.")
273
274 ;;; FIXME we don't handle the compiled-interactively case yet. That
275 ;;; should have NIL :filename & :position, and non-NIL :source-form
276 (defun function-source-location (function &optional name)
277 "Try to find the canonical source location of FUNCTION."
278 (let* ((def (sb-introspect:find-definition-source function))
279 (pathname (sb-introspect:definition-source-pathname def))
280 (path (sb-introspect:definition-source-form-path def))
281 (position (sb-introspect:definition-source-character-offset def)))
282 (unless pathname
283 (return-from function-source-location
284 (list :error (format nil "No filename for: ~S" function))))
285 (multiple-value-bind (truename condition)
286 (ignore-errors (truename pathname))
287 (when condition
288 (return-from function-source-location
289 (list :error (format nil "~A" condition))))
290 (make-location
291 (list :file (namestring truename))
292 ;; source-paths depend on the file having been compiled with
293 ;; lotsa debugging. If not present, return the function name
294 ;; for emacs to attempt to find with a regex
295 (cond (path (list :source-path path position))
296 (t (list :function-name
297 (or (and name (string name))
298 (string (sb-kernel:%fun-name function))))))))))
299
300 (defun safe-function-source-location (fun name)
301 (if *debug-definition-finding*
302 (function-source-location fun name)
303 (handler-case (function-source-location fun name)
304 (error (e)
305 (list (list :error (format nil "Error: ~A" e)))))))
306
307 (defun method-definitions (gf)
308 (let ((methods (sb-mop:generic-function-methods gf))
309 (name (sb-mop:generic-function-name gf)))
310 (loop for method in methods
311 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
312 (safe-function-source-location method name)))))
313
314 (defun function-definitions (name)
315 (flet ((loc (fn name) (safe-function-source-location fn name)))
316 (cond ((and (symbolp name) (macro-function name))
317 (list (list `(defmacro ,name)
318 (loc (macro-function name) name))))
319 ((fboundp name)
320 (let ((fn (fdefinition name)))
321 (typecase fn
322 (generic-function
323 (cons (list `(defgeneric ,name) (loc fn name))
324 (method-definitions fn)))
325 (t
326 (list (list `(function ,name) (loc fn name))))))))))
327
328 (defimplementation find-definitions (name)
329 (function-definitions name))
330
331 (defimplementation describe-symbol-for-emacs (symbol)
332 "Return a plist describing SYMBOL.
333 Return NIL if the symbol is unbound."
334 (let ((result '()))
335 (labels ((doc (kind)
336 (or (documentation symbol kind) :not-documented))
337 (maybe-push (property value)
338 (when value
339 (setf result (list* property value result)))))
340 (maybe-push
341 :variable (multiple-value-bind (kind recorded-p)
342 (sb-int:info :variable :kind symbol)
343 (declare (ignore kind))
344 (if (or (boundp symbol) recorded-p)
345 (doc 'variable))))
346 (maybe-push
347 :function (if (fboundp symbol)
348 (doc 'function)))
349 (maybe-push
350 :setf (if (or (sb-int:info :setf :inverse symbol)
351 (sb-int:info :setf :expander symbol))
352 (doc 'setf)))
353 (maybe-push
354 :type (if (sb-int:info :type :kind symbol)
355 (doc 'type)))
356 result)))
357
358 (defimplementation describe-definition (symbol type)
359 (case type
360 (:variable
361 (describe symbol))
362 (:function
363 (describe (symbol-function symbol)))
364 (:setf
365 (describe (or (sb-int:info :setf :inverse symbol)
366 (sb-int:info :setf :expander symbol))))
367 (:class
368 (describe (find-class symbol)))
369 (:type
370 (describe (sb-kernel:values-specifier-type symbol)))))
371
372 ;;; macroexpansion
373
374 (defimplementation macroexpand-all (form)
375 (let ((sb-walker:*walk-form-expand-macros-p* t))
376 (sb-walker:walk-form form)))
377
378
379 ;;; Debugging
380
381 (defvar *sldb-stack-top*)
382
383 (defimplementation call-with-debugging-environment (debugger-loop-fn)
384 (declare (type function debugger-loop-fn))
385 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
386 (sb-debug:*stack-top-hint* nil))
387 (handler-bind ((sb-di:debug-condition
388 (lambda (condition)
389 (signal (make-condition
390 'sldb-condition
391 :original-condition condition)))))
392 (funcall debugger-loop-fn))))
393
394 (defun nth-frame (index)
395 (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
396 (i index (1- i)))
397 ((zerop i) frame)))
398
399 (defimplementation compute-backtrace (start end)
400 "Return a list of frames starting with frame number START and
401 continuing to frame number END or, if END is nil, the last frame on the
402 stack."
403 (let ((end (or end most-positive-fixnum)))
404 (loop for f = (nth-frame start) then (sb-di:frame-down f)
405 for i from start below end
406 while f
407 collect f)))
408
409 (defimplementation print-frame (frame stream)
410 (let ((*standard-output* stream))
411 (sb-debug::print-frame-call frame :verbosity 1 :number nil)))
412
413 (defun code-location-source-path (code-location)
414 (let* ((location (sb-debug::maybe-block-start-location code-location))
415 (form-num (sb-di:code-location-form-number location)))
416 (let ((translations (sb-debug::get-toplevel-form location)))
417 (unless (< form-num (length translations))
418 (error "Source path no longer exists."))
419 (reverse (cdr (svref translations form-num))))))
420
421 (defun code-location-file-position (code-location)
422 (let* ((debug-source (sb-di:code-location-debug-source code-location))
423 (filename (sb-di:debug-source-name debug-source))
424 (path (code-location-source-path code-location)))
425 (source-path-file-position path filename)))
426
427 ;;; source-path-file-position and friends are in swank-source-path-parser
428
429 (defun debug-source-info-from-emacs-buffer-p (debug-source)
430 (let ((info (sb-c::debug-source-info debug-source)))
431 (and info
432 (consp info)
433 (eq :emacs-buffer (car info)))))
434
435 (defun source-location-for-emacs (code-location)
436 (let* ((debug-source (sb-di:code-location-debug-source code-location))
437 (from (sb-di:debug-source-from debug-source))
438 (name (sb-di:debug-source-name debug-source)))
439 (ecase from
440 (:file
441 (let ((source-path (ignore-errors
442 (code-location-source-path code-location))))
443 (cond (source-path
444 ;; XXX: code-location-source-path reads the source !!
445 (let ((position (code-location-file-position code-location)))
446 (make-location
447 (list :file (namestring (truename name)))
448 (list :source-path source-path position))))
449 (t
450 (let* ((dfn (sb-di:code-location-debug-fun code-location))
451 (fn (sb-di:debug-fun-fun dfn)))
452 (unless fn
453 (error "Cannot find source location for: ~A "
454 code-location))
455 (function-source-location
456 fn (sb-di:debug-fun-name dfn)))))))
457
458 (:lisp
459 (make-location
460 (list :source-form (with-output-to-string (*standard-output*)
461 (sb-debug::print-code-location-source-form
462 code-location 100)))
463 (list :position 0))))))
464
465 (defun safe-source-location-for-emacs (code-location)
466 (handler-case (source-location-for-emacs code-location)
467 (error (c) (list :error (format nil "~A" c)))))
468
469 (defimplementation frame-source-location-for-emacs (index)
470 (safe-source-location-for-emacs
471 (sb-di:frame-code-location (nth-frame index))))
472
473 (defimplementation frame-locals (index)
474 (let* ((frame (nth-frame index))
475 (location (sb-di:frame-code-location frame))
476 (debug-function (sb-di:frame-debug-fun frame))
477 (debug-variables (sb-di::debug-fun-debug-vars debug-function)))
478 (declare (type (or null simple-vector) debug-variables))
479 (loop for v across debug-variables
480 collect (list
481 :name (sb-di:debug-var-symbol v)
482 :id (sb-di:debug-var-id v)
483 :value (if (eq (sb-di:debug-var-validity v location)
484 :valid)
485 (sb-di:debug-var-value v frame)
486 '#:<not-available>)))))
487
488 (defimplementation frame-catch-tags (index)
489 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
490
491 (defimplementation eval-in-frame (form index)
492 (let ((frame (nth-frame index)))
493 (funcall (the function
494 (sb-di:preprocess-for-eval form
495 (sb-di:frame-code-location frame)))
496 frame)))
497
498 (defun sb-debug-catch-tag-p (tag)
499 (and (symbolp tag)
500 (not (symbol-package tag))
501 (string= tag :sb-debug-catch-tag)))
502
503 (defimplementation return-from-frame (index form)
504 (let* ((frame (nth-frame index))
505 (probe (assoc-if #'sb-debug-catch-tag-p
506 (sb-di::frame-catches frame))))
507 (cond (probe (throw (car probe) (eval-in-frame form index)))
508 (t (format nil "Cannot return from frame: ~S" frame)))))
509
510
511 ;;;; Profiling
512
513 (defimplementation profile (fname)
514 (when fname (eval `(sb-profile:profile ,fname))))
515
516 (defimplementation unprofile (fname)
517 (when fname (eval `(sb-profile:unprofile ,fname))))
518
519 (defimplementation unprofile-all ()
520 (sb-profile:unprofile)
521 "All functions unprofiled.")
522
523 (defimplementation profile-report ()
524 (sb-profile:report))
525
526 (defimplementation profile-reset ()
527 (sb-profile:reset)
528 "Reset profiling counters.")
529
530 (defimplementation profiled-functions ()
531 (sb-profile:profile))
532
533
534 ;;;; Inspector
535
536 (defmethod inspected-parts (o)
537 (cond ((sb-di::indirect-value-cell-p o)
538 (inspected-parts-of-value-cell o))
539 (t
540 (multiple-value-bind (text labeledp parts)
541 (sb-impl::inspected-parts o)
542 (let ((parts (if labeledp
543 (loop for (label . value) in parts
544 collect (cons (string label) value))
545 (loop for value in parts
546 for i from 0
547 collect (cons (format nil "~D" i) value)))))
548 (values text parts))))))
549
550 (defun inspected-parts-of-value-cell (o)
551 (values (format nil "~A~% is a value cell." o)
552 (list (cons "Value" (sb-kernel:value-cell-ref o)))))
553
554 (defmethod inspected-parts ((o function))
555 (let ((header (sb-kernel:widetag-of o)))
556 (cond ((= header sb-vm:simple-fun-header-widetag)
557 (values
558 (format nil "~A~% is a simple-fun." o)
559 (list (cons "Self" (sb-kernel:%simple-fun-self o))
560 (cons "Next" (sb-kernel:%simple-fun-next o))
561 (cons "Name" (sb-kernel:%simple-fun-name o))
562 (cons "Arglist" (sb-kernel:%simple-fun-arglist o))
563 (cons "Type" (sb-kernel:%simple-fun-type o))
564 (cons "Code Object" (sb-kernel:fun-code-header o)))))
565 ((= header sb-vm:closure-header-widetag)
566 (values (format nil "~A~% is a closure." o)
567 (list*
568 (cons "Function" (sb-kernel:%closure-fun o))
569 (loop for i from 0
570 below (- (sb-kernel:get-closure-length o)
571 (1- sb-vm:closure-info-offset))
572 collect (cons (format nil "~D" i)
573 (sb-kernel:%closure-index-ref o i))))))
574 (t (call-next-method o)))))
575
576 (defmethod inspected-parts ((o sb-kernel:code-component))
577 (values (format nil "~A~% is a code data-block." o)
578 `(("First entry point" . ,(sb-kernel:%code-entry-points o))
579 ,@(loop for i from sb-vm:code-constants-offset
580 below (sb-kernel:get-header-data o)
581 collect (cons (format nil "Constant#~D" i)
582 (sb-kernel:code-header-ref o i)))
583 ("Debug info" . ,(sb-kernel:%code-debug-info o))
584 ("Instructions" . ,(sb-kernel:code-instructions o)))))
585
586 (defmethod inspected-parts ((o sb-kernel:fdefn))
587 (values (format nil "~A~% is a fdefn object." o)
588 `(("Name" . ,(sb-kernel:fdefn-name o))
589 ("Function" . ,(sb-kernel:fdefn-fun o)))))
590
591
592 (defmethod inspected-parts ((o generic-function))
593 (values (format nil "~A~% is a generic function." o)
594 (list
595 (cons "Method-Class" (sb-pcl:generic-function-method-class o))
596 (cons "Methods" (sb-pcl:generic-function-methods o))
597 (cons "Name" (sb-pcl:generic-function-name o))
598 (cons "Declarations" (sb-pcl:generic-function-declarations o))
599 (cons "Method-Combination"
600 (sb-pcl:generic-function-method-combination o))
601 (cons "Lambda-List" (sb-pcl:generic-function-lambda-list o))
602 (cons "Precedence-Order"
603 (sb-pcl:generic-function-argument-precedence-order o))
604 (cons "Pretty-Arglist"
605 (sb-pcl::generic-function-pretty-arglist o))
606 (cons "Initial-Methods"
607 (sb-pcl::generic-function-initial-methods o)))))
608
609
610 ;;;; Multiprocessing
611
612 #+sb-thread
613 (progn
614 (defimplementation spawn (fn &key name)
615 (declare (ignore name))
616 (sb-thread:make-thread fn))
617
618 (defimplementation startup-multiprocessing ()
619 (setq *communication-style* :spawn))
620
621 (defimplementation thread-name (thread)
622 (format nil "Thread ~D" thread))
623
624 (defimplementation thread-status (thread)
625 (declare (ignore thread))
626 "???")
627
628 (defimplementation make-lock (&key name)
629 (sb-thread:make-mutex :name name))
630
631 (defimplementation call-with-lock-held (lock function)
632 (declare (type function function))
633 (sb-thread:with-mutex (lock) (funcall function)))
634
635 (defimplementation current-thread ()
636 (sb-thread:current-thread-id))
637
638 (defimplementation all-threads ()
639 (sb-thread::mapcar-threads
640 (lambda (sap)
641 (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
642 sb-vm::thread-pid-slot)))))
643
644 (defimplementation interrupt-thread (thread fn)
645 (sb-thread:interrupt-thread thread fn))
646
647 (defimplementation kill-thread (thread)
648 (sb-thread:terminate-thread thread))
649
650 ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)
651
652 (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
653 (defvar *mailboxes* (list))
654 (declaim (type list *mailboxes*))
655
656 (defstruct (mailbox (:conc-name mailbox.))
657 thread
658 (mutex (sb-thread:make-mutex))
659 (waitqueue (sb-thread:make-waitqueue))
660 (queue '() :type list))
661
662 (defun mailbox (thread)
663 "Return THREAD's mailbox."
664 (sb-thread:with-mutex (*mailbox-lock*)
665 (or (find thread *mailboxes* :key #'mailbox.thread)
666 (let ((mb (make-mailbox :thread thread)))
667 (push mb *mailboxes*)
668 mb))))
669
670 (defimplementation send (thread message)
671 (let* ((mbox (mailbox thread))
672 (mutex (mailbox.mutex mbox)))
673 (sb-thread:with-mutex (mutex)
674 (setf (mailbox.queue mbox)
675 (nconc (mailbox.queue mbox) (list message)))
676 (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
677
678 (defimplementation receive ()
679 (let* ((mbox (mailbox (sb-thread:current-thread-id)))
680 (mutex (mailbox.mutex mbox)))
681 (sb-thread:with-mutex (mutex)
682 (loop
683 (let ((q (mailbox.queue mbox)))
684 (cond (q (return (pop (mailbox.queue mbox))))
685 (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
686 mutex))))))))
687
688 )
689
690 (defimplementation quit-lisp ()
691 (sb-ext::quit))

  ViewVC Help
Powered by ViewVC 1.1.5