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")
17 (name nil
:type
(or null simple-string
))
18 (%owner nil
:type
(or null thread
))
19 #!+(and (not sb-lutex
) sb-thread
)
20 (state 0 :type fixnum
)
21 #!+(and sb-lutex sb-thread
)
24 ;;; FIXME: We probably want to rename the accessor MUTEX-OWNER.
25 (defun mutex-value (mutex)
26 "Current owner of the mutex, NIL if the mutex is free."
29 (defsetf mutex-value set-mutex-value
)
31 (declaim (inline set-mutex-value
))
32 (defun set-mutex-value (mutex value
)
33 (declare (ignore mutex value
))
34 (error "~S is no longer supported." '(setf mutex-value
)))
36 (define-compiler-macro set-mutex-value
(&whole form mutex value
)
37 (declare (ignore mutex value
))
38 (warn "~S is no longer supported, and will signal an error at runtime."
45 (name nil
:type
(or null simple-string
))
48 (sb!xc
:defmacro with-mutex
((mutex &key
(value '*current-thread
*) (wait-p t
))
51 "Acquire MUTEX for the dynamic scope of BODY, setting it to
52 NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL
53 and the mutex is in use, sleep until it is available"
54 `(dx-flet ((with-mutex-thunk () ,@body
))
61 (sb!xc
:defmacro with-system-mutex
((mutex &key without-gcing
) &body body
)
62 `(dx-flet ((with-system-mutex-thunk () ,@body
))
63 (call-with-system-mutex
64 #'with-system-mutex-thunk
68 (sb!xc
:defmacro with-recursive-lock
((mutex) &body body
)
70 "Acquires MUTEX for the dynamic scope of BODY. Within that scope
71 further recursive lock attempts for the same mutex succeed. It is
72 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
73 provided the default value is used for the mutex."
74 `(dx-flet ((with-recursive-lock-thunk () ,@body
))
75 (call-with-recursive-lock
76 #'with-recursive-lock-thunk
79 (sb!xc
:defmacro with-recursive-spinlock
((spinlock) &body body
)
80 `(dx-flet ((with-recursive-spinlock-thunk () ,@body
))
81 (call-with-recursive-spinlock
82 #'with-recursive-spinlock-thunk
85 (sb!xc
:defmacro with-recursive-system-spinlock
((spinlock &key without-gcing
)
87 `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body
))
88 (call-with-recursive-system-spinlock
89 #'with-recursive-system-spinlock-thunk
93 (sb!xc
:defmacro with-spinlock
((spinlock) &body body
)
94 `(dx-flet ((with-spinlock-thunk () ,@body
))
99 ;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not
100 ;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented.
101 ;;; However, there would be a (possibly slight) performance hit in
105 (defun call-with-system-mutex (function mutex
&optional without-gcing-p
)
106 (declare (ignore mutex
)
112 (allow-with-interrupts (funcall function
)))))
114 (defun call-with-system-spinlock (function spinlock
&optional without-gcing-p
)
115 (declare (ignore spinlock
)
121 (allow-with-interrupts (funcall function
)))))
123 (defun call-with-recursive-system-spinlock (function lock
124 &optional without-gcing-p
)
125 (declare (ignore lock
)
131 (allow-with-interrupts (funcall function
)))))
133 (defun call-with-mutex (function mutex value waitp
)
134 (declare (ignore mutex value waitp
)
138 (defun call-with-recursive-lock (function mutex
)
139 (declare (ignore mutex
) (function function
))
142 (defun call-with-spinlock (function spinlock
)
143 (declare (ignore spinlock
) (function function
))
146 (defun call-with-recursive-spinlock (function spinlock
)
147 (declare (ignore spinlock
) (function function
))
151 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
152 ;;; closes over GOT-IT causes a value-cell to be allocated for it -- and
153 ;;; we prefer that to go on the stack since it can.
155 (defun call-with-system-mutex (function mutex
&optional without-gcing-p
)
156 (declare (function function
))
157 (flet ((%call-with-system-mutex
()
160 (when (setf got-it
(get-mutex mutex
))
163 (release-mutex mutex
))))))
166 (%call-with-system-mutex
))
168 (allow-with-interrupts (%call-with-system-mutex
))))))
170 (defun call-with-system-spinlock (function spinlock
&optional without-gcing-p
)
171 (declare (function function
))
172 (flet ((%call-with-system-spinlock
()
175 (when (setf got-it
(get-spinlock spinlock
))
178 (release-spinlock spinlock
))))))
181 (%call-with-system-spinlock
))
183 (allow-with-interrupts (%call-with-system-spinlock
))))))
185 (defun call-with-recursive-system-spinlock (function lock
186 &optional without-gcing-p
)
187 (declare (function function
))
188 (flet ((%call-with-system-spinlock
()
189 (dx-let ((inner-lock-p (eq *current-thread
* (spinlock-value lock
)))
192 (when (or inner-lock-p
(setf got-it
(get-spinlock lock
)))
195 (release-spinlock lock
))))))
198 (%call-with-system-spinlock
))
200 (allow-with-interrupts (%call-with-system-spinlock
))))))
202 (defun call-with-spinlock (function spinlock
)
203 (declare (function function
))
204 (dx-let ((got-it nil
))
207 (when (setf got-it
(allow-with-interrupts
208 (get-spinlock spinlock
)))
209 (with-local-interrupts (funcall function
)))
211 (release-spinlock spinlock
))))))
213 (defun call-with-mutex (function mutex value waitp
)
214 (declare (function function
))
215 (dx-let ((got-it nil
))
218 (when (setq got-it
(allow-with-interrupts
219 (get-mutex mutex value waitp
)))
220 (with-local-interrupts (funcall function
)))
222 (release-mutex mutex
))))))
224 (defun call-with-recursive-lock (function mutex
)
225 (declare (function function
))
226 (dx-let ((inner-lock-p (eq (mutex-%owner mutex
) *current-thread
*))
230 (when (or inner-lock-p
(setf got-it
(allow-with-interrupts
232 (with-local-interrupts (funcall function
)))
234 (release-mutex mutex
))))))
238 (defun call-with-recursive-spinlock (function spinlock
)
239 (declare (function function
))
240 (dx-let ((inner-lock-p (eq (spinlock-value spinlock
) *current-thread
*))
244 (when (or inner-lock-p
(setf got-it
(allow-with-interrupts
245 (get-spinlock spinlock
))))
246 (with-local-interrupts (funcall function
)))
248 (release-spinlock spinlock
)))))))