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