1 ;;;; -*- indent-tabs-mode: nil -*-
3 (in-package :bordeaux-threads-2
)
6 (error 'bordeaux-threads-error
7 :message
"Threading not supported")
13 (deftype native-thread
()
16 (defun %start-multiprocessing
()
19 (defun %make-thread
(function name
)
20 (mp:process-run-function name function
))
22 (defun %current-thread
()
25 (defun %thread-name
(thread)
26 (mp:process-name thread
))
28 (defun %join-thread
(thread)
30 (mp:process-join thread
)
32 (mp:process-wait
(format nil
"Waiting for thread ~A to complete" thread
)
33 (complement #'mp
:process-alive-p
)
36 (defun %thread-yield
()
37 (mp:process-allow-schedule
))
40 ;;; Introspection/debugging
43 (defun %all-threads
()
46 (defun %interrupt-thread
(thread function
)
47 (mp:process-interrupt thread function
))
49 (defun %destroy-thread
(thread)
50 (mp:process-kill thread
))
52 (defun %thread-alive-p
(thread)
53 (mp:process-alive-p thread
))
57 ;;; Non-recursive locks
60 (deftype native-lock
() 'mp
:process-lock
)
62 (defun %make-lock
(name)
63 (mp:make-process-lock
:name name
))
65 (defun %acquire-lock
(lock waitp timeout
)
66 (mp:process-lock lock mp
:*current-process
* "Lock"
67 (if waitp timeout
0)))
69 (defun %release-lock
(lock)
70 (mp:process-unlock lock
))
72 (defmacro %with-lock
((place timeout
) &body body
)
73 `(mp:with-process-lock
(,place
:timeout
,timeout
:norecursive t
)
80 (deftype native-recursive-lock
() 'mp
:process-lock
)
82 (defun %make-recursive-lock
(name)
83 (mp:make-process-lock
:name name
))
85 (mark-not-implemented 'acquire-recursive-lock
)
86 (defun %acquire-recursive-lock
(lock waitp timeout
)
87 (declare (ignore lock waitp timeout
))
88 (signal-not-implemented 'acquire-recursive-lock
))
90 (mark-not-implemented 'release-recursive-lock
)
91 (defun %release-recursive-lock
(lock)
92 (declare (ignore lock
))
93 (signal-not-implemented 'release-recursive-lock
))
95 (defmacro %with-recursive-lock
((place timeout
) &body body
)
96 `(mp:with-process-lock
(,place
:timeout
,timeout
)
104 (defmacro with-timeout
((timeout) &body body
)
106 `(mp:with-timeout
(,timeout
(error 'timeout
:length
,timeout
))
114 (defstruct (semaphore
115 (:constructor %%make-semaphore
(name)))
116 "Bordeaux-threads implementation of semaphores."
118 (gate (mp:make-gate nil
)))
120 (defmethod print-object ((sem semaphore
) stream
)
121 (print-unreadable-object (sem stream
:type t
:identity t
)
122 (format stream
"~S" (semaphore-name sem
))))
124 (defun %make-semaphore
(name count
)
125 (let ((sem (%%make-semaphore name
)))
126 (%signal-semaphore sem count
)
129 (defun %signal-semaphore
(semaphore count
)
131 (mp:put-semaphore
(semaphore-gate semaphore
))))
133 (defun %wait-on-semaphore
(semaphore timeout
)
136 ;; Timeouts that are too small expire immediately.
137 ;; 100ms should suffice.
138 (when (< timeout
0.1)
141 (with-timeout (timeout)
142 (mp:get-semaphore
(semaphore-gate semaphore
))
146 (mp:get-semaphore
(semaphore-gate semaphore
))
151 ;;; Condition variables
154 (deftype condition-variable
()
155 'mp
:condition-variable
)
157 (defun %make-condition-variable
(name)
158 (mp:make-condition-variable
:name name
))
160 (defun %condition-wait
(cv lock timeout
)
161 (mp:condition-variable-wait cv lock
:timeout timeout
))
163 (defun %condition-notify
(cv)
164 (mp:condition-variable-signal cv
))
166 (defun %condition-broadcast
(cv)
167 (mp:condition-variable-broadcast cv
))