1.0.21.25: LOAD-SHARED-OBJECT and logical pathnames
[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!struct mutex
15   #!+sb-doc
16   "Mutex type."
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)
22   (lutex (make-lutex)))
23
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."
27   (mutex-%owner mutex))
28
29 (defsetf mutex-value set-mutex-value)
30
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)))
35
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."
39         '(setf mutex-value))
40   form)
41
42 (def!struct spinlock
43   #!+sb-doc
44   "Spinlock type."
45   (name nil :type (or null simple-string))
46   (value nil))
47
48 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
49                             &body body)
50   #!+sb-doc
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))
55      (call-with-mutex
56       #'with-mutex-thunk
57       ,mutex
58       ,value
59       ,wait-p)))
60
61 (sb!xc:defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts) &body body)
62   `(dx-flet ((with-system-mutex-thunk () ,@body))
63      (,(cond (without-gcing
64                'call-with-system-mutex/without-gcing)
65              (allow-with-interrupts
66               'call-with-system-mutex/allow-with-interrupts)
67              (t
68               'call-with-system-mutex))
69        #'with-system-mutex-thunk
70        ,mutex)))
71
72 (sb!xc:defmacro with-system-spinlock ((spinlock &key) &body body)
73   `(dx-flet ((with-system-spinlock-thunk () ,@body))
74      (call-with-system-spinlock
75        #'with-system-spinlock-thunk
76        ,spinlock)))
77
78 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
79   #!+sb-doc
80   "Acquires MUTEX for the dynamic scope of BODY. Within that scope
81 further recursive lock attempts for the same mutex succeed. It is
82 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
83 provided the default value is used for the mutex."
84   `(dx-flet ((with-recursive-lock-thunk () ,@body))
85      (call-with-recursive-lock
86       #'with-recursive-lock-thunk
87       ,mutex)))
88
89 (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
90   `(dx-flet ((with-recursive-spinlock-thunk () ,@body))
91      (call-with-recursive-spinlock
92       #'with-recursive-spinlock-thunk
93       ,spinlock)))
94
95 (sb!xc:defmacro with-recursive-system-spinlock ((spinlock
96                                                  &key without-gcing)
97                                                 &body body)
98   `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body))
99      (,(cond (without-gcing
100                'call-with-recursive-system-spinlock/without-gcing)
101              (t
102               'call-with-recursive-system-spinlock))
103        #'with-recursive-system-spinlock-thunk
104        ,spinlock)))
105
106 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
107   `(dx-flet ((with-spinlock-thunk () ,@body))
108      (call-with-spinlock
109       #'with-spinlock-thunk
110       ,spinlock)))
111
112 ;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not
113 ;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented.
114 ;;; However, there would be a (possibly slight) performance hit in
115 ;;; using them.
116 #!-sb-thread
117 (progn
118   (macrolet ((def (name &optional variant)
119                `(defun ,(if variant (symbolicate name "/" variant) name) (function lock)
120                   (declare (ignore lock) (function function))
121                   ,(ecase variant
122                     (:without-gcing
123                       `(without-gcing (funcall function)))
124                     (:allow-with-interrupts
125                       `(without-interrupts (allow-with-interrupts (funcall function))))
126                     ((nil)
127                       `(without-interrupts (funcall function)))))))
128     (def call-with-system-mutex)
129     (def call-with-system-mutex :without-gcing)
130     (def call-with-system-mutex :allow-with-interrupts)
131     (def call-with-system-spinlock)
132     (def call-with-recursive-system-spinlock)
133     (def call-with-recursive-system-spinlock :without-gcing))
134
135   (defun call-with-mutex (function mutex value waitp)
136     (declare (ignore mutex value waitp)
137              (function function))
138     (funcall function))
139
140   (defun call-with-recursive-lock (function mutex)
141     (declare (ignore mutex) (function function))
142     (funcall function))
143
144   (defun call-with-spinlock (function spinlock)
145     (declare (ignore spinlock) (function function))
146     (funcall function))
147
148   (defun call-with-recursive-spinlock (function spinlock)
149     (declare (ignore spinlock) (function function))
150     (funcall function)))
151
152 #!+sb-thread
153 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
154 ;;; closes over GOT-IT causes a value-cell to be allocated for it --
155 ;;; and we prefer that to go on the stack since it can.
156 (progn
157   (macrolet ((def (name &optional variant)
158                `(defun ,(if variant (symbolicate name "/" variant) name) (function mutex)
159                   (declare (function function))
160                   (flet ((%call-with-system-mutex ()
161                            (dx-let (got-it)
162                              (unwind-protect
163                                   (when (setf got-it (get-mutex mutex))
164                                     (funcall function))
165                                (when got-it
166                                  (release-mutex mutex))))))
167                     (declare (inline %call-with-system-mutex))
168                     ,(ecase variant
169                       (:without-gcing
170                         `(without-gcing (%call-with-system-mutex)))
171                       (:allow-with-interrupts
172                         `(without-interrupts (allow-with-interrupts (%call-with-system-mutex))))
173                       ((nil)
174                         `(without-interrupts (%call-with-system-mutex))))))))
175     (def call-with-system-mutex)
176     (def call-with-system-mutex :without-gcing)
177     (def call-with-system-mutex :allow-with-interrupts))
178
179   (defun call-with-system-spinlock (function spinlock)
180     (declare (function function))
181     (without-interrupts
182       (dx-let (got-it)
183         (unwind-protect
184              (when (setf got-it (get-spinlock spinlock))
185                (funcall function))
186           (when got-it
187             (release-spinlock spinlock))))))
188
189   (macrolet ((def (name &optional variant)
190                `(defun ,(if variant (symbolicate name "/" variant) name) (function spinlock)
191                   (declare (function function))
192                   (flet ((%call-with-system-spinlock ()
193                            (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value spinlock)))
194                                     (got-it nil))
195                              (unwind-protect
196                                   (when (or inner-lock-p (setf got-it (get-spinlock spinlock)))
197                                     (funcall function))
198                                (when got-it
199                                  (release-spinlock spinlock))))))
200                     (declare (inline %call-with-system-spinlock))
201                     ,(ecase variant
202                       (:without-gcing
203                         `(without-gcing (%call-with-system-spinlock)))
204                       ((nil)
205                         `(without-interrupts (%call-with-system-spinlock))))))))
206     (def call-with-recursive-system-spinlock)
207     (def call-with-recursive-system-spinlock :without-gcing))
208
209   (defun call-with-spinlock (function spinlock)
210     (declare (function function))
211     (dx-let ((got-it nil))
212       (without-interrupts
213         (unwind-protect
214              (when (setf got-it (allow-with-interrupts
215                                  (get-spinlock spinlock)))
216                (with-local-interrupts (funcall function)))
217           (when got-it
218             (release-spinlock spinlock))))))
219
220   (defun call-with-mutex (function mutex value waitp)
221     (declare (function function))
222     (dx-let ((got-it nil))
223       (without-interrupts
224         (unwind-protect
225              (when (setq got-it (allow-with-interrupts
226                                  (get-mutex mutex value waitp)))
227                (with-local-interrupts (funcall function)))
228           (when got-it
229             (release-mutex mutex))))))
230
231   (defun call-with-recursive-lock (function mutex)
232     (declare (function function))
233     (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
234              (got-it nil))
235       (without-interrupts
236         (unwind-protect
237              (when (or inner-lock-p (setf got-it (allow-with-interrupts
238                                                   (get-mutex mutex))))
239                (with-local-interrupts (funcall function)))
240           (when got-it
241             (release-mutex mutex))))))
242
243
244
245   (defun call-with-recursive-spinlock (function spinlock)
246     (declare (function function))
247     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
248           (got-it nil))
249       (without-interrupts
250         (unwind-protect
251              (when (or inner-lock-p (setf got-it (allow-with-interrupts
252                                                   (get-spinlock spinlock))))
253                (with-local-interrupts (funcall function)))
254           (when got-it
255             (release-spinlock spinlock)))))))