src/code/thread.lisp

   1 (in-package "SB!THREAD")
   2
   3 (defvar *session-lock*)
   4
   5 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
   6   #!+sb-thread
   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
  11                     (sb!sys:int-sap
  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))))
  21       (unwind-protect
  22            (progn ,@body)
  23         (when (sb!sys:sap= (sb!sys:int-sap
  24                             (sb!kernel:get-lisp-obj-address
  25                              (mutex-value ,mutex)))
  26                            ,cfp)
  27           (release-mutex ,mutex)))))
  28   #!-sb-thread
  29   `(progn ,@body))
  30
  31 #!+sb-thread
  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 sb!unix:sigint #'sb!unix::sigint-handler)
  36   t)
  37 #!-sb-thread
  38 (defun get-foreground () t)
  39
  40 #!+sb-thread
  41 (defun release-foreground ()
  42   (sb!sys:enable-interrupt sb!unix:sigint :ignore)
  43   (release-mutex *session-lock*)
  44   t)
  45 #!-sb-thread
  46 (defun release-foreground () t)