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