default-implementations.lisp - clic - Clic is an command line interactive clien… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
default-implementations.lisp (14739B) | |
--- | |
1 ;;;; -*- indent-tabs-mode: nil -*- | |
2 | |
3 (in-package #:bordeaux-threads) | |
4 | |
5 ;;; Helper macros | |
6 | |
7 (defmacro defdfun (name args doc &body body) | |
8 `(eval-when (:compile-toplevel :load-toplevel :execute) | |
9 (unless (fboundp ',name) | |
10 (defun ,name ,args ,@body)) | |
11 (setf (documentation ',name 'function) | |
12 (or (documentation ',name 'function) ,doc)))) | |
13 | |
14 (defmacro defdmacro (name args doc &body body) | |
15 `(eval-when (:compile-toplevel :load-toplevel :execute) | |
16 (unless (fboundp ',name) | |
17 (defmacro ,name ,args ,@body)) | |
18 (setf (documentation ',name 'function) | |
19 (or (documentation ',name 'function) ,doc)))) | |
20 | |
21 ;;; Thread Creation | |
22 | |
23 (defdfun start-multiprocessing () | |
24 "If the host implementation uses user-level threads, start the | |
25 scheduler and multiprocessing, otherwise do nothing. | |
26 It is safe to call repeatedly." | |
27 nil) | |
28 | |
29 (defdfun make-thread (function &key name | |
30 (initial-bindings *default-special-bindings*)) | |
31 "Creates and returns a thread named NAME, which will call the | |
32 function FUNCTION with no arguments: when FUNCTION returns, the | |
33 thread terminates. NAME defaults to \"Anonymous thread\" if unsupplied. | |
34 | |
35 On systems that do not support multi-threading, MAKE-THREAD will | |
36 signal an error. | |
37 | |
38 The interaction between threads and dynamic variables is in some | |
39 cases complex, and depends on whether the variable has only a global | |
40 binding (as established by e.g. DEFVAR/DEFPARAMETER/top-level SETQ) | |
41 or has been bound locally (e.g. with LET or LET*) in the calling | |
42 thread. | |
43 | |
44 - Global bindings are shared between threads: the initial value of a | |
45 global variable in the new thread will be the same as in the | |
46 parent, and an assignment to such a variable in any thread will be | |
47 visible to all threads in which the global binding is visible. | |
48 | |
49 - Local bindings, such as the ones introduced by INITIAL-BINDINGS, | |
50 are local to the thread they are introduced in, except that | |
51 | |
52 - Local bindings in the the caller of MAKE-THREAD may or may not be | |
53 shared with the new thread that it creates: this is | |
54 implementation-defined. Portable code should not depend on | |
55 particular behaviour in this case, nor should it assign to such | |
56 variables without first rebinding them in the new thread." | |
57 (%make-thread (binding-default-specials function initial-bindings) | |
58 (or name "Anonymous thread"))) | |
59 | |
60 (defdfun %make-thread (function name) | |
61 "The actual implementation-dependent function that creates threads." | |
62 (declare (ignore function name)) | |
63 (error (make-threading-support-error))) | |
64 | |
65 (defdfun current-thread () | |
66 "Returns the thread object for the calling | |
67 thread. This is the same kind of object as would be returned by | |
68 MAKE-THREAD." | |
69 nil) | |
70 | |
71 (defdfun threadp (object) | |
72 "Returns true if object is a thread, otherwise NIL." | |
73 (declare (ignore object)) | |
74 nil) | |
75 | |
76 (defdfun thread-name (thread) | |
77 "Returns the name of the thread, as supplied to MAKE-THREAD." | |
78 (declare (ignore thread)) | |
79 "Main thread") | |
80 | |
81 ;;; Resource contention: locks and recursive locks | |
82 | |
83 (defdfun lock-p (object) | |
84 "Returns T if OBJECT is a lock; returns NIL otherwise." | |
85 (declare (ignore object)) | |
86 nil) | |
87 | |
88 (defdfun recursive-lock-p (object) | |
89 "Returns T if OBJECT is a recursive lock; returns NIL otherwise." | |
90 (declare (ignore object)) | |
91 nil) | |
92 | |
93 (defdfun make-lock (&optional name) | |
94 "Creates a lock (a mutex) whose name is NAME. If the system does not | |
95 support multiple threads this will still return some object, but it | |
96 may not be used for very much." | |
97 ;; In CLIM-SYS this is a freshly consed list (NIL). I don't know if | |
98 ;; there's some good reason it should be said structure or that it | |
99 ;; be freshly consed - EQ comparison of locks? | |
100 (declare (ignore name)) | |
101 (list nil)) | |
102 | |
103 (defdfun acquire-lock (lock &optional wait-p) | |
104 "Acquire the lock LOCK for the calling thread. | |
105 WAIT-P governs what happens if the lock is not available: if WAIT-P | |
106 is true, the calling thread will wait until the lock is available | |
107 and then acquire it; if WAIT-P is NIL, ACQUIRE-LOCK will return | |
108 immediately. ACQUIRE-LOCK returns true if the lock was acquired and | |
109 NIL otherwise. | |
110 | |
111 This specification does not define what happens if a thread | |
112 attempts to acquire a lock that it already holds. For applications | |
113 that require locks to be safe when acquired recursively, see instead | |
114 MAKE-RECURSIVE-LOCK and friends." | |
115 (declare (ignore lock wait-p)) | |
116 t) | |
117 | |
118 (defdfun release-lock (lock) | |
119 "Release LOCK. It is an error to call this unless | |
120 the lock has previously been acquired (and not released) by the same | |
121 thread. If other threads are waiting for the lock, the | |
122 ACQUIRE-LOCK call in one of them will now be able to continue. | |
123 | |
124 This function has no interesting return value." | |
125 (declare (ignore lock)) | |
126 (values)) | |
127 | |
128 (defdmacro with-lock-held ((place) &body body) | |
129 "Evaluates BODY with the lock named by PLACE, the value of which | |
130 is a lock created by MAKE-LOCK. Before the forms in BODY are | |
131 evaluated, the lock is acquired as if by using ACQUIRE-LOCK. After the | |
132 forms in BODY have been evaluated, or if a non-local control transfer | |
133 is caused (e.g. by THROW or SIGNAL), the lock is released as if by | |
134 RELEASE-LOCK. | |
135 | |
136 Note that if the debugger is entered, it is unspecified whether the | |
137 lock is released at debugger entry or at debugger exit when execution | |
138 is restarted." | |
139 `(when (acquire-lock ,place t) | |
140 (unwind-protect | |
141 (locally ,@body) | |
142 (release-lock ,place)))) | |
143 | |
144 (defdfun make-recursive-lock (&optional name) | |
145 "Create and return a recursive lock whose name is NAME. A recursive | |
146 lock differs from an ordinary lock in that a thread that already | |
147 holds the recursive lock can acquire it again without blocking. The | |
148 thread must then release the lock twice before it becomes available | |
149 for another thread." | |
150 (declare (ignore name)) | |
151 (list nil)) | |
152 | |
153 (defdfun acquire-recursive-lock (lock) | |
154 "As for ACQUIRE-LOCK, but for recursive locks." | |
155 (declare (ignore lock)) | |
156 t) | |
157 | |
158 (defdfun release-recursive-lock (lock) | |
159 "Release the recursive LOCK. The lock will only | |
160 become free after as many Release operations as there have been | |
161 Acquire operations. See RELEASE-LOCK for other information." | |
162 (declare (ignore lock)) | |
163 (values)) | |
164 | |
165 (defdmacro with-recursive-lock-held ((place &key timeout) &body body) | |
166 "Evaluates BODY with the recursive lock named by PLACE, which is a | |
167 reference to a recursive lock created by MAKE-RECURSIVE-LOCK. See | |
168 WITH-LOCK-HELD etc etc" | |
169 (declare (ignore timeout)) | |
170 `(when (acquire-recursive-lock ,place) | |
171 (unwind-protect | |
172 (locally ,@body) | |
173 (release-recursive-lock ,place)))) | |
174 | |
175 ;;; Resource contention: condition variables | |
176 | |
177 ;;; A condition variable provides a mechanism for threads to put | |
178 ;;; themselves to sleep while waiting for the state of something to | |
179 ;;; change, then to be subsequently woken by another thread which has | |
180 ;;; changed the state. | |
181 ;;; | |
182 ;;; A condition variable must be used in conjunction with a lock to | |
183 ;;; protect access to the state of the object of interest. The | |
184 ;;; procedure is as follows: | |
185 ;;; | |
186 ;;; Suppose two threads A and B, and some kind of notional event | |
187 ;;; channel C. A is consuming events in C, and B is producing them. | |
188 ;;; CV is a condition-variable | |
189 ;;; | |
190 ;;; 1) A acquires the lock that safeguards access to C | |
191 ;;; 2) A threads and removes all events that are available in C | |
192 ;;; 3) When C is empty, A calls CONDITION-WAIT, which atomically | |
193 ;;; releases the lock and puts A to sleep on CV | |
194 ;;; 4) Wait to be notified; CONDITION-WAIT will acquire the lock again | |
195 ;;; before returning | |
196 ;;; 5) Loop back to step 2, for as long as threading should continue | |
197 ;;; | |
198 ;;; When B generates an event E, it | |
199 ;;; 1) acquires the lock guarding C | |
200 ;;; 2) adds E to the channel | |
201 ;;; 3) calls CONDITION-NOTIFY on CV to wake any sleeping thread | |
202 ;;; 4) releases the lock | |
203 ;;; | |
204 ;;; To avoid the "lost wakeup" problem, the implementation must | |
205 ;;; guarantee that CONDITION-WAIT in thread A atomically releases the | |
206 ;;; lock and sleeps. If this is not guaranteed there is the | |
207 ;;; possibility that thread B can add an event and call | |
208 ;;; CONDITION-NOTIFY between the lock release and the sleep - in this | |
209 ;;; case the notify call would not see A, which would be left sleeping | |
210 ;;; despite there being an event available. | |
211 | |
212 (defdfun thread-yield () | |
213 "Allows other threads to run. It may be necessary or desirable to | |
214 call this periodically in some implementations; others may schedule | |
215 threads automatically. On systems that do not support | |
216 multi-threading, this does nothing." | |
217 (values)) | |
218 | |
219 (defdfun make-condition-variable (&key name) | |
220 "Returns a new condition-variable object for use | |
221 with CONDITION-WAIT and CONDITION-NOTIFY." | |
222 (declare (ignore name)) | |
223 nil) | |
224 | |
225 (defdfun condition-wait (condition-variable lock &key timeout) | |
226 "Atomically release LOCK and enqueue the calling | |
227 thread waiting for CONDITION-VARIABLE. The thread will resume when | |
228 another thread has notified it using CONDITION-NOTIFY; it may also | |
229 resume if interrupted by some external event or in other | |
230 implementation-dependent circumstances: the caller must always test | |
231 on waking that there is threading to be done, instead of assuming | |
232 that it can go ahead. | |
233 | |
234 It is an error to call function this unless from the thread that | |
235 holds LOCK. | |
236 | |
237 If TIMEOUT is nil or not provided, the system always reacquires LOCK | |
238 before returning to the caller. In this case T is returned. | |
239 | |
240 If TIMEOUT is non-nil, the call will return after at most TIMEOUT | |
241 seconds (approximately), whether or not a notification has occurred. | |
242 Either NIL or T will be returned. A return of NIL indicates that the | |
243 lock is no longer held and that the timeout has expired. A return of | |
244 T indicates that the lock is held, in which case the timeout may or | |
245 may not have expired. | |
246 | |
247 **NOTE**: The behavior of CONDITION-WAIT with TIMEOUT diverges from | |
248 the POSIX function pthread_cond_timedwait. The former may return | |
249 without the lock being held while the latter always returns with the | |
250 lock held. | |
251 | |
252 In an implementation that does not support multiple threads, this | |
253 function signals an error." | |
254 (declare (ignore condition-variable lock timeout)) | |
255 (error (make-threading-support-error))) | |
256 | |
257 (defdfun condition-notify (condition-variable) | |
258 "Notify at least one of the threads waiting for | |
259 CONDITION-VARIABLE. It is implementation-dependent whether one or | |
260 more than one (and possibly all) threads are woken, but if the | |
261 implementation is capable of waking only a single thread (not all | |
262 are) this is probably preferable for efficiency reasons. The order | |
263 of wakeup is unspecified and does not necessarily relate to the | |
264 order that the threads went to sleep in. | |
265 | |
266 CONDITION-NOTIFY has no useful return value. In an implementation | |
267 that does not support multiple threads, it has no effect." | |
268 (declare (ignore condition-variable)) | |
269 (values)) | |
270 | |
271 ;;; Resource contention: semaphores | |
272 | |
273 (defdfun make-semaphore (&key name (count 0)) | |
274 "Create a semaphore with the supplied NAME and initial counter value… | |
275 (make-%semaphore :lock (make-lock name) | |
276 :condition-variable (make-condition-variable :name na… | |
277 :counter count)) | |
278 | |
279 (defdfun signal-semaphore (semaphore &key (count 1)) | |
280 "Increment SEMAPHORE by COUNT. If there are threads waiting on this | |
281 semaphore, then COUNT of them are woken up." | |
282 (with-lock-held ((%semaphore-lock semaphore)) | |
283 (incf (%semaphore-counter semaphore) count) | |
284 (dotimes (v count) | |
285 (condition-notify (%semaphore-condition-variable semaphore)))) | |
286 (values)) | |
287 | |
288 (defdfun wait-on-semaphore (semaphore &key timeout) | |
289 "Decrement the count of SEMAPHORE by 1 if the count would not be negat… | |
290 | |
291 Else blocks until the semaphore can be decremented. Returns generalized … | |
292 T on success. | |
293 | |
294 If TIMEOUT is given, it is the maximum number of seconds to wait. If the… | |
295 cannot be decremented in that time, returns NIL without decrementing the… | |
296 (with-lock-held ((%semaphore-lock semaphore)) | |
297 (if (>= (%semaphore-counter semaphore) 1) | |
298 (decf (%semaphore-counter semaphore)) | |
299 (let ((deadline (when timeout | |
300 (+ (get-internal-real-time) | |
301 (* timeout internal-time-units-per-second))… | |
302 ;; we need this loop because of a spurious wakeup possibility | |
303 (loop until (>= (%semaphore-counter semaphore) 1) | |
304 do (cond | |
305 ((null (condition-wait (%semaphore-condition-variable … | |
306 (%semaphore-lock semaphore) | |
307 :timeout timeout)) | |
308 (return-from wait-on-semaphore)) | |
309 ;; unfortunately cv-wait may return T on timeout too | |
310 ((and deadline (>= (get-internal-real-time) deadline)) | |
311 (return-from wait-on-semaphore)) | |
312 (timeout | |
313 (setf timeout (/ (- deadline (get-internal-real-time)) | |
314 internal-time-units-per-second))))) | |
315 (decf (%semaphore-counter semaphore)))))) | |
316 | |
317 (defdfun semaphore-p (object) | |
318 "Returns T if OBJECT is a semaphore; returns NIL otherwise." | |
319 (typep object 'semaphore)) | |
320 | |
321 ;;; Introspection/debugging | |
322 | |
323 ;;; The following functions may be provided for debugging purposes, | |
324 ;;; but are not advised to be called from normal user code. | |
325 | |
326 (defdfun all-threads () | |
327 "Returns a sequence of all of the threads. This may not | |
328 be freshly-allocated, so the caller should not modify it." | |
329 (error (make-threading-support-error))) | |
330 | |
331 (defdfun interrupt-thread (thread function) | |
332 "Interrupt THREAD and cause it to evaluate FUNCTION | |
333 before continuing with the interrupted path of execution. This may | |
334 not be a good idea if THREAD is holding locks or doing anything | |
335 important. On systems that do not support multiple threads, this | |
336 function signals an error." | |
337 (declare (ignore thread function)) | |
338 (error (make-threading-support-error))) | |
339 | |
340 (defdfun destroy-thread (thread) | |
341 "Terminates the thread THREAD, which is an object | |
342 as returned by MAKE-THREAD. This should be used with caution: it is | |
343 implementation-defined whether the thread runs cleanup forms or | |
344 releases its locks first. | |
345 | |
346 Destroying the calling thread is an error." | |
347 (declare (ignore thread)) | |
348 (error (make-threading-support-error))) | |
349 | |
350 (defdfun thread-alive-p (thread) | |
351 "Returns true if THREAD is alive, that is, if | |
352 DESTROY-THREAD has not been called on it." | |
353 (declare (ignore thread)) | |
354 (error (make-threading-support-error))) | |
355 | |
356 (defdfun join-thread (thread) | |
357 "Wait until THREAD terminates. If THREAD has already terminated, | |
358 return immediately. The return values of the thread function are | |
359 returned." | |
360 (declare (ignore thread)) | |
361 (error (make-threading-support-error))) |