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 (def!struct (thread (:constructor %make-thread))
  15   #!+sb-doc
  16   "Thread type. Do not rely on threads being structs as it may change
  17 in future versions."
  18   name
  19   %alive-p
  20   os-thread
  21   interruptions
  22   (interruptions-lock (make-mutex :name "thread interruptions lock"))
  23   result
  24   (result-lock (make-mutex :name "thread result lock")))
  25
  26 (def!struct mutex
  27   #!+sb-doc
  28   "Mutex type."
  29   (name nil :type (or null simple-string))
  30   (%owner nil :type (or null thread))
  31   #!+(and (not sb-lutex) sb-thread)
  32   (state 0 :type fixnum)
  33   #!+(and sb-lutex sb-thread)
  34   (lutex (make-lutex)))
  35
  36 (defun mutex-value (mutex)
  37   "Current owner of the mutex, NIL if the mutex is free. May return a
  38 stale value, use MUTEX-OWNER instead."
  39   (mutex-%owner mutex))
  40
  41 (defun holding-mutex-p (mutex)
  42   "Test whether the current thread is holding MUTEX."
  43   ;; This is about the only use for which a stale value of owner is
  44   ;; sufficient.
  45   (eq sb!thread:*current-thread* (mutex-%owner mutex)))
  46
  47 (defsetf mutex-value set-mutex-value)
  48
  49 (declaim (inline set-mutex-value))
  50 (defun set-mutex-value (mutex value)
  51   (declare (ignore mutex value))
  52   (error "~S is no longer supported." '(setf mutex-value)))
  53
  54 (define-compiler-macro set-mutex-value (&whole form mutex value)
  55   (declare (ignore mutex value))
  56   (warn "~S is no longer supported, and will signal an error at runtime."
  57         '(setf mutex-value))
  58   form)
  59
  60 (def!struct spinlock
  61   #!+sb-doc
  62   "Spinlock type."
  63   (name nil :type (or null simple-string))
  64   (value nil))
  65
  66 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
  67                             &body body)
  68   #!+sb-doc
  69   "Acquire MUTEX for the dynamic scope of BODY, setting it to VALUE or
  70 some suitable default value if NIL.  If WAIT-P is non-NIL and the mutex
  71 is in use, sleep until it is available"
  72   `(dx-flet ((with-mutex-thunk () ,@body))
  73      (call-with-mutex
  74       #'with-mutex-thunk
  75       ,mutex
  76       ,value
  77       ,wait-p)))
  78
  79 (sb!xc:defmacro with-system-mutex ((mutex
  80                                     &key without-gcing allow-with-interrupts)
  81                                    &body body)
  82   `(dx-flet ((with-system-mutex-thunk () ,@body))
  83      (,(cond (without-gcing
  84                'call-with-system-mutex/without-gcing)
  85              (allow-with-interrupts
  86               'call-with-system-mutex/allow-with-interrupts)
  87              (t
  88               'call-with-system-mutex))
  89        #'with-system-mutex-thunk
  90        ,mutex)))
  91
  92 (sb!xc:defmacro with-system-spinlock ((spinlock &key) &body body)
  93   `(dx-flet ((with-system-spinlock-thunk () ,@body))
  94      (call-with-system-spinlock
  95        #'with-system-spinlock-thunk
  96        ,spinlock)))
  97
  98 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
  99   #!+sb-doc
 100   "Acquires MUTEX for the dynamic scope of BODY. Within that scope
 101 further recursive lock attempts for the same mutex succeed. It is
 102 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
 103 provided the default value is used for the mutex."
 104   `(dx-flet ((with-recursive-lock-thunk () ,@body))
 105      (call-with-recursive-lock
 106       #'with-recursive-lock-thunk
 107       ,mutex)))
 108
 109 (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
 110   `(dx-flet ((with-recursive-spinlock-thunk () ,@body))
 111      (call-with-recursive-spinlock
 112       #'with-recursive-spinlock-thunk
 113       ,spinlock)))
 114
 115 (sb!xc:defmacro with-recursive-system-spinlock ((spinlock
 116                                                  &key without-gcing)
 117                                                 &body body)
 118   `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body))
 119      (,(cond (without-gcing
 120                'call-with-recursive-system-spinlock/without-gcing)
 121              (t
 122               'call-with-recursive-system-spinlock))
 123        #'with-recursive-system-spinlock-thunk
 124        ,spinlock)))
 125
 126 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
 127   `(dx-flet ((with-spinlock-thunk () ,@body))
 128      (call-with-spinlock
 129       #'with-spinlock-thunk
 130       ,spinlock)))
 131
 132 (macrolet ((def (name &optional variant)
 133              `(defun ,(if variant (symbolicate name "/" variant) name)
 134                   (function mutex)
 135                 (declare (function function))
 136                 (flet ((%call-with-system-mutex ()
 137                          (dx-let (got-it)
 138                            (unwind-protect
 139                                 (when (setf got-it (get-mutex mutex))
 140                                   (funcall function))
 141                              (when got-it
 142                                (release-mutex mutex))))))
 143                   (declare (inline %call-with-system-mutex))
 144                   ,(ecase variant
 145                      (:without-gcing
 146                        `(without-gcing (%call-with-system-mutex)))
 147                      (:allow-with-interrupts
 148                        `(without-interrupts
 149                           (allow-with-interrupts (%call-with-system-mutex))))
 150                      ((nil)
 151                       `(without-interrupts (%call-with-system-mutex))))))))
 152   (def call-with-system-mutex)
 153   (def call-with-system-mutex :without-gcing)
 154   (def call-with-system-mutex :allow-with-interrupts))
 155
 156 #!-sb-thread
 157 (progn
 158   (macrolet ((def (name &optional variant)
 159                `(defun ,(if variant (symbolicate name "/" variant) name)
 160                     (function lock)
 161                   (declare (ignore lock) (function function))
 162                   ,(ecase variant
 163                     (:without-gcing
 164                       `(without-gcing (funcall function)))
 165                     (:allow-with-interrupts
 166                       `(without-interrupts
 167                          (allow-with-interrupts (funcall function))))
 168                     ((nil)
 169                       `(without-interrupts (funcall function)))))))
 170     (def call-with-system-spinlock)
 171     (def call-with-recursive-system-spinlock)
 172     (def call-with-recursive-system-spinlock :without-gcing))
 173
 174   (defun call-with-mutex (function mutex value waitp)
 175     (declare (ignore mutex value waitp)
 176              (function function))
 177     (funcall function))
 178
 179   (defun call-with-recursive-lock (function mutex)
 180     (declare (ignore mutex) (function function))
 181     (funcall function))
 182
 183   (defun call-with-spinlock (function spinlock)
 184     (declare (ignore spinlock) (function function))
 185     (funcall function))
 186
 187   (defun call-with-recursive-spinlock (function spinlock)
 188     (declare (ignore spinlock) (function function))
 189     (funcall function)))
 190
 191 #!+sb-thread
 192 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
 193 ;;; closes over GOT-IT causes a value-cell to be allocated for it --
 194 ;;; and we prefer that to go on the stack since it can.
 195 (progn
 196   (defun call-with-system-spinlock (function spinlock)
 197     (declare (function function))
 198     (without-interrupts
 199       (dx-let (got-it)
 200         (unwind-protect
 201              (when (setf got-it (get-spinlock spinlock))
 202                (funcall function))
 203           (when got-it
 204             (release-spinlock spinlock))))))
 205
 206   (macrolet ((def (name &optional variant)
 207                `(defun ,(if variant (symbolicate name "/" variant) name)
 208                     (function spinlock)
 209                   (declare (function function))
 210                   (flet ((%call-with-system-spinlock ()
 211                            (dx-let ((inner-lock-p
 212                                      (eq *current-thread*
 213                                          (spinlock-value spinlock)))
 214                                     (got-it nil))
 215                              (unwind-protect
 216                                   (when (or inner-lock-p
 217                                             (setf got-it
 218                                                   (get-spinlock spinlock)))
 219                                     (funcall function))
 220                                (when got-it
 221                                  (release-spinlock spinlock))))))
 222                     (declare (inline %call-with-system-spinlock))
 223                     ,(ecase variant
 224                       (:without-gcing
 225                         `(without-gcing (%call-with-system-spinlock)))
 226                       ((nil)
 227                         `(without-interrupts (%call-with-system-spinlock))))))))
 228     (def call-with-recursive-system-spinlock)
 229     (def call-with-recursive-system-spinlock :without-gcing))
 230
 231   (defun call-with-spinlock (function spinlock)
 232     (declare (function function))
 233     (dx-let ((got-it nil))
 234       (without-interrupts
 235         (unwind-protect
 236              (when (setf got-it (allow-with-interrupts
 237                                  (get-spinlock spinlock)))
 238                (with-local-interrupts (funcall function)))
 239           (when got-it
 240             (release-spinlock spinlock))))))
 241
 242   (defun call-with-mutex (function mutex value waitp)
 243     (declare (function function))
 244     (dx-let ((got-it nil))
 245       (without-interrupts
 246         (unwind-protect
 247              (when (setq got-it (allow-with-interrupts
 248                                  (get-mutex mutex value waitp)))
 249                (with-local-interrupts (funcall function)))
 250           (when got-it
 251             (release-mutex mutex))))))
 252
 253   (defun call-with-recursive-lock (function mutex)
 254     (declare (function function))
 255     (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
 256              (got-it nil))
 257       (without-interrupts
 258         (unwind-protect
 259              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 260                                                   (get-mutex mutex))))
 261                (with-local-interrupts (funcall function)))
 262           (when got-it
 263             (release-mutex mutex))))))
 264
 265   (defun call-with-recursive-spinlock (function spinlock)
 266     (declare (function function))
 267     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *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                                                   (get-spinlock spinlock))))
 273                (with-local-interrupts (funcall function)))
 274           (when got-it
 275             (release-spinlock spinlock)))))))