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