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