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 (def!struct mutex
  15   #!+sb-doc
  16   "Mutex type."
  17   (name nil :type (or null simple-string))
  18   (value nil)
  19   #!+(and sb-lutex sb-thread)
  20   (lutex (make-lutex)))
  21
  22 (def!struct spinlock
  23   #!+sb-doc
  24   "Spinlock type."
  25   (name nil :type (or null simple-string))
  26   (value nil))
  27
  28 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
  29                             &body body)
  30   #!+sb-doc
  31   "Acquire MUTEX for the dynamic scope of BODY, setting it to
  32 NEW-VALUE or some suitable default value if NIL.  If WAIT-P is non-NIL
  33 and the mutex is in use, sleep until it is available"
  34   `(call-with-mutex
  35     (lambda () ,@body)
  36     ,mutex
  37     ,value
  38     ,wait-p))
  39
  40 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
  41   #!+sb-doc
  42   "Acquires MUTEX for the dynamic scope of BODY. Within that scope
  43 further recursive lock attempts for the same mutex succeed. It is
  44 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
  45 provided the default value is used for the mutex."
  46   `(call-with-recursive-lock
  47     (lambda () ,@body)
  48     ,mutex))
  49
  50 (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
  51   `(call-with-recursive-spinlock
  52     (lambda () ,@body)
  53     ,spinlock))
  54
  55 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
  56   `(call-with-spinlock
  57     (lambda () ,@body)
  58     ,spinlock))
  59
  60 ;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not
  61 ;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented.
  62 ;;; However, there would be a (possibly slight) performance hit in
  63 ;;; using them.
  64 #!-sb-thread
  65 (progn
  66   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
  67     (declare (ignore mutex)
  68              (function function))
  69     (if without-gcing-p
  70         (without-gcing
  71           (funcall function))
  72         (without-interrupts
  73           (funcall function))))
  74
  75   (defun call-with-system-spinlock (function lock &optional without-gcing-p)
  76     (declare (ignore lock)
  77              (function function))
  78     (if without-gcing-p
  79         (without-gcing
  80           (funcall function))
  81         (without-interrupts
  82           (funcall function))))
  83
  84   (defun call-with-mutex (function mutex value waitp)
  85     (declare (ignore mutex value waitp)
  86              (function function))
  87     (funcall function))
  88
  89   (defun call-with-recursive-lock (function mutex)
  90     (declare (ignore mutex) (function function))
  91     (funcall function))
  92
  93   (defun call-with-spinlock (function spinlock)
  94     (declare (ignore spinlock) (function function))
  95     (funcall function))
  96
  97   (defun call-with-recursive-spinlock (function spinlock)
  98     (declare (ignore spinlock) (function function))
  99     (funcall function)))
 100
 101 #!+sb-thread
 102 (progn
 103   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
 104     (declare (function function))
 105     (flet ((%call-with-system-mutex ()
 106              (let (got-it)
 107                (unwind-protect
 108                     (when (setf got-it (get-mutex mutex))
 109                       (funcall function))
 110                  (when got-it
 111                    (release-mutex mutex))))))
 112       (if without-gcing-p
 113           (without-gcing
 114             (%call-with-system-mutex))
 115           (without-interrupts
 116             (%call-with-system-mutex)))))
 117
 118   (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p)
 119     (declare (function function))
 120     (flet ((%call-with-system-spinlock ()
 121              (let ((inner-lock-p (eq *current-thread* (spinlock-value lock)))
 122                    (got-it nil))
 123                (unwind-protect
 124                     (when (or inner-lock-p (setf got-it (get-spinlock lock)))
 125                       (funcall function))
 126                  (when got-it
 127                    (release-spinlock lock))))))
 128       (if without-gcing-p
 129           (without-gcing
 130             (%call-with-system-spinlock))
 131           (without-interrupts
 132             (%call-with-system-spinlock)))))
 133
 134   (defun call-with-mutex (function mutex value waitp)
 135     (declare (function function))
 136     (let ((got-it nil))
 137       (without-interrupts
 138         (unwind-protect
 139              (when (setq got-it (allow-with-interrupts
 140                                  (get-mutex mutex value waitp)))
 141                (with-local-interrupts (funcall function)))
 142           (when got-it
 143             (release-mutex mutex))))))
 144
 145   (defun call-with-recursive-lock (function mutex)
 146     (declare (function function))
 147     (let ((inner-lock-p (eq (mutex-value mutex) *current-thread*))
 148           (got-it nil))
 149       (without-interrupts
 150         (unwind-protect
 151              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 152                                                   (get-mutex mutex))))
 153                (with-local-interrupts (funcall function)))
 154           (when got-it
 155             (release-mutex mutex))))))
 156
 157   (defun call-with-spinlock (function spinlock)
 158     (declare (function function))
 159     (let ((got-it nil))
 160       (without-interrupts
 161         (unwind-protect
 162              (when (setf got-it (allow-with-interrupts
 163                                  (get-spinlock spinlock)))
 164                (with-local-interrupts (funcall function)))
 165           (when got-it
 166             (release-spinlock spinlock))))))
 167
 168   (defun call-with-recursive-spinlock (function spinlock)
 169     (declare (function function))
 170     (let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
 171           (got-it nil))
 172       (without-interrupts
 173         (unwind-protect
 174              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 175                                                   (get-spinlock spinlock))))
 176                (with-local-interrupts (funcall function)))
 177           (when got-it
 178             (release-spinlock spinlock)))))))