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