Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/sionescu-bordeaux-threads-20250412101706/apiv2/impl-sbcl.lisp

KindCoveredAll%
expression4165 2.4
branch020 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- indent-tabs-mode: nil -*-
2
 
3
 (in-package :bordeaux-threads-2)
4
 
5
 ;;;
6
 ;;; Threads
7
 ;;;
8
 
9
 (deftype native-thread ()
10
   'sb-thread:thread)
11
 
12
 (defun %make-thread (function name)
13
   (sb-thread:make-thread function :name name))
14
 
15
 (defun %current-thread ()
16
   sb-thread:*current-thread*)
17
 
18
 (defun %thread-name (thread)
19
   (sb-thread:thread-name thread))
20
 
21
 (defun %join-thread (thread)
22
   (ignore-some-conditions (sb-thread:join-thread-error)
23
     (sb-thread:join-thread thread)))
24
 
25
 (defun %thread-yield ()
26
   (sb-thread:thread-yield))
27
 
28
 ;;;
29
 ;;; Introspection/debugging
30
 ;;;
31
 
32
 (defun %all-threads ()
33
   (sb-thread:list-all-threads))
34
 
35
 (defun %interrupt-thread (thread function)
36
   (sb-thread:interrupt-thread thread function))
37
 
38
 (defun %destroy-thread (thread)
39
   (sb-thread:terminate-thread thread))
40
 
41
 (defun %thread-alive-p (thread)
42
   (sb-thread:thread-alive-p thread))
43
 
44
 
45
 ;;;
46
 ;;; Non-recursive locks
47
 ;;;
48
 
49
 (deftype native-lock ()
50
   'sb-thread:mutex)
51
 
52
 (defun %make-lock (name)
53
   (sb-thread:make-mutex :name name))
54
 
55
 (defun %try-lock (lock)
56
   (sb-sys:without-interrupts
57
     (sb-thread:grab-mutex lock :waitp nil)))
58
 
59
 (defun %lock (lock)
60
   (sb-sys:without-interrupts
61
     (sb-sys:allow-with-interrupts
62
       (loop :while (not (sb-thread:grab-mutex lock :waitp t)))
63
       t)))
64
 
65
 (defun %timedlock (lock timeout)
66
   (let ((deadline (+ (get-internal-real-time)
67
                      (* internal-time-units-per-second
68
                         timeout))))
69
     (sb-sys:without-interrupts
70
       (sb-sys:allow-with-interrupts
71
         (loop :while (not (sb-thread:grab-mutex lock :waitp t :timeout timeout))
72
               :for now := (get-internal-real-time)
73
               :do (if (>= now deadline)
74
                       (return-from %timedlock nil)
75
                       (setf timeout (/ (- deadline now)
76
                                        internal-time-units-per-second))))
77
         t))))
78
 
79
 (defun %acquire-lock (lock waitp timeout)
80
   (cond
81
     ((not waitp)
82
      (%try-lock lock))
83
     ((null timeout)
84
      (%lock lock))
85
     (t
86
      (%timedlock lock timeout))))
87
 
88
 (defun %release-lock (lock)
89
   (sb-sys:without-interrupts
90
     (sb-thread:release-mutex lock)))
91
 
92
 (defmacro %with-lock ((place timeout) &body body)
93
   `(sb-thread:with-mutex (,place :timeout ,timeout) ,@body))
94
 
95
 ;;;
96
 ;;; Recursive locks
97
 ;;;
98
 
99
 (deftype native-recursive-lock ()
100
   'sb-thread:mutex)
101
 
102
 (defun %make-recursive-lock (name)
103
   (sb-thread:make-mutex :name name))
104
 
105
 (mark-not-implemented 'acquire-recursive-lock)
106
 (defun %acquire-recursive-lock (lock waitp timeout)
107
   (declare (ignore lock waitp timeout))
108
   (signal-not-implemented 'acquire-recursive-lock))
109
 
110
 (mark-not-implemented 'release-recursive-lock)
111
 (defun %release-recursive-lock (lock)
112
   (declare (ignore lock))
113
   (signal-not-implemented 'release-recursive-lock))
114
 
115
 (defmacro %with-recursive-lock ((place timeout) &body body)
116
   `(sb-thread:with-recursive-lock (,place :timeout ,timeout)
117
      ,@body))
118
 
119
 
120
 ;;;
121
 ;;; Semaphores
122
 ;;;
123
 
124
 (deftype semaphore ()
125
   'sb-thread:semaphore)
126
 
127
 (defun %make-semaphore (name count)
128
   (sb-thread:make-semaphore :name name :count count))
129
 
130
 (defun %signal-semaphore (semaphore count)
131
   (sb-thread:signal-semaphore semaphore count))
132
 
133
 (defun %wait-on-semaphore (semaphore timeout)
134
   (cond
135
     ((and timeout (zerop timeout))
136
      (sb-thread:try-semaphore semaphore))
137
     (t
138
      (if (sb-thread:wait-on-semaphore semaphore :timeout timeout)
139
          t nil))))
140
 
141
 
142
 ;;;
143
 ;;; Condition variables
144
 ;;;
145
 
146
 (deftype condition-variable ()
147
   'sb-thread:waitqueue)
148
 
149
 (defun %make-condition-variable (name)
150
   (sb-thread:make-waitqueue :name name))
151
 
152
 (defun %condition-wait (cv lock timeout)
153
   (let ((success
154
           (sb-thread:condition-wait cv lock :timeout timeout)))
155
     (when (not success)
156
       (%acquire-lock lock t nil))
157
     success))
158
 
159
 (defun %condition-notify (cv)
160
   (sb-thread:condition-notify cv))
161
 
162
 (defun %condition-broadcast (cv)
163
   (sb-thread:condition-broadcast cv))
164
 
165
 
166
 ;;;
167
 ;;; Timeouts
168
 ;;;
169
 
170
 (defmacro with-timeout ((timeout) &body body)
171
   `(sb-ext:with-timeout ,timeout
172
      ,@body))