1 ;;;; -*- indent-tabs-mode: nil -*-
4 Copyright
2006, 2007 Greg Pfeil
5 Copyright
2010 Jean-Claude Beaudoin.
7 Distributed under the MIT license
(see LICENSE file
)
10 (in-package #:bordeaux-threads
)
17 (defun %make-thread
(function name
)
18 (mt:thread-run-function name function
))
20 (defun current-thread ()
23 (defun threadp (object)
24 (typep object
'mt
:thread
))
26 (defun thread-name (thread)
27 (mt:thread-name thread
))
29 ;;; Resource contention: locks and recursive locks
31 (deftype lock
() 'mt
:lock
)
33 (deftype recursive-lock
()
34 '(and mt
:lock
(satisfies mt
:recursive-lock-p
)))
36 (defun lock-p (object)
37 (typep object
'mt
:lock
))
39 (defun recursive-lock-p (object)
40 (and (typep object
'mt
:lock
)
41 (mt:recursive-lock-p object
)))
43 (defun make-lock (&optional name
)
44 (mt:make-lock
:name
(or name
"Anonymous lock")))
46 (defun acquire-lock (lock &optional
(wait-p t
))
47 (mt:get-lock lock wait-p
))
49 (defun release-lock (lock)
50 (mt:giveup-lock lock
))
52 (defmacro with-lock-held
((place) &body body
)
53 `(mt:with-lock
(,place
) ,@body
))
55 (defun make-recursive-lock (&optional name
)
56 (mt:make-lock
:name
(or name
"Anonymous recursive lock") :recursive t
))
58 (defun acquire-recursive-lock (lock &optional
(wait-p t
))
59 (mt:get-lock lock wait-p
))
61 (defun release-recursive-lock (lock)
62 (mt:giveup-lock lock
))
64 (defmacro with-recursive-lock-held
((place) &body body
)
65 `(mt:with-lock
(,place
) ,@body
))
67 ;;; Resource contention: condition variables
69 (defun make-condition-variable (&key name
)
70 (declare (ignore name
))
71 (mt:make-condition-variable
))
73 (defun condition-wait (condition-variable lock
&key timeout
)
74 (signal-error-if-condition-wait-timeout timeout
)
75 (mt:condition-wait condition-variable lock
)
78 (define-condition-wait-compiler-macro)
80 (defun condition-notify (condition-variable)
81 (mt:condition-signal condition-variable
))
83 (defun thread-yield ()
86 ;;; Introspection/debugging
91 (defun interrupt-thread (thread function
&rest args
)
92 (flet ((apply-function ()
94 (named-lambda %interrupt-thread-wrapper
()
95 (apply function args
))
97 (declare (dynamic-extent #'apply-function
))
98 (mt:interrupt-thread thread
(apply-function))))
100 (defun destroy-thread (thread)
101 (signal-error-if-current-thread thread
)
102 (mt:thread-kill thread
))
104 (defun thread-alive-p (thread)
105 (mt:thread-active-p thread
))
107 (defun join-thread (thread)
108 (mt:thread-join thread
))