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   (%owner nil :type (or null thread))
  19   #!+(and (not sb-lutex) sb-thread)
  20   (state 0 :type fixnum)
  21   #!+(and sb-lutex sb-thread)
  22   (lutex (make-lutex)))
  23
  24 ;;; FIXME: We probably want to rename the accessor MUTEX-OWNER.
  25 (defun mutex-value (mutex)
  26   "Current owner of the mutex, NIL if the mutex is free."
  27   (mutex-%owner mutex))
  28
  29 (defsetf mutex-value set-mutex-value)
  30
  31 (declaim (inline set-mutex-value))
  32 (defun set-mutex-value (mutex value)
  33   (declare (ignore mutex value))
  34   (error "~S is no longer supported." '(setf mutex-value)))
  35
  36 (define-compiler-macro set-mutex-value (&whole form mutex value)
  37   (declare (ignore mutex value))
  38   (warn "~S is no longer supported, and will signal an error at runtime."
  39         '(setf mutex-value))
  40   form)
  41
  42 (def!struct spinlock
  43   #!+sb-doc
  44   "Spinlock type."
  45   (name nil :type (or null simple-string))
  46   (value nil))
  47
  48 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
  49                             &body body)
  50   #!+sb-doc
  51   "Acquire MUTEX for the dynamic scope of BODY, setting it to
  52 NEW-VALUE or some suitable default value if NIL.  If WAIT-P is non-NIL
  53 and the mutex is in use, sleep until it is available"
  54   `(dx-flet ((with-mutex-thunk () ,@body))
  55      (call-with-mutex
  56       #'with-mutex-thunk
  57       ,mutex
  58       ,value
  59       ,wait-p)))
  60
  61 (sb!xc:defmacro with-system-mutex ((mutex &key without-gcing) &body body)
  62   `(dx-flet ((with-system-mutex-thunk () ,@body))
  63      (call-with-system-mutex
  64       #'with-system-mutex-thunk
  65       ,mutex
  66       ,without-gcing)))
  67
  68 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
  69   #!+sb-doc
  70   "Acquires MUTEX for the dynamic scope of BODY. Within that scope
  71 further recursive lock attempts for the same mutex succeed. It is
  72 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
  73 provided the default value is used for the mutex."
  74   `(dx-flet ((with-recursive-lock-thunk () ,@body))
  75      (call-with-recursive-lock
  76       #'with-recursive-lock-thunk
  77       ,mutex)))
  78
  79 (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
  80   `(dx-flet ((with-recursive-spinlock-thunk () ,@body))
  81      (call-with-recursive-spinlock
  82       #'with-recursive-spinlock-thunk
  83       ,spinlock)))
  84
  85 (sb!xc:defmacro with-recursive-system-spinlock ((spinlock &key without-gcing)
  86                                                 &body body)
  87   `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body))
  88      (call-with-recursive-system-spinlock
  89       #'with-recursive-system-spinlock-thunk
  90       ,spinlock
  91       ,without-gcing)))
  92
  93 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
  94   `(dx-flet ((with-spinlock-thunk () ,@body))
  95      (call-with-spinlock
  96       #'with-spinlock-thunk
  97       ,spinlock)))
  98
  99 ;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not
 100 ;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented.
 101 ;;; However, there would be a (possibly slight) performance hit in
 102 ;;; using them.
 103 #!-sb-thread
 104 (progn
 105   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
 106     (declare (ignore mutex)
 107              (function function))
 108     (if without-gcing-p
 109         (without-gcing
 110           (funcall function))
 111         (without-interrupts
 112           (allow-with-interrupts (funcall function)))))
 113
 114   (defun call-with-system-spinlock (function spinlock &optional without-gcing-p)
 115     (declare (ignore spinlock)
 116              (function function))
 117     (if without-gcing-p
 118         (without-gcing
 119           (funcall function))
 120         (without-interrupts
 121           (allow-with-interrupts (funcall function)))))
 122
 123   (defun call-with-recursive-system-spinlock (function lock
 124                                               &optional without-gcing-p)
 125     (declare (ignore lock)
 126              (function function))
 127     (if without-gcing-p
 128         (without-gcing
 129           (funcall function))
 130         (without-interrupts
 131           (allow-with-interrupts (funcall function)))))
 132
 133   (defun call-with-mutex (function mutex value waitp)
 134     (declare (ignore mutex value waitp)
 135              (function function))
 136     (funcall function))
 137
 138   (defun call-with-recursive-lock (function mutex)
 139     (declare (ignore mutex) (function function))
 140     (funcall function))
 141
 142   (defun call-with-spinlock (function spinlock)
 143     (declare (ignore spinlock) (function function))
 144     (funcall function))
 145
 146   (defun call-with-recursive-spinlock (function spinlock)
 147     (declare (ignore spinlock) (function function))
 148     (funcall function)))
 149
 150 #!+sb-thread
 151 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
 152 ;;; closes over GOT-IT causes a value-cell to be allocated for it -- and
 153 ;;; we prefer that to go on the stack since it can.
 154 (progn
 155   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
 156     (declare (function function))
 157     (flet ((%call-with-system-mutex ()
 158              (dx-let (got-it)
 159                (unwind-protect
 160                     (when (setf got-it (get-mutex mutex))
 161                       (funcall function))
 162                  (when got-it
 163                    (release-mutex mutex))))))
 164       (if without-gcing-p
 165           (without-gcing
 166             (%call-with-system-mutex))
 167           (without-interrupts
 168             (allow-with-interrupts (%call-with-system-mutex))))))
 169
 170   (defun call-with-system-spinlock (function spinlock &optional without-gcing-p)
 171     (declare (function function))
 172     (flet ((%call-with-system-spinlock ()
 173              (dx-let (got-it)
 174                (unwind-protect
 175                     (when (setf got-it (get-spinlock spinlock))
 176                       (funcall function))
 177                  (when got-it
 178                    (release-spinlock spinlock))))))
 179       (if without-gcing-p
 180           (without-gcing
 181             (%call-with-system-spinlock))
 182           (without-interrupts
 183             (allow-with-interrupts (%call-with-system-spinlock))))))
 184
 185   (defun call-with-recursive-system-spinlock (function lock
 186                                               &optional without-gcing-p)
 187     (declare (function function))
 188     (flet ((%call-with-system-spinlock ()
 189              (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value lock)))
 190                       (got-it nil))
 191                (unwind-protect
 192                     (when (or inner-lock-p (setf got-it (get-spinlock lock)))
 193                       (funcall function))
 194                  (when got-it
 195                    (release-spinlock lock))))))
 196       (if without-gcing-p
 197           (without-gcing
 198             (%call-with-system-spinlock))
 199           (without-interrupts
 200             (allow-with-interrupts (%call-with-system-spinlock))))))
 201
 202   (defun call-with-spinlock (function spinlock)
 203     (declare (function function))
 204     (dx-let ((got-it nil))
 205       (without-interrupts
 206         (unwind-protect
 207              (when (setf got-it (allow-with-interrupts
 208                                  (get-spinlock spinlock)))
 209                (with-local-interrupts (funcall function)))
 210           (when got-it
 211             (release-spinlock spinlock))))))
 212
 213   (defun call-with-mutex (function mutex value waitp)
 214     (declare (function function))
 215     (dx-let ((got-it nil))
 216       (without-interrupts
 217         (unwind-protect
 218              (when (setq got-it (allow-with-interrupts
 219                                  (get-mutex mutex value waitp)))
 220                (with-local-interrupts (funcall function)))
 221           (when got-it
 222             (release-mutex mutex))))))
 223
 224   (defun call-with-recursive-lock (function mutex)
 225     (declare (function function))
 226     (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
 227              (got-it nil))
 228       (without-interrupts
 229         (unwind-protect
 230              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 231                                                   (get-mutex mutex))))
 232                (with-local-interrupts (funcall function)))
 233           (when got-it
 234             (release-mutex mutex))))))
 235
 236
 237
 238   (defun call-with-recursive-spinlock (function spinlock)
 239     (declare (function function))
 240     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
 241           (got-it nil))
 242       (without-interrupts
 243         (unwind-protect
 244              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 245                                                   (get-spinlock spinlock))))
 246                (with-local-interrupts (funcall function)))
 247           (when got-it
 248             (release-spinlock spinlock)))))))