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