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!type thread-name ()
  15   'simple-string)
  16
  17 (def!struct (thread (:constructor %make-thread))
  18   #!+sb-doc
  19   "Thread type. Do not rely on threads being structs as it may change
  20 in future versions."
  21   (name          nil :type (or thread-name null))
  22   (%alive-p      nil :type boolean)
  23   (%ephemeral-p  nil :type boolean)
  24   (os-thread     nil :type (or integer null))
  25   (interruptions nil :type list)
  26   (result        nil :type list)
  27   (interruptions-lock
  28    (make-mutex :name "thread interruptions lock")
  29    :type mutex)
  30   (result-lock
  31    (make-mutex :name "thread result lock")
  32    :type mutex)
  33   waiting-for)
  34
  35 (def!struct mutex
  36   #!+sb-doc
  37   "Mutex type."
  38   (name   nil :type (or null thread-name))
  39   (%owner nil :type (or null thread))
  40   #!+(and sb-thread sb-futex)
  41   (state    0 :type fixnum))
  42
  43 (defun mutex-value (mutex)
  44   "Current owner of the mutex, NIL if the mutex is free. May return a
  45 stale value, use MUTEX-OWNER instead."
  46   (mutex-%owner mutex))
  47
  48 (defun holding-mutex-p (mutex)
  49   "Test whether the current thread is holding MUTEX."
  50   ;; This is about the only use for which a stale value of owner is
  51   ;; sufficient.
  52   (eq sb!thread:*current-thread* (mutex-%owner mutex)))
  53
  54 (defsetf mutex-value set-mutex-value)
  55
  56 (declaim (inline set-mutex-value))
  57 (defun set-mutex-value (mutex value)
  58   (declare (ignore mutex value))
  59   (error "~S is no longer supported." '(setf mutex-value)))
  60
  61 (define-compiler-macro set-mutex-value (&whole form mutex value)
  62   (declare (ignore mutex value))
  63   (warn "~S is no longer supported, and will signal an error at runtime."
  64         '(setf mutex-value))
  65   form)
  66
  67 ;;; SPINLOCK no longer exists as a type -- provided for backwards compatibility.
  68
  69 (deftype spinlock ()
  70   "Spinlock type."
  71   (deprecation-warning :early "1.0.53.11" 'spinlock 'mutex)
  72   'mutex)
  73
  74 (define-deprecated-function :early "1.0.53.11" make-spinlock make-mutex (&key name)
  75   (make-mutex :name name))
  76
  77 (define-deprecated-function :early "1.0.53.11" spinlock-name mutex-name (lock)
  78   (mutex-name lock))
  79
  80 (define-deprecated-function :early "1.0.53.11" (setf spinlock-name) (setf mutex-name) (name lock)
  81   (setf (mutex-name lock) name))
  82
  83 (define-deprecated-function :early "1.0.53.11" spinlock-value mutex-owner (lock)
  84   (mutex-owner lock))
  85
  86 (define-deprecated-function :early "1.0.53.11" get-spinlock grab-mutex (lock)
  87   (grab-mutex lock))
  88
  89 (define-deprecated-function :early "1.0.53.11" release-spinlock release-mutex (lock)
  90   (release-mutex lock))
  91
  92 (sb!xc:defmacro with-recursive-spinlock ((lock) &body body)
  93   (deprecation-warning :early "1.0.53.11" 'with-recursive-spinlock 'with-recursive-lock)
  94   `(with-recursive-lock (,lock)
  95      ,@body))
  96
  97 (sb!xc:defmacro with-spinlock ((lock) &body body)
  98   (deprecation-warning :early "1.0.53.11" 'with-spinlock 'with-mutex)
  99   `(with-mutex (,lock)
 100      ,@body))
 101
 102 (sb!xc:defmacro without-thread-waiting-for ((&key already-without-interrupts) &body body)
 103   (with-unique-names (thread prev)
 104     (let ((without (if already-without-interrupts
 105                        'progn
 106                        'without-interrupts))
 107           (with (if already-without-interrupts
 108                     'progn
 109                     'with-local-interrupts)))
 110       `(let* ((,thread *current-thread*)
 111               (,prev (progn
 112                        (barrier (:read))
 113                        (thread-waiting-for ,thread))))
 114          (flet ((exec () ,@body))
 115            (if ,prev
 116                (,without
 117                 (unwind-protect
 118                      (progn
 119                        (setf (thread-waiting-for ,thread) nil)
 120                        (barrier (:write))
 121                        (,with (exec)))
 122                   ;; If we were waiting on a waitqueue, this becomes a bogus
 123                   ;; wakeup.
 124                   (when (mutex-p ,prev)
 125                     (setf (thread-waiting-for ,thread) ,prev)
 126                     (barrier (:write)))))
 127                (exec)))))))
 128
 129 (sb!xc:defmacro with-mutex ((mutex &key (wait-p t) timeout value)
 130                             &body body)
 131   #!+sb-doc
 132   "Acquire MUTEX for the dynamic scope of BODY. If WAIT-P is true (the default),
 133 and the MUTEX is not immediately available, sleep until it is available.
 134
 135 If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long
 136 the system should try to acquire the lock in the contested case.
 137
 138 If the mutex isn't acquired succesfully due to either WAIT-P or TIMEOUT, the
 139 body is not executed, and WITH-MUTEX returns NIL.
 140
 141 Otherwise body is executed with the mutex held by current thread, and
 142 WITH-MUTEX returns the values of BODY.
 143
 144 Historically WITH-MUTEX also accepted a VALUE argument, which when provided
 145 was used as the new owner of the mutex instead of the current thread. This is
 146 no longer supported: if VALUE is provided, it must be either NIL or the
 147 current thread."
 148   `(dx-flet ((with-mutex-thunk () ,@body))
 149      (call-with-mutex
 150       #'with-mutex-thunk
 151       ,mutex
 152       ,value
 153       ,wait-p
 154       ,timeout)))
 155
 156 (sb!xc:defmacro with-system-mutex ((mutex
 157                                     &key without-gcing allow-with-interrupts)
 158                                    &body body)
 159   `(dx-flet ((with-system-mutex-thunk () ,@body))
 160      (,(cond (without-gcing
 161                'call-with-system-mutex/without-gcing)
 162              (allow-with-interrupts
 163               'call-with-system-mutex/allow-with-interrupts)
 164              (t
 165               'call-with-system-mutex))
 166        #'with-system-mutex-thunk
 167        ,mutex)))
 168
 169 (sb!xc:defmacro with-recursive-lock ((mutex &key (wait-p t) timeout) &body body)
 170   #!+sb-doc
 171   "Acquire MUTEX for the dynamic scope of BODY.
 172
 173 If WAIT-P is true (the default), and the MUTEX is not immediately available or
 174 held by the current thread, sleep until it is available.
 175
 176 If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long
 177 the system should try to acquire the lock in the contested case.
 178
 179 If the mutex isn't acquired succesfully due to either WAIT-P or TIMEOUT, the
 180 body is not executed, and WITH-RECURSIVE-LOCK returns NIL.
 181
 182 Otherwise body is executed with the mutex held by current thread, and
 183 WITH-RECURSIVE-LOCK returns the values of BODY.
 184
 185 Unlike WITH-MUTEX, which signals an error on attempt to re-acquire an already
 186 held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed."
 187   `(dx-flet ((with-recursive-lock-thunk () ,@body))
 188      (call-with-recursive-lock
 189       #'with-recursive-lock-thunk
 190       ,mutex
 191       ,wait-p
 192       ,timeout)))
 193
 194 (sb!xc:defmacro with-recursive-system-lock ((lock
 195                                              &key without-gcing)
 196                                             &body body)
 197   `(dx-flet ((with-recursive-system-lock-thunk () ,@body))
 198      (,(cond (without-gcing
 199               'call-with-recursive-system-lock/without-gcing)
 200              (t
 201               'call-with-recursive-system-lock))
 202       #'with-recursive-system-lock-thunk
 203        ,lock)))
 204
 205 (macrolet ((def (name &optional variant)
 206              `(defun ,(if variant (symbolicate name "/" variant) name)
 207                   (function mutex)
 208                 (declare (function function))
 209                 (flet ((%call-with-system-mutex ()
 210                          (dx-let (got-it)
 211                            (unwind-protect
 212                                 (when (setf got-it (grab-mutex mutex))
 213                                   (funcall function))
 214                              (when got-it
 215                                (release-mutex mutex))))))
 216                   (declare (inline %call-with-system-mutex))
 217                   ,(ecase variant
 218                      (:without-gcing
 219                        `(without-gcing (%call-with-system-mutex)))
 220                      (:allow-with-interrupts
 221                        `(without-interrupts
 222                           (allow-with-interrupts (%call-with-system-mutex))))
 223                      ((nil)
 224                       `(without-interrupts (%call-with-system-mutex))))))))
 225   (def call-with-system-mutex)
 226   (def call-with-system-mutex :without-gcing)
 227   (def call-with-system-mutex :allow-with-interrupts))
 228
 229 #!-sb-thread
 230 (progn
 231   (defun call-with-mutex (function mutex value waitp timeout)
 232     (declare (ignore mutex waitp timeout)
 233              (function function))
 234     (unless (or (null value) (eq *current-thread* value))
 235       (error "~S called with non-nil :VALUE that isn't the current thread."
 236              'with-mutex))
 237     (funcall function))
 238
 239   (defun call-with-recursive-lock (function mutex waitp timeout)
 240     (declare (ignore mutex waitp timeout)
 241              (function function))
 242     (funcall function))
 243
 244   (defun call-with-recursive-system-lock (function lock)
 245     (declare (function function) (ignore lock))
 246     (without-interrupts
 247       (funcall function)))
 248
 249   (defun call-with-recursive-system-lock/without-gcing (function mutex)
 250     (declare (function function) (ignore mutex))
 251     (without-gcing
 252       (funcall function))))
 253
 254 #!+sb-thread
 255 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
 256 ;;; closes over GOT-IT causes a value-cell to be allocated for it --
 257 ;;; and we prefer that to go on the stack since it can.
 258 (progn
 259   (defun call-with-mutex (function mutex value waitp timeout)
 260     (declare (function function))
 261     (unless (or (null value) (eq *current-thread* value))
 262       (error "~S called with non-nil :VALUE that isn't the current thread."
 263              'with-mutex))
 264     (dx-let ((got-it nil))
 265       (without-interrupts
 266         (unwind-protect
 267              (when (setq got-it (allow-with-interrupts
 268                                   (grab-mutex mutex :waitp waitp
 269                                                     :timeout timeout)))
 270                (with-local-interrupts (funcall function)))
 271           (when got-it
 272             (release-mutex mutex))))))
 273
 274   (defun call-with-recursive-lock (function mutex waitp timeout)
 275     (declare (function function))
 276     (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
 277              (got-it nil))
 278       (without-interrupts
 279         (unwind-protect
 280              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 281                                                    (grab-mutex mutex :waitp waitp
 282                                                                      :timeout timeout))))
 283                (with-local-interrupts (funcall function)))
 284           (when got-it
 285             (release-mutex mutex))))))
 286
 287   (macrolet ((def (name &optional variant)
 288                `(defun ,(if variant (symbolicate name "/" variant) name)
 289                     (function lock)
 290                   (declare (function function))
 291                   (flet ((%call-with-recursive-system-lock ()
 292                            (dx-let ((inner-lock-p
 293                                      (eq *current-thread* (mutex-owner lock)))
 294                                     (got-it nil))
 295                              (unwind-protect
 296                                   (when (or inner-lock-p
 297                                             (setf got-it (grab-mutex lock)))
 298                                     (funcall function))
 299                                (when got-it
 300                                  (release-mutex lock))))))
 301                     (declare (inline %call-with-recursive-system-lock))
 302                     ,(ecase variant
 303                       (:without-gcing
 304                         `(without-gcing (%call-with-recursive-system-lock)))
 305                       ((nil)
 306                         `(without-interrupts (%call-with-recursive-system-lock))))))))
 307     (def call-with-recursive-system-lock)
 308     (def call-with-recursive-system-lock :without-gcing)))