1 (in-package "SB!THREAD")
3 (defvar *session-lock*)
5 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
7 (with-unique-names (cfp)
8 `(let ((,cfp (sb!kernel:current-fp)))
9 (unless (and (mutex-value ,mutex)
10 (sb!vm:control-stack-pointer-valid-p
12 (sb!kernel:get-lisp-obj-address (mutex-value ,mutex)))))
13 ;; this punning with MAKE-LISP-OBJ depends for its safety on
14 ;; the frame pointer being a lispobj-aligned integer. While
15 ;; it is, then MAKE-LISP-OBJ will always return a FIXNUM, so
16 ;; we're safe to do that. Should this ever change, this
17 ;; MAKE-LISP-OBJ could return something that looks like a
18 ;; pointer, but pointing into neverneverland, which will
19 ;; confuse GC completely. -- CSR, 2003-06-03
20 (get-mutex ,mutex (sb!kernel:make-lisp-obj (sb!sys:sap-int ,cfp))))
23 (when (sb!sys:sap= (sb!sys:int-sap
24 (sb!kernel:get-lisp-obj-address
25 (mutex-value ,mutex)))
27 (release-mutex ,mutex)))))
32 (defun get-foreground ()
33 (when (not (eql (mutex-value *session-lock*) (current-thread-id)))
34 (get-mutex *session-lock*))
35 (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
38 (defun get-foreground () t)
41 (defun release-foreground ()
42 (sb!sys:enable-interrupt :sigint :ignore)
43 (release-mutex *session-lock*)
46 (defun release-foreground () t)