Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv1/default-implementations.lisp

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