1 ;;;; support for threads needed at cross-compile time
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!THREAD")
14 (sb!xc
:defmacro with-mutex
((mutex &key value
(wait-p t
)) &body body
)
16 "Acquire MUTEX for the dynamic scope of BODY, setting it to
17 NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL
18 and the mutex is in use, sleep until it is available"
19 #!-sb-thread
(declare (ignore mutex value wait-p
))
21 (with-unique-names (got)
22 `(let ((,got
(get-mutex ,mutex
,value
,wait-p
)))
26 (release-mutex ,mutex
)))))
27 ;; KLUDGE: this separate expansion for (NOT SB-THREAD) is not
28 ;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented.
29 ;; However, there would be a (possibly slight) performance hit in
34 (sb!xc
:defmacro with-recursive-lock
((mutex) &body body
)
36 "Acquires MUTEX for the dynamic scope of BODY. Within that scope
37 further recursive lock attempts for the same mutex succeed. However,
38 it is an error to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same
40 #!-sb-thread
(declare (ignore mutex
))
42 (with-unique-names (cfp inner-lock
)
43 `(let ((,cfp
(sb!kernel
:current-fp
))
45 (and (mutex-value ,mutex
)
46 (sb!vm
:control-stack-pointer-valid-p
48 (sb!kernel
:get-lisp-obj-address
(mutex-value ,mutex
)))))))
50 ;; this punning with MAKE-LISP-OBJ depends for its safety on
51 ;; the frame pointer being a lispobj-aligned integer. While
52 ;; it is, then MAKE-LISP-OBJ will always return a FIXNUM, so
53 ;; we're safe to do that. Should this ever change, this
54 ;; MAKE-LISP-OBJ could return something that looks like a
55 ;; pointer, but pointing into neverneverland, which will
56 ;; confuse GC completely. -- CSR, 2003-06-03
57 (get-mutex ,mutex
(sb!kernel
:make-lisp-obj
(sb!sys
:sap-int
,cfp
))))
61 (release-mutex ,mutex
)))))