1.0.41.42: ppc: Documentation and NEWS updates for threading.
[sbcl.git] / src / code / thread.lisp
1 ;;;; support for threads needed at cross-compile time
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!THREAD")
13
14 (def!type thread-name ()
15   'simple-string)
16
17 (def!struct (thread (:constructor %make-thread))
18   #!+sb-doc
19   "Thread type. Do not rely on threads being structs as it may change
20 in future versions."
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)
26   (interruptions-lock
27    (make-mutex :name "thread interruptions lock")
28    :type mutex)
29   (result-lock
30    (make-mutex :name "thread result lock")
31    :type mutex))
32
33 (def!struct mutex
34   #!+sb-doc
35   "Mutex type."
36   (name   nil :type (or null thread-name))
37   (%owner nil :type (or null thread))
38   #!+(and (not sb-lutex) sb-thread)
39   (state    0 :type fixnum)
40   #!+(and sb-lutex sb-thread)
41   (lutex (make-lutex)))
42
43 (defun mutex-value (mutex)
44   "Current owner of the mutex, NIL if the mutex is free. May return a
45 stale value, use MUTEX-OWNER instead."
46   (mutex-%owner mutex))
47
48 (defun holding-mutex-p (mutex)
49   "Test whether the current thread is holding MUTEX."
50   ;; This is about the only use for which a stale value of owner is
51   ;; sufficient.
52   (eq sb!thread:*current-thread* (mutex-%owner mutex)))
53
54 (defsetf mutex-value set-mutex-value)
55
56 (declaim (inline set-mutex-value))
57 (defun set-mutex-value (mutex value)
58   (declare (ignore mutex value))
59   (error "~S is no longer supported." '(setf mutex-value)))
60
61 (define-compiler-macro set-mutex-value (&whole form mutex value)
62   (declare (ignore mutex value))
63   (warn "~S is no longer supported, and will signal an error at runtime."
64         '(setf mutex-value))
65   form)
66
67 (def!struct spinlock
68   #!+sb-doc
69   "Spinlock type."
70   (name  nil :type (or null thread-name))
71   (value nil))
72
73 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
74                             &body body)
75   #!+sb-doc
76   "Acquire MUTEX for the dynamic scope of BODY, setting it to VALUE or
77 some suitable default value if NIL.  If WAIT-P is non-NIL and the mutex
78 is in use, sleep until it is available"
79   `(dx-flet ((with-mutex-thunk () ,@body))
80      (call-with-mutex
81       #'with-mutex-thunk
82       ,mutex
83       ,value
84       ,wait-p)))
85
86 (sb!xc:defmacro with-system-mutex ((mutex
87                                     &key without-gcing allow-with-interrupts)
88                                    &body body)
89   `(dx-flet ((with-system-mutex-thunk () ,@body))
90      (,(cond (without-gcing
91                'call-with-system-mutex/without-gcing)
92              (allow-with-interrupts
93               'call-with-system-mutex/allow-with-interrupts)
94              (t
95               'call-with-system-mutex))
96        #'with-system-mutex-thunk
97        ,mutex)))
98
99 (sb!xc:defmacro with-system-spinlock ((spinlock &key) &body body)
100   `(dx-flet ((with-system-spinlock-thunk () ,@body))
101      (call-with-system-spinlock
102        #'with-system-spinlock-thunk
103        ,spinlock)))
104
105 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
106   #!+sb-doc
107   "Acquires MUTEX for the dynamic scope of BODY. Within that scope
108 further recursive lock attempts for the same mutex succeed. It is
109 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
110 provided the default value is used for the mutex."
111   `(dx-flet ((with-recursive-lock-thunk () ,@body))
112      (call-with-recursive-lock
113       #'with-recursive-lock-thunk
114       ,mutex)))
115
116 (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
117   `(dx-flet ((with-recursive-spinlock-thunk () ,@body))
118      (call-with-recursive-spinlock
119       #'with-recursive-spinlock-thunk
120       ,spinlock)))
121
122 (sb!xc:defmacro with-recursive-system-spinlock ((spinlock
123                                                  &key without-gcing)
124                                                 &body body)
125   `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body))
126      (,(cond (without-gcing
127                'call-with-recursive-system-spinlock/without-gcing)
128              (t
129               'call-with-recursive-system-spinlock))
130        #'with-recursive-system-spinlock-thunk
131        ,spinlock)))
132
133 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
134   `(dx-flet ((with-spinlock-thunk () ,@body))
135      (call-with-spinlock
136       #'with-spinlock-thunk
137       ,spinlock)))
138
139 (macrolet ((def (name &optional variant)
140              `(defun ,(if variant (symbolicate name "/" variant) name)
141                   (function mutex)
142                 (declare (function function))
143                 (flet ((%call-with-system-mutex ()
144                          (dx-let (got-it)
145                            (unwind-protect
146                                 (when (setf got-it (get-mutex mutex))
147                                   (funcall function))
148                              (when got-it
149                                (release-mutex mutex))))))
150                   (declare (inline %call-with-system-mutex))
151                   ,(ecase variant
152                      (:without-gcing
153                        `(without-gcing (%call-with-system-mutex)))
154                      (:allow-with-interrupts
155                        `(without-interrupts
156                           (allow-with-interrupts (%call-with-system-mutex))))
157                      ((nil)
158                       `(without-interrupts (%call-with-system-mutex))))))))
159   (def call-with-system-mutex)
160   (def call-with-system-mutex :without-gcing)
161   (def call-with-system-mutex :allow-with-interrupts))
162
163 #!-sb-thread
164 (progn
165   (macrolet ((def (name &optional variant)
166                `(defun ,(if variant (symbolicate name "/" variant) name)
167                     (function lock)
168                   (declare (ignore lock) (function function))
169                   ,(ecase variant
170                     (:without-gcing
171                       `(without-gcing (funcall function)))
172                     (:allow-with-interrupts
173                       `(without-interrupts
174                          (allow-with-interrupts (funcall function))))
175                     ((nil)
176                       `(without-interrupts (funcall function)))))))
177     (def call-with-system-spinlock)
178     (def call-with-recursive-system-spinlock)
179     (def call-with-recursive-system-spinlock :without-gcing))
180
181   (defun call-with-mutex (function mutex value waitp)
182     (declare (ignore mutex value waitp)
183              (function function))
184     (funcall function))
185
186   (defun call-with-recursive-lock (function mutex)
187     (declare (ignore mutex) (function function))
188     (funcall function))
189
190   (defun call-with-spinlock (function spinlock)
191     (declare (ignore spinlock) (function function))
192     (funcall function))
193
194   (defun call-with-recursive-spinlock (function spinlock)
195     (declare (ignore spinlock) (function function))
196     (funcall function)))
197
198 #!+sb-thread
199 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
200 ;;; closes over GOT-IT causes a value-cell to be allocated for it --
201 ;;; and we prefer that to go on the stack since it can.
202 (progn
203   (defun call-with-system-spinlock (function spinlock)
204     (declare (function function))
205     (without-interrupts
206       (dx-let (got-it)
207         (unwind-protect
208              (when (setf got-it (get-spinlock spinlock))
209                (funcall function))
210           (when got-it
211             (release-spinlock spinlock))))))
212
213   (macrolet ((def (name &optional variant)
214                `(defun ,(if variant (symbolicate name "/" variant) name)
215                     (function spinlock)
216                   (declare (function function))
217                   (flet ((%call-with-system-spinlock ()
218                            (dx-let ((inner-lock-p
219                                      (eq *current-thread*
220                                          (spinlock-value spinlock)))
221                                     (got-it nil))
222                              (unwind-protect
223                                   (when (or inner-lock-p
224                                             (setf got-it
225                                                   (get-spinlock spinlock)))
226                                     (funcall function))
227                                (when got-it
228                                  (release-spinlock spinlock))))))
229                     (declare (inline %call-with-system-spinlock))
230                     ,(ecase variant
231                       (:without-gcing
232                         `(without-gcing (%call-with-system-spinlock)))
233                       ((nil)
234                         `(without-interrupts (%call-with-system-spinlock))))))))
235     (def call-with-recursive-system-spinlock)
236     (def call-with-recursive-system-spinlock :without-gcing))
237
238   (defun call-with-spinlock (function spinlock)
239     (declare (function function))
240     (dx-let ((got-it nil))
241       (without-interrupts
242         (unwind-protect
243              (when (setf got-it (allow-with-interrupts
244                                  (get-spinlock spinlock)))
245                (with-local-interrupts (funcall function)))
246           (when got-it
247             (release-spinlock spinlock))))))
248
249   (defun call-with-mutex (function mutex value waitp)
250     (declare (function function))
251     (dx-let ((got-it nil))
252       (without-interrupts
253         (unwind-protect
254              (when (setq got-it (allow-with-interrupts
255                                  (get-mutex mutex value waitp)))
256                (with-local-interrupts (funcall function)))
257           (when got-it
258             (release-mutex mutex))))))
259
260   (defun call-with-recursive-lock (function mutex)
261     (declare (function function))
262     (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
263              (got-it nil))
264       (without-interrupts
265         (unwind-protect
266              (when (or inner-lock-p (setf got-it (allow-with-interrupts
267                                                   (get-mutex mutex))))
268                (with-local-interrupts (funcall function)))
269           (when got-it
270             (release-mutex mutex))))))
271
272   (defun call-with-recursive-spinlock (function spinlock)
273     (declare (function function))
274     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
275           (got-it nil))
276       (without-interrupts
277         (unwind-protect
278              (when (or inner-lock-p (setf got-it (allow-with-interrupts
279                                                   (get-spinlock spinlock))))
280                (with-local-interrupts (funcall function)))
281           (when got-it
282             (release-spinlock spinlock)))))))