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)))))