1 ;;;; -*- indent-tabs-mode: nil -*-
3 (in-package :bordeaux-threads-2
)
9 (deftype native-thread
()
10 'mezzano.supervisor
:thread
)
12 (defun %make-thread
(function name
)
13 (mezzano.supervisor
:make-thread function
:name name
))
15 (defun %current-thread
()
16 (mezzano.supervisor
:current-thread
))
18 (defun %thread-name
(thread)
19 (mezzano.supervisor
:thread-name thread
))
21 (defun %join-thread
(thread)
22 ;; THREAD-JOIN can return non-lists if the thread was destroyed.
23 (let ((values (mezzano.supervisor
:thread-join thread
)))
28 (defun %thread-yield
()
29 (mezzano.supervisor
:thread-yield
))
32 ;;; Introspection/debugging
35 (defun %all-threads
()
36 (mezzano.supervisor
:all-threads
))
38 (defun %interrupt-thread
(thread function
)
39 (mezzano.supervisor
:establish-thread-foothold thread function
))
41 (defun %destroy-thread
(thread)
42 (mezzano.supervisor
:terminate-thread thread
))
44 (defun %thread-alive-p
(thread)
45 (not (eql (mezzano.supervisor
:thread-state thread
) :dead
)))
49 ;;; Non-recursive locks
52 (deftype native-lock
() 'mezzano.supervisor
:mutex
)
54 (defun %make-lock
(name)
55 (mezzano.supervisor
:make-mutex name
))
57 (mark-not-implemented 'acquire-lock
:timeout
)
58 (defun %acquire-lock
(lock waitp timeout
)
60 (signal-not-implemented 'acquire-lock
:timeout
))
61 (mezzano.supervisor
:acquire-mutex lock waitp
))
63 (defun %release-lock
(lock)
64 (mezzano.supervisor
:release-mutex lock
))
66 (mark-not-implemented 'with-lock-held
:timeout
)
67 (defmacro %with-lock
((place timeout
) &body body
)
69 `(signal-not-implemented 'with-lock-held
:timeout
)
70 `(mezzano.supervisor
:with-mutex
(,place
) ,@body
)))
76 (defstruct (%recursive-lock
77 (:constructor %make-recursive-lock-internal
(mutex)))
81 (deftype native-recursive-lock
() '%recursive-lock
)
83 (defun %make-recursive-lock
(name)
84 (%make-recursive-lock-internal
(%make-lock name
)))
86 (mark-not-implemented 'acquire-recursive-lock
)
87 (defun %acquire-recursive-lock
(lock waitp timeout
)
88 (declare (ignore lock waitp timeout
))
89 (signal-not-implemented 'acquire-recursive-lock
))
91 (release-not-implemented 'release-recursive-lock
)
92 (defun %release-recursive-lock
(lock)
93 (declare (ignore lock
))
94 (signal-not-implemented 'release-recursive-lock
))
96 (defun call-with-recursive-lock-held (lock function
)
97 (cond ((mezzano.supervisor
:mutex-held-p
98 (%recursive-lock-mutex lock
))
100 (progn (incf (%recursive-lock-depth lock
))
102 (decf (%recursive-lock-depth lock
))))
104 (mezzano.supervisor
:with-mutex
((%recursive-lock-mutex lock
))
105 (multiple-value-prog1
107 (assert (zerop (%recursive-lock-depth lock
))))))))
109 (mark-not-implemented 'with-recursive-lock-held
:timeout
)
110 (defmacro %with-recursive-lock
((place timeout
) &body body
)
112 `(signal-not-implemented 'with-recursive-lock-held
:timeout
)
113 `(call-with-recursive-lock-held ,place
(lambda () ,@body
))))
120 (deftype semaphore
()
121 'mezzano.sync
:semaphore
)
123 (defun %make-semaphore
(name count
)
124 (mezzano.sync
:make-semaphore
:name name
:value count
))
126 (defun %signal-semaphore
(semaphore count
)
127 (dotimes (c count
) (mezzano.sync
:semaphore-up semaphore
)))
129 (defun %wait-on-semaphore
(semaphore timeout
)
130 (mezzano.supervisor
:event-wait-for
(semaphore :timeout timeout
)
131 (mezzano.sync
:semaphore-down semaphore
:wait-p nil
)))
135 ;;; Condition variables
138 (deftype condition-variable
()
139 'mezzano.supervisor
:condition-variable
)
141 (defun %make-condition-variable
(name)
142 (mezzano.supervisor
:make-condition-variable name
))
144 (defun %condition-wait
(cv lock timeout
)
145 (mezzano.supervisor
:condition-wait cv lock timeout
))
147 (defun %condition-notify
(cv)
148 (mezzano.supervisor
:condition-notify cv
))
150 (mark-not-implemented 'condition-broadcast
)
151 (defun %condition-broadcast
(cv)
152 (declare (ignore cv
))
153 (signal-not-implemented 'condition-broadcast
))