1 ;;;; -*- indent-tabs-mode: nil -*-
3 (in-package :bordeaux-threads-2
)
5 (eval-when (:compile-toplevel
:execute
)
6 (when (>= ext
:+ecl-version-number
+ 230909)
7 (pushnew :has-timeouts
*features
*)))
13 (deftype native-thread
()
16 (defun %make-thread
(function name
)
17 (mp:process-run-function name function
))
19 (defun %current-thread
()
22 (defun %thread-name
(thread)
23 ;; Some system threads have symbols for a name.
24 (string (mp:process-name thread
)))
26 (defun %join-thread
(thread)
27 (mp:process-join thread
))
29 (defun %thread-yield
()
33 ;;; Introspection/debugging
36 (defun %all-threads
()
39 (defun %interrupt-thread
(thread function
)
40 (mp:interrupt-process thread function
))
42 (defun %destroy-thread
(thread)
43 (mp:process-kill thread
))
45 (defun %thread-alive-p
(thread)
46 (mp:process-active-p thread
))
50 ;;; Non-recursive locks
53 (deftype native-lock
() 'mp
:lock
)
55 (defun %make-lock
(name)
56 (mp:make-lock
:name name
))
60 (mark-not-implemented 'acquire-lock
:timeout
)
61 (defun %acquire-lock
(lock waitp timeout
)
63 (signal-not-implemented 'acquire-lock
:timeout
))
64 (mp:get-lock lock waitp
)))
67 (defun %acquire-lock
(lock waitp timeout
)
68 (mp:get-lock lock
(cond ((not waitp
) nil
)
72 (defun %release-lock
(lock)
73 (mp:giveup-lock lock
))
77 (mark-not-implemented 'with-lock-held
:timeout
)
78 (defmacro %with-lock
((place timeout
) &body body
)
80 `(signal-not-implemented 'with-lock-held
:timeout
)
81 `(mp:with-lock
(,place
) ,@body
))))
84 (defmacro %with-lock
((place timeout
) &body body
)
85 `(mp:with-lock
(,place
:wait-form
(or ,timeout t
))
92 (deftype native-recursive-lock
()
93 '(and mp
:lock
(satisfies mp
:recursive-lock-p
)))
95 (defun %make-recursive-lock
(name)
96 (mp:make-lock
:name name
:recursive t
))
100 (mark-not-implemented 'acquire-recursive-lock
:timeout
)
101 (defun %acquire-recursive-lock
(lock waitp timeout
)
103 (signal-not-implemented 'acquire-recursive-lock
:timeout
))
104 (mp:get-lock lock waitp
)))
107 (defun %acquire-recursive-lock
(lock waitp timeout
)
108 (mp:get-lock lock
(cond ((not waitp
) nil
)
112 (defun %release-recursive-lock
(lock)
113 (mp:giveup-lock lock
))
117 (mark-not-implemented 'with-recursive-lock-held
:timeout
)
118 (defmacro %with-recursive-lock
((place timeout
) &body body
)
120 `(signal-not-implemented 'with-recursive-lock-held
:timeout
)
121 `(mp:with-lock
(,place
) ,@body
))))
124 (defmacro %with-recursive-lock
((place timeout
) &body body
)
125 `(mp:with-lock
(,place
:wait-form
(or ,timeout t
))
133 (deftype semaphore
() 'mp
:semaphore
)
135 (defun %make-semaphore
(name count
)
136 (mp:make-semaphore
:name name
:count count
))
138 (defun %signal-semaphore
(semaphore count
)
139 (mp:signal-semaphore semaphore count
))
141 (defun %wait-on-semaphore
(semaphore timeout
)
144 (mp:wait-on-semaphore semaphore
)
149 (with-timeout (timeout)
150 (mp:wait-on-semaphore semaphore
)
154 (mp:semaphore-wait semaphore
1 timeout
))
156 (if (mp:try-get-semaphore semaphore
) t nil
))))
160 ;;; Condition variables
163 (deftype condition-variable
()
164 'mp
:condition-variable
)
166 (defun %make-condition-variable
( name
)
167 (declare (ignore name
))
168 (mp:make-condition-variable
))
170 (defun %condition-wait
(cv lock timeout
)
174 (with-timeout (timeout)
175 (mp:condition-variable-wait cv lock
))
177 (%acquire-lock lock t nil
)
180 (mp:condition-variable-timedwait cv lock timeout
)
181 (mp:condition-variable-wait cv lock
)))
183 (defun %condition-notify
(cv)
184 (mp:condition-variable-signal cv
))
186 (defun %condition-broadcast
(cv)
187 (mp:condition-variable-broadcast cv
))
189 (eval-when (:compile-toplevel
:execute
)
190 (setf *features
* (remove :has-timeouts
*features
*)))