1 ;;;; -*- indent-tabs-mode: nil -*-
3 (in-package :bordeaux-threads-2
)
9 (deftype native-thread
()
12 (defun %make-thread
(function name
)
13 (mp:process-run-function name function
))
15 (defun %current-thread
()
18 (defun %thread-name
(thread)
19 ;; Some system threads have symbols for a name.
20 (string (mp:process-name thread
)))
22 (defun %join-thread
(thread)
23 (mp:process-join thread
))
25 (defun %thread-yield
()
29 ;;; Introspection/debugging
32 (defun %all-threads
()
35 (defun %interrupt-thread
(thread function
)
36 (mp:interrupt-process thread function
))
38 (defun %destroy-thread
(thread)
39 (mp:process-kill thread
))
41 (defun %thread-alive-p
(thread)
42 (mp:process-active-p thread
))
46 ;;; Non-recursive locks
49 (deftype native-lock
() 'mp
:lock
)
51 (defun %make-lock
(name)
52 (mp:make-lock
:name name
))
54 (mark-not-implemented 'acquire-lock
:timeout
)
55 (defun %acquire-lock
(lock waitp timeout
)
57 (signal-not-implemented 'acquire-lock
:timeout
))
58 (mp:get-lock lock waitp
))
60 (defun %release-lock
(lock)
61 (mp:giveup-lock lock
))
63 (mark-not-implemented 'with-lock-held
:timeout
)
64 (defmacro %with-lock
((place timeout
) &body body
)
66 `(signal-not-implemented 'with-lock-held
:timeout
)
67 `(mp:with-lock
(,place
) ,@body
)))
73 (deftype native-recursive-lock
()
74 '(and mp
:lock
(satisfies mp
:recursive-lock-p
)))
76 (defun %make-recursive-lock
(name)
77 (mp:make-lock
:name name
:recursive t
))
79 (mark-not-implemented 'acquire-recursive-lock
:timeout
)
80 (defun %acquire-recursive-lock
(lock waitp timeout
)
82 (signal-not-implemented 'acquire-recursive-lock
:timeout
))
83 (mp:get-lock lock waitp
))
85 (defun %release-recursive-lock
(lock)
86 (mp:giveup-lock lock
))
88 (mark-not-implemented 'with-recursive-lock-held
:timeout
)
89 (defmacro %with-recursive-lock
((place timeout
) &body body
)
91 `(signal-not-implemented 'with-recursive-lock-held
:timeout
)
92 `(mp:with-lock
(,place
) ,@body
)))
99 (deftype semaphore
() 'mp
:semaphore
)
101 (defun %make-semaphore
(name count
)
102 (mp:make-semaphore
:name name
:count count
))
104 (defun %signal-semaphore
(semaphore count
)
105 (mp:signal-semaphore semaphore count
))
107 (defun %wait-on-semaphore
(semaphore timeout
)
110 (mp:wait-on-semaphore semaphore
)
114 (with-timeout (timeout)
115 (mp:wait-on-semaphore semaphore
)
119 (if (mp:try-get-semaphore semaphore
) t nil
))))
123 ;;; Condition variables
126 (deftype condition-variable
()
127 'mp
:condition-variable
)
129 (defun %make-condition-variable
( name
)
130 (declare (ignore name
))
131 (mp:make-condition-variable
))
133 (defun %condition-wait
(cv lock timeout
)
136 (with-timeout (timeout)
137 (mp:condition-variable-wait cv lock
))
139 (%acquire-lock lock t nil
)
141 (mp:condition-variable-wait cv lock
)))
143 (defun %condition-notify
(cv)
144 (mp:condition-variable-signal cv
))
146 (defun %condition-broadcast
(cv)
147 (mp:condition-variable-broadcast cv
))