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