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