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 VALUE or
70 some suitable default value if NIL. If WAIT-P is non-NIL and the mutex
71 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)))))))