1 ;;;; -*- indent-tabs-mode: nil -*-
4 Copyright
2006, 2007 Greg Pfeil
6 Distributed under the MIT license
(see LICENSE file
)
9 (in-package #:bordeaux-threads
)
11 ;;; documentation on the SBCL Threads interface can be found at
12 ;;; http://www.sbcl.org/manual/Threading.html
19 (defun %make-thread
(function name
)
20 (sb-thread:make-thread function
:name name
))
22 (defun current-thread ()
23 sb-thread
:*current-thread
*)
25 (defun threadp (object)
26 (typep object
'sb-thread
:thread
))
28 (defun thread-name (thread)
29 (sb-thread:thread-name thread
))
31 ;;; Resource contention: locks and recursive locks
33 (deftype lock
() 'sb-thread
:mutex
)
35 (deftype recursive-lock
() 'sb-thread
:mutex
)
37 (defun lock-p (object)
38 (typep object
'sb-thread
:mutex
))
40 (defun recursive-lock-p (object)
41 (typep object
'sb-thread
:mutex
))
43 (defun make-lock (&optional name
)
44 (sb-thread:make-mutex
:name
(or name
"Anonymous lock")))
46 (defun acquire-lock (lock &optional
(wait-p t
))
47 #+#.
(cl:if
(cl:find-symbol
(cl:string
'#:grab-mutex
) :sb-thread
) '(and) '(or))
48 (sb-thread:grab-mutex lock
:waitp wait-p
)
49 #-
#.
(cl:if
(cl:find-symbol
(cl:string
'#:grab-mutex
) :sb-thread
) '(and) '(or))
50 (sb-thread:get-mutex lock nil wait-p
))
52 (defun release-lock (lock)
53 (sb-thread:release-mutex lock
))
55 (defmacro with-lock-held
((place) &body body
)
56 `(sb-thread:with-mutex
(,place
) ,@body
))
58 (defun make-recursive-lock (&optional name
)
59 (sb-thread:make-mutex
:name
(or name
"Anonymous recursive lock")))
61 ;;; XXX acquire-recursive-lock and release-recursive-lock are actually
62 ;;; complicated because we can't use control stack tricks. We need to
63 ;;; actually count something to check that the acquire/releases are
66 (defmacro with-recursive-lock-held
((place) &body body
)
67 `(sb-thread:with-recursive-lock
(,place
)
70 ;;; Resource contention: condition variables
72 (defun make-condition-variable (&key name
)
73 (sb-thread:make-waitqueue
:name
(or name
"Anonymous condition variable")))
75 (defun condition-wait (condition-variable lock
&key timeout
)
77 (sb-thread:condition-wait condition-variable lock
:timeout timeout
)))
82 (defun condition-notify (condition-variable)
83 (sb-thread:condition-notify condition-variable
))
85 (defun thread-yield ()
86 (sb-thread:thread-yield
))
93 (defmacro with-timeout
((timeout) &body body
)
94 `(sb-ext:with-timeout
,timeout
100 'sb-thread
:semaphore
)
102 (defun make-semaphore (&key name
(count 0))
103 (sb-thread:make-semaphore
:name name
:count count
))
105 (defun signal-semaphore (semaphore &key
(count 1))
106 (sb-thread:signal-semaphore semaphore count
))
108 (defun wait-on-semaphore (semaphore &key timeout
)
109 (sb-thread:wait-on-semaphore semaphore
:timeout timeout
))
111 ;;; Introspection/debugging
113 (defun all-threads ()
114 (sb-thread:list-all-threads
))
116 (defun interrupt-thread (thread function
&rest args
)
117 (flet ((apply-function ()
119 (named-lambda %interrupt-thread-wrapper
()
120 (apply function args
))
122 (declare (dynamic-extent #'apply-function
))
123 (sb-thread:interrupt-thread thread
(apply-function))))
125 (defun destroy-thread (thread)
126 (signal-error-if-current-thread thread
)
127 (sb-thread:terminate-thread thread
))
129 (defun thread-alive-p (thread)
130 (sb-thread:thread-alive-p thread
))
132 (defun join-thread (thread)
133 (sb-thread:join-thread thread
))