1 ;;;; support for threads needed at cross-compile time
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!THREAD")
14 (def!struct
(thread (:constructor %make-thread
))
16 "Thread type. Do not rely on threads being structs as it may change
22 (interruptions-lock (make-mutex :name
"thread interruptions lock"))
24 (result-lock (make-mutex :name
"thread result lock")))
29 (name nil
:type
(or null simple-string
))
30 (%owner nil
:type
(or null thread
))
31 #!+(and (not sb-lutex
) sb-thread
)
32 (state 0 :type fixnum
)
33 #!+(and sb-lutex sb-thread
)
36 (defun mutex-value (mutex)
37 "Current owner of the mutex, NIL if the mutex is free. May return a
38 stale value, use MUTEX-OWNER instead."
41 (defun holding-mutex-p (mutex)
42 "Test whether the current thread is holding MUTEX."
43 ;; This is about the only use for which a stale value of owner is
45 (eq sb
!thread
:*current-thread
* (mutex-%owner mutex
)))
47 (defsetf mutex-value set-mutex-value
)
49 (declaim (inline set-mutex-value
))
50 (defun set-mutex-value (mutex value
)
51 (declare (ignore mutex value
))
52 (error "~S is no longer supported." '(setf mutex-value
)))
54 (define-compiler-macro set-mutex-value
(&whole form mutex value
)
55 (declare (ignore mutex value
))
56 (warn "~S is no longer supported, and will signal an error at runtime."
63 (name nil
:type
(or null simple-string
))
66 (sb!xc
:defmacro with-mutex
((mutex &key
(value '*current-thread
*) (wait-p t
))
69 "Acquire MUTEX for the dynamic scope of BODY, setting it to
70 NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL
71 and the mutex is in use, sleep until it is available"
72 `(dx-flet ((with-mutex-thunk () ,@body
))
79 (sb!xc
:defmacro with-system-mutex
((mutex
80 &key without-gcing allow-with-interrupts
)
82 `(dx-flet ((with-system-mutex-thunk () ,@body
))
83 (,(cond (without-gcing
84 'call-with-system-mutex
/without-gcing
)
85 (allow-with-interrupts
86 'call-with-system-mutex
/allow-with-interrupts
)
88 'call-with-system-mutex
))
89 #'with-system-mutex-thunk
92 (sb!xc
:defmacro with-system-spinlock
((spinlock &key
) &body body
)
93 `(dx-flet ((with-system-spinlock-thunk () ,@body
))
94 (call-with-system-spinlock
95 #'with-system-spinlock-thunk
98 (sb!xc
:defmacro with-recursive-lock
((mutex) &body body
)
100 "Acquires MUTEX for the dynamic scope of BODY. Within that scope
101 further recursive lock attempts for the same mutex succeed. It is
102 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
103 provided the default value is used for the mutex."
104 `(dx-flet ((with-recursive-lock-thunk () ,@body
))
105 (call-with-recursive-lock
106 #'with-recursive-lock-thunk
109 (sb!xc
:defmacro with-recursive-spinlock
((spinlock) &body body
)
110 `(dx-flet ((with-recursive-spinlock-thunk () ,@body
))
111 (call-with-recursive-spinlock
112 #'with-recursive-spinlock-thunk
115 (sb!xc
:defmacro with-recursive-system-spinlock
((spinlock
118 `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body
))
119 (,(cond (without-gcing
120 'call-with-recursive-system-spinlock
/without-gcing
)
122 'call-with-recursive-system-spinlock
))
123 #'with-recursive-system-spinlock-thunk
126 (sb!xc
:defmacro with-spinlock
((spinlock) &body body
)
127 `(dx-flet ((with-spinlock-thunk () ,@body
))
129 #'with-spinlock-thunk
132 (macrolet ((def (name &optional variant
)
133 `(defun ,(if variant
(symbolicate name
"/" variant
) name
)
135 (declare (function function
))
136 (flet ((%call-with-system-mutex
()
139 (when (setf got-it
(get-mutex mutex
))
142 (release-mutex mutex
))))))
143 (declare (inline %call-with-system-mutex
))
146 `(without-gcing (%call-with-system-mutex
)))
147 (:allow-with-interrupts
149 (allow-with-interrupts (%call-with-system-mutex
))))
151 `(without-interrupts (%call-with-system-mutex
))))))))
152 (def call-with-system-mutex
)
153 (def call-with-system-mutex
:without-gcing
)
154 (def call-with-system-mutex
:allow-with-interrupts
))
158 (macrolet ((def (name &optional variant
)
159 `(defun ,(if variant
(symbolicate name
"/" variant
) name
)
161 (declare (ignore lock
) (function function
))
164 `(without-gcing (funcall function
)))
165 (:allow-with-interrupts
167 (allow-with-interrupts (funcall function
))))
169 `(without-interrupts (funcall function
)))))))
170 (def call-with-system-spinlock
)
171 (def call-with-recursive-system-spinlock
)
172 (def call-with-recursive-system-spinlock
:without-gcing
))
174 (defun call-with-mutex (function mutex value waitp
)
175 (declare (ignore mutex value waitp
)
179 (defun call-with-recursive-lock (function mutex
)
180 (declare (ignore mutex
) (function function
))
183 (defun call-with-spinlock (function spinlock
)
184 (declare (ignore spinlock
) (function function
))
187 (defun call-with-recursive-spinlock (function spinlock
)
188 (declare (ignore spinlock
) (function function
))
192 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
193 ;;; closes over GOT-IT causes a value-cell to be allocated for it --
194 ;;; and we prefer that to go on the stack since it can.
196 (defun call-with-system-spinlock (function spinlock
)
197 (declare (function function
))
201 (when (setf got-it
(get-spinlock spinlock
))
204 (release-spinlock spinlock
))))))
206 (macrolet ((def (name &optional variant
)
207 `(defun ,(if variant
(symbolicate name
"/" variant
) name
)
209 (declare (function function
))
210 (flet ((%call-with-system-spinlock
()
211 (dx-let ((inner-lock-p
213 (spinlock-value spinlock
)))
216 (when (or inner-lock-p
218 (get-spinlock spinlock
)))
221 (release-spinlock spinlock
))))))
222 (declare (inline %call-with-system-spinlock
))
225 `(without-gcing (%call-with-system-spinlock
)))
227 `(without-interrupts (%call-with-system-spinlock
))))))))
228 (def call-with-recursive-system-spinlock
)
229 (def call-with-recursive-system-spinlock
:without-gcing
))
231 (defun call-with-spinlock (function spinlock
)
232 (declare (function function
))
233 (dx-let ((got-it nil
))
236 (when (setf got-it
(allow-with-interrupts
237 (get-spinlock spinlock
)))
238 (with-local-interrupts (funcall function
)))
240 (release-spinlock spinlock
))))))
242 (defun call-with-mutex (function mutex value waitp
)
243 (declare (function function
))
244 (dx-let ((got-it nil
))
247 (when (setq got-it
(allow-with-interrupts
248 (get-mutex mutex value waitp
)))
249 (with-local-interrupts (funcall function
)))
251 (release-mutex mutex
))))))
253 (defun call-with-recursive-lock (function mutex
)
254 (declare (function function
))
255 (dx-let ((inner-lock-p (eq (mutex-%owner mutex
) *current-thread
*))
259 (when (or inner-lock-p
(setf got-it
(allow-with-interrupts
261 (with-local-interrupts (funcall function
)))
263 (release-mutex mutex
))))))
265 (defun call-with-recursive-spinlock (function spinlock
)
266 (declare (function function
))
267 (dx-let ((inner-lock-p (eq (spinlock-value spinlock
) *current-thread
*))
271 (when (or inner-lock-p
(setf got-it
(allow-with-interrupts
272 (get-spinlock spinlock
))))
273 (with-local-interrupts (funcall function
)))
275 (release-spinlock spinlock
)))))))