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!type thread-name ()
17 (def!struct (thread (:constructor %make-thread))
19 "Thread type. Do not rely on threads being structs as it may change
21 (name nil :type (or thread-name null))
22 (%alive-p nil :type boolean)
23 (os-thread nil :type (or integer null))
24 (interruptions nil :type list)
25 (result nil :type list)
27 (make-mutex :name "thread interruptions lock")
30 (make-mutex :name "thread result lock")
37 (name nil :type (or null thread-name))
38 (%owner nil :type (or null thread))
39 #!+(and sb-thread sb-futex)
40 (state 0 :type fixnum))
42 (defun mutex-value (mutex)
43 "Current owner of the mutex, NIL if the mutex is free. May return a
44 stale value, use MUTEX-OWNER instead."
47 (defun holding-mutex-p (mutex)
48 "Test whether the current thread is holding MUTEX."
49 ;; This is about the only use for which a stale value of owner is
51 (eq sb!thread:*current-thread* (mutex-%owner mutex)))
53 (defsetf mutex-value set-mutex-value)
55 (declaim (inline set-mutex-value))
56 (defun set-mutex-value (mutex value)
57 (declare (ignore mutex value))
58 (error "~S is no longer supported." '(setf mutex-value)))
60 (define-compiler-macro set-mutex-value (&whole form mutex value)
61 (declare (ignore mutex value))
62 (warn "~S is no longer supported, and will signal an error at runtime."
66 ;;; SPINLOCK no longer exists as a type -- provided for backwards compatibility.
70 (deprecation-warning :early "1.0.53.11" 'spinlock 'mutex)
73 (define-deprecated-function :early "1.0.53.11" make-spinlock make-mutex (&key name)
74 (make-mutex :name name))
76 (define-deprecated-function :early "1.0.53.11" spinlock-name mutex-name (lock)
79 (define-deprecated-function :early "1.0.53.11" (setf spinlock-name) (setf mutex-name) (name lock)
80 (setf (mutex-name lock) name))
82 (define-deprecated-function :early "1.0.53.11" spinlock-value mutex-owner (lock)
85 (define-deprecated-function :early "1.0.53.11" get-spinlock grab-mutex (lock)
88 (define-deprecated-function :early "1.0.53.11" release-spinlock release-mutex (lock)
91 (sb!xc:defmacro with-recursive-spinlock ((lock) &body body)
92 (deprecation-warning :early "1.0.53.11" 'with-recursive-spinlock 'with-recursive-lock)
93 `(with-recursive-lock (,lock)
96 (sb!xc:defmacro with-spinlock ((lock) &body body)
97 (deprecation-warning :early "1.0.53.11" 'with-recursive-spinlock 'with-mutex)
101 (sb!xc:defmacro without-thread-waiting-for ((&key already-without-interrupts) &body body)
102 (with-unique-names (thread prev)
103 (let ((without (if already-without-interrupts
105 'without-interrupts))
106 (with (if already-without-interrupts
108 'with-local-interrupts)))
109 `(let* ((,thread *current-thread*)
110 (,prev (thread-waiting-for ,thread)))
111 (flet ((exec () ,@body))
116 (setf (thread-waiting-for ,thread) nil)
118 (setf (thread-waiting-for ,thread) ,prev)))
121 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
124 "Acquire MUTEX for the dynamic scope of BODY, setting it to VALUE or
125 some suitable default value if NIL. If WAIT-P is non-NIL and the mutex
126 is in use, sleep until it is available"
127 `(dx-flet ((with-mutex-thunk () ,@body))
134 (sb!xc:defmacro with-system-mutex ((mutex
135 &key without-gcing allow-with-interrupts)
137 `(dx-flet ((with-system-mutex-thunk () ,@body))
138 (,(cond (without-gcing
139 'call-with-system-mutex/without-gcing)
140 (allow-with-interrupts
141 'call-with-system-mutex/allow-with-interrupts)
143 'call-with-system-mutex))
144 #'with-system-mutex-thunk
147 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
149 "Acquires MUTEX for the dynamic scope of BODY. Within that scope
150 further recursive lock attempts for the same mutex succeed. It is
151 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
152 provided the default value is used for the mutex."
153 `(dx-flet ((with-recursive-lock-thunk () ,@body))
154 (call-with-recursive-lock
155 #'with-recursive-lock-thunk
158 (sb!xc:defmacro with-recursive-system-lock ((lock
161 `(dx-flet ((with-recursive-system-lock-thunk () ,@body))
162 (,(cond (without-gcing
163 'call-with-recursive-system-lock/without-gcing)
165 'call-with-recursive-system-lock))
166 #'with-recursive-system-lock-thunk
169 (macrolet ((def (name &optional variant)
170 `(defun ,(if variant (symbolicate name "/" variant) name)
172 (declare (function function))
173 (flet ((%call-with-system-mutex ()
176 (when (setf got-it (get-mutex mutex))
179 (release-mutex mutex))))))
180 (declare (inline %call-with-system-mutex))
183 `(without-gcing (%call-with-system-mutex)))
184 (:allow-with-interrupts
186 (allow-with-interrupts (%call-with-system-mutex))))
188 `(without-interrupts (%call-with-system-mutex))))))))
189 (def call-with-system-mutex)
190 (def call-with-system-mutex :without-gcing)
191 (def call-with-system-mutex :allow-with-interrupts))
195 (defun call-with-mutex (function mutex value waitp)
196 (declare (ignore mutex value waitp)
200 (defun call-with-recursive-lock (function mutex)
201 (declare (ignore mutex) (function function))
204 (defun call-with-recursive-system-lock (function lock)
205 (declare (function function) (ignore lock))
209 (defun call-with-recursive-system-lock/without-gcing (function mutex)
210 (declare (function function) (ignore mutex))
212 (funcall function))))
215 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
216 ;;; closes over GOT-IT causes a value-cell to be allocated for it --
217 ;;; and we prefer that to go on the stack since it can.
219 (defun call-with-mutex (function mutex value waitp)
220 (declare (function function))
221 (dx-let ((got-it nil))
224 (when (setq got-it (allow-with-interrupts
225 (get-mutex mutex value waitp)))
226 (with-local-interrupts (funcall function)))
228 (release-mutex mutex))))))
230 (defun call-with-recursive-lock (function mutex)
231 (declare (function function))
232 (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
236 (when (or inner-lock-p (setf got-it (allow-with-interrupts
238 (with-local-interrupts (funcall function)))
240 (release-mutex mutex))))))
242 (macrolet ((def (name &optional variant)
243 `(defun ,(if variant (symbolicate name "/" variant) name)
245 (declare (function function))
246 (flet ((%call-with-recursive-system-lock ()
247 (dx-let ((inner-lock-p
248 (eq *current-thread* (mutex-owner lock)))
251 (when (or inner-lock-p
252 (setf got-it (grab-mutex lock)))
255 (release-mutex lock))))))
256 (declare (inline %call-with-recursive-system-lock))
259 `(without-gcing (%call-with-recursive-system-lock)))
261 `(without-interrupts (%call-with-recursive-system-lock))))))))
262 (def call-with-recursive-system-lock)
263 (def call-with-recursive-system-lock :without-gcing)))