[83fc8f]: src / code / thread.lisp Maximize Restore History

Download this file

thread.lisp    309 lines (266 with data), 12.1 kB

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