1 ;;;; -*- indent-tabs-mode: nil -*-
4 Copyright
2008 Scieneer Pty Ltd
6 Distributed under the MIT license
(see LICENSE file
)
9 (in-package #:bordeaux-threads
)
14 (defun %make-thread
(function name
)
15 (thread:thread-create function
:name name
))
17 (defun current-thread ()
20 (defun threadp (object)
21 (typep object
'thread
:thread
))
23 (defun thread-name (thread)
24 (thread:thread-name thread
))
26 ;;; Resource contention: locks and recursive locks
28 (deftype lock
() 'thread
:lock
)
30 (deftype recursive-lock
() 'thread
:recursive-lock
)
32 (defun lock-p (object)
33 (typep object
'thread
:lock
))
35 (defun recursive-lock-p (object)
36 (typep object
'thread
:recursive-lock
))
38 (defun make-lock (&optional name
)
39 (thread:make-lock
(or name
"Anonymous lock")))
41 (defun acquire-lock (lock &optional
(wait-p t
))
42 (thread::acquire-lock lock nil wait-p
))
44 (defun release-lock (lock)
45 (thread::release-lock lock
))
47 (defmacro with-lock-held
((place) &body body
)
48 `(thread:with-lock-held
(,place
) ,@body
))
50 (defun make-recursive-lock (&optional name
)
51 (thread:make-lock
(or name
"Anonymous recursive lock")
54 ;;; XXX acquire-recursive-lock and release-recursive-lock are actually
55 ;;; complicated because we can't use control stack tricks. We need to
56 ;;; actually count something to check that the acquire/releases are
59 (defmacro with-recursive-lock-held
((place) &body body
)
60 `(thread:with-lock-held
(,place
)
63 ;;; Resource contention: condition variables
65 (defun make-condition-variable (&key name
)
66 (thread:make-cond-var
(or name
"Anonymous condition variable")))
68 (defun condition-wait (condition-variable lock
&key timeout
)
70 (thread:cond-var-timedwait condition-variable lock timeout
)
71 (thread:cond-var-wait condition-variable lock
))
74 (defun condition-notify (condition-variable)
75 (thread:cond-var-broadcast condition-variable
))
77 (defun thread-yield ()
80 ;;; Introspection/debugging
85 (defun interrupt-thread (thread function
&rest args
)
86 (flet ((apply-function ()
88 (named-lambda %interrupt-thread-wrapper
()
89 (apply function args
))
91 (declare (dynamic-extent #'apply-function
))
92 (thread:thread-interrupt thread
(apply-function))))
94 (defun destroy-thread (thread)
95 (thread:destroy-thread thread
))
97 (defun thread-alive-p (thread)
98 (mp:process-alive-p thread
))
100 (defun join-thread (thread)
101 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
102 (named-lambda %thread-completedp
()
103 (not (mp:process-alive-p thread
)))))