1.0.37.31: Use (WITH-TEST ...) consistently in threads.impure.lisp.
[sbcl.git] / src / code / thread.lisp
1 ;;;; support for threads needed at cross-compile time
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!THREAD")
13
14 (def!type thread-name ()
15   'simple-string)
16
17 (def!struct (thread (:constructor %make-thread))
18   #!+sb-doc
19   "Thread type. Do not rely on threads being structs as it may change
20 in future versions."
21   (name          nil :type (or thread-name null))
22   (%alive-p      nil :type boolean)
23   (os-thread     nil :type (or integer null))
24   (whostate      nil :type (or null simple-string))
25   (interruptions nil :type list)
26   (result        nil :type list)
27   (interruptions-lock
28    (make-mutex :name "thread interruptions lock")
29    :type mutex)
30   (result-lock
31    (make-mutex :name "thread result lock")
32    :type mutex))
33
34 (def!struct mutex
35   #!+sb-doc
36   "Mutex type."
37   (name   nil :type (or null thread-name))
38   (%owner nil :type (or null thread))
39   #!+(and (not sb-lutex) sb-thread)
40   (state    0 :type fixnum)
41   #!+(and sb-lutex sb-thread)
42   (lutex (make-lutex)))
43
44 (defun mutex-value (mutex)
45   "Current owner of the mutex, NIL if the mutex is free. May return a
46 stale value, use MUTEX-OWNER instead."
47   (mutex-%owner mutex))
48
49 (defun holding-mutex-p (mutex)
50   "Test whether the current thread is holding MUTEX."
51   ;; This is about the only use for which a stale value of owner is
52   ;; sufficient.
53   (eq sb!thread:*current-thread* (mutex-%owner mutex)))
54
55 (defsetf mutex-value set-mutex-value)
56
57 (declaim (inline set-mutex-value))
58 (defun set-mutex-value (mutex value)
59   (declare (ignore mutex value))
60   (error "~S is no longer supported." '(setf mutex-value)))
61
62 (define-compiler-macro set-mutex-value (&whole form mutex value)
63   (declare (ignore mutex value))
64   (warn "~S is no longer supported, and will signal an error at runtime."
65         '(setf mutex-value))
66   form)
67
68 (def!struct spinlock
69   #!+sb-doc
70   "Spinlock type."
71   (name  nil :type (or null thread-name))
72   (value nil))
73
74 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
75                             &body body)
76   #!+sb-doc
77   "Acquire MUTEX for the dynamic scope of BODY, setting it to VALUE or
78 some suitable default value if NIL.  If WAIT-P is non-NIL and the mutex
79 is in use, sleep until it is available"
80   `(dx-flet ((with-mutex-thunk () ,@body))
81      (call-with-mutex
82       #'with-mutex-thunk
83       ,mutex
84       ,value
85       ,wait-p)))
86
87 (sb!xc:defmacro with-system-mutex ((mutex
88                                     &key without-gcing allow-with-interrupts)
89                                    &body body)
90   `(dx-flet ((with-system-mutex-thunk () ,@body))
91      (,(cond (without-gcing
92                'call-with-system-mutex/without-gcing)
93              (allow-with-interrupts
94               'call-with-system-mutex/allow-with-interrupts)
95              (t
96               'call-with-system-mutex))
97        #'with-system-mutex-thunk
98        ,mutex)))
99
100 (sb!xc:defmacro with-system-spinlock ((spinlock &key) &body body)
101   `(dx-flet ((with-system-spinlock-thunk () ,@body))
102      (call-with-system-spinlock
103        #'with-system-spinlock-thunk
104        ,spinlock)))
105
106 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
107   #!+sb-doc
108   "Acquires MUTEX for the dynamic scope of BODY. Within that scope
109 further recursive lock attempts for the same mutex succeed. It is
110 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
111 provided the default value is used for the mutex."
112   `(dx-flet ((with-recursive-lock-thunk () ,@body))
113      (call-with-recursive-lock
114       #'with-recursive-lock-thunk
115       ,mutex)))
116
117 (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
118   `(dx-flet ((with-recursive-spinlock-thunk () ,@body))
119      (call-with-recursive-spinlock
120       #'with-recursive-spinlock-thunk
121       ,spinlock)))
122
123 (sb!xc:defmacro with-recursive-system-spinlock ((spinlock
124                                                  &key without-gcing)
125                                                 &body body)
126   `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body))
127      (,(cond (without-gcing
128                'call-with-recursive-system-spinlock/without-gcing)
129              (t
130               'call-with-recursive-system-spinlock))
131        #'with-recursive-system-spinlock-thunk
132        ,spinlock)))
133
134 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
135   `(dx-flet ((with-spinlock-thunk () ,@body))
136      (call-with-spinlock
137       #'with-spinlock-thunk
138       ,spinlock)))
139
140 (macrolet ((def (name &optional variant)
141              `(defun ,(if variant (symbolicate name "/" variant) name)
142                   (function mutex)
143                 (declare (function function))
144                 (flet ((%call-with-system-mutex ()
145                          (dx-let (got-it)
146                            (unwind-protect
147                                 (when (setf got-it (get-mutex mutex))
148                                   (funcall function))
149                              (when got-it
150                                (release-mutex mutex))))))
151                   (declare (inline %call-with-system-mutex))
152                   ,(ecase variant
153                      (:without-gcing
154                        `(without-gcing (%call-with-system-mutex)))
155                      (:allow-with-interrupts
156                        `(without-interrupts
157                           (allow-with-interrupts (%call-with-system-mutex))))
158                      ((nil)
159                       `(without-interrupts (%call-with-system-mutex))))))))
160   (def call-with-system-mutex)
161   (def call-with-system-mutex :without-gcing)
162   (def call-with-system-mutex :allow-with-interrupts))
163
164 #!-sb-thread
165 (progn
166   (macrolet ((def (name &optional variant)
167                `(defun ,(if variant (symbolicate name "/" variant) name)
168                     (function lock)
169                   (declare (ignore lock) (function function))
170                   ,(ecase variant
171                     (:without-gcing
172                       `(without-gcing (funcall function)))
173                     (:allow-with-interrupts
174                       `(without-interrupts
175                          (allow-with-interrupts (funcall function))))
176                     ((nil)
177                       `(without-interrupts (funcall function)))))))
178     (def call-with-system-spinlock)
179     (def call-with-recursive-system-spinlock)
180     (def call-with-recursive-system-spinlock :without-gcing))
181
182   (defun call-with-mutex (function mutex value waitp)
183     (declare (ignore mutex value waitp)
184              (function function))
185     (funcall function))
186
187   (defun call-with-recursive-lock (function mutex)
188     (declare (ignore mutex) (function function))
189     (funcall function))
190
191   (defun call-with-spinlock (function spinlock)
192     (declare (ignore spinlock) (function function))
193     (funcall function))
194
195   (defun call-with-recursive-spinlock (function spinlock)
196     (declare (ignore spinlock) (function function))
197     (funcall function)))
198
199 #!+sb-thread
200 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
201 ;;; closes over GOT-IT causes a value-cell to be allocated for it --
202 ;;; and we prefer that to go on the stack since it can.
203 (progn
204   (defun call-with-system-spinlock (function spinlock)
205     (declare (function function))
206     (without-interrupts
207       (dx-let (got-it)
208         (unwind-protect
209              (when (setf got-it (get-spinlock spinlock))
210                (funcall function))
211           (when got-it
212             (release-spinlock spinlock))))))
213
214   (macrolet ((def (name &optional variant)
215                `(defun ,(if variant (symbolicate name "/" variant) name)
216                     (function spinlock)
217                   (declare (function function))
218                   (flet ((%call-with-system-spinlock ()
219                            (dx-let ((inner-lock-p
220                                      (eq *current-thread*
221                                          (spinlock-value spinlock)))
222                                     (got-it nil))
223                              (unwind-protect
224                                   (when (or inner-lock-p
225                                             (setf got-it
226                                                   (get-spinlock spinlock)))
227                                     (funcall function))
228                                (when got-it
229                                  (release-spinlock spinlock))))))
230                     (declare (inline %call-with-system-spinlock))
231                     ,(ecase variant
232                       (:without-gcing
233                         `(without-gcing (%call-with-system-spinlock)))
234                       ((nil)
235                         `(without-interrupts (%call-with-system-spinlock))))))))
236     (def call-with-recursive-system-spinlock)
237     (def call-with-recursive-system-spinlock :without-gcing))
238
239   (defun call-with-spinlock (function spinlock)
240     (declare (function function))
241     (dx-let ((got-it nil))
242       (without-interrupts
243         (unwind-protect
244              (when (setf got-it (allow-with-interrupts
245                                  (get-spinlock spinlock)))
246                (with-local-interrupts (funcall function)))
247           (when got-it
248             (release-spinlock spinlock))))))
249
250   (defun call-with-mutex (function mutex value waitp)
251     (declare (function function))
252     (dx-let ((got-it nil))
253       (without-interrupts
254         (unwind-protect
255              (when (setq got-it (allow-with-interrupts
256                                  (get-mutex mutex value waitp)))
257                (with-local-interrupts (funcall function)))
258           (when got-it
259             (release-mutex mutex))))))
260
261   (defun call-with-recursive-lock (function mutex)
262     (declare (function function))
263     (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
264              (got-it nil))
265       (without-interrupts
266         (unwind-protect
267              (when (or inner-lock-p (setf got-it (allow-with-interrupts
268                                                   (get-mutex mutex))))
269                (with-local-interrupts (funcall function)))
270           (when got-it
271             (release-mutex mutex))))))
272
273   (defun call-with-recursive-spinlock (function spinlock)
274     (declare (function function))
275     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
276           (got-it nil))
277       (without-interrupts
278         (unwind-protect
279              (when (or inner-lock-p (setf got-it (allow-with-interrupts
280                                                   (get-spinlock spinlock))))
281                (with-local-interrupts (funcall function)))
282           (when got-it
283             (release-spinlock spinlock)))))))