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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5