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 (sb!xc:defmacro with-mutex ((mutex &key value (wait-p t)) &body body)
  15   #!+sb-doc
  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))
  20   #!+sb-thread
  21   (with-unique-names (got)
  22     `(let ((,got (get-mutex ,mutex ,value ,wait-p)))
  23       (when ,got
  24         (unwind-protect
  25              (locally ,@body)
  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
  30   ;; using them.
  31   #!-sb-thread
  32   `(locally ,@body))
  33
  34 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
  35   #!+sb-doc
  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
  39 mutex."
  40   #!-sb-thread (declare (ignore mutex))
  41   #!+sb-thread
  42   (with-unique-names (cfp inner-lock)
  43     `(let ((,cfp (sb!kernel:current-fp))
  44            (,inner-lock
  45             (and (mutex-value ,mutex)
  46                  (sb!vm:control-stack-pointer-valid-p
  47                   (sb!sys:int-sap
  48                    (sb!kernel:get-lisp-obj-address (mutex-value ,mutex)))))))
  49       (unless ,inner-lock
  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))))
  58       (unwind-protect
  59            (locally ,@body)
  60         (unless ,inner-lock
  61           (release-mutex ,mutex)))))
  62   #!-sb-thread
  63   `(locally ,@body))