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