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 mutex
  15   #!+sb-doc
  16   "Mutex type."
  17   (name nil :type (or null simple-string))
  18   (value nil)
  19   #!+(and sb-lutex sb-thread)
  20   (lutex (make-lutex)))
  21
  22 (def!struct spinlock
  23   #!+sb-doc
  24   "Spinlock type."
  25   (name nil :type (or null simple-string))
  26   (value nil))
  27
  28 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
  29                             &body body)
  30   #!+sb-doc
  31   "Acquire MUTEX for the dynamic scope of BODY, setting it to
  32 NEW-VALUE or some suitable default value if NIL.  If WAIT-P is non-NIL
  33 and the mutex is in use, sleep until it is available"
  34   `(dx-flet ((with-mutex-thunk () ,@body))
  35      (call-with-mutex
  36       #'with-mutex-thunk
  37       ,mutex
  38       ,value
  39       ,wait-p)))
  40
  41 (sb!xc:defmacro with-system-mutex ((mutex &key without-gcing) &body body)
  42   `(dx-flet ((with-system-mutex-thunk () ,@body))
  43      (call-with-system-mutex
  44       #'with-system-mutex-thunk
  45       ,mutex
  46       ,without-gcing)))
  47
  48 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
  49   #!+sb-doc
  50   "Acquires MUTEX for the dynamic scope of BODY. Within that scope
  51 further recursive lock attempts for the same mutex succeed. It is
  52 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
  53 provided the default value is used for the mutex."
  54   `(dx-flet ((with-recursive-lock-thunk () ,@body))
  55      (call-with-recursive-lock
  56       #'with-recursive-lock-thunk
  57       ,mutex)))
  58
  59 (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
  60   `(dx-flet ((with-recursive-spinlock-thunk () ,@body))
  61      (call-with-recursive-spinlock
  62       #'with-recursive-spinlock-thunk
  63       ,spinlock)))
  64
  65 (sb!xc:defmacro with-recursive-system-spinlock ((spinlock &key without-gcing)
  66                                                 &body body)
  67   `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body))
  68      (call-with-recursive-system-spinlock
  69       #'with-recursive-system-spinlock-thunk
  70       ,spinlock
  71       ,without-gcing)))
  72
  73 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
  74   `(dx-flet ((with-spinlock-thunk () ,@body))
  75      (call-with-spinlock
  76       #'with-spinlock-thunk
  77       ,spinlock)))
  78
  79 ;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not
  80 ;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented.
  81 ;;; However, there would be a (possibly slight) performance hit in
  82 ;;; using them.
  83 #!-sb-thread
  84 (progn
  85   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
  86     (declare (ignore mutex)
  87              (function function))
  88     (if without-gcing-p
  89         (without-gcing
  90           (funcall function))
  91         (without-interrupts
  92           (allow-with-interrupts (funcall function)))))
  93
  94   (defun call-with-system-spinlock (function spinlock &optional without-gcing-p)
  95     (declare (ignore spinlock)
  96              (function function))
  97     (if without-gcing-p
  98         (without-gcing
  99           (funcall function))
 100         (without-interrupts
 101           (allow-with-interrupts (funcall function)))))
 102
 103   (defun call-with-recursive-system-spinlock (function lock
 104                                               &optional without-gcing-p)
 105     (declare (ignore lock)
 106              (function function))
 107     (if without-gcing-p
 108         (without-gcing
 109           (funcall function))
 110         (without-interrupts
 111           (allow-with-interrupts (funcall function)))))
 112
 113   (defun call-with-mutex (function mutex value waitp)
 114     (declare (ignore mutex value waitp)
 115              (function function))
 116     (funcall function))
 117
 118   (defun call-with-recursive-lock (function mutex)
 119     (declare (ignore mutex) (function function))
 120     (funcall function))
 121
 122   (defun call-with-spinlock (function spinlock)
 123     (declare (ignore spinlock) (function function))
 124     (funcall function))
 125
 126   (defun call-with-recursive-spinlock (function spinlock)
 127     (declare (ignore spinlock) (function function))
 128     (funcall function)))
 129
 130 #!+sb-thread
 131 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
 132 ;;; closes over GOT-IT causes a value-cell to be allocated for it -- and
 133 ;;; we prefer that to go on the stack since it can.
 134 (progn
 135   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
 136     (declare (function function))
 137     (flet ((%call-with-system-mutex ()
 138              (dx-let (got-it)
 139                (unwind-protect
 140                     (when (setf got-it (get-mutex mutex))
 141                       (funcall function))
 142                  (when got-it
 143                    (release-mutex mutex))))))
 144       (if without-gcing-p
 145           (without-gcing
 146             (%call-with-system-mutex))
 147           (without-interrupts
 148             (allow-with-interrupts (%call-with-system-mutex))))))
 149
 150   (defun call-with-system-spinlock (function spinlock &optional without-gcing-p)
 151     (declare (function function))
 152     (flet ((%call-with-system-spinlock ()
 153              (dx-let (got-it)
 154                (unwind-protect
 155                     (when (setf got-it (get-spinlock spinlock))
 156                       (funcall function))
 157                  (when got-it
 158                    (release-spinlock spinlock))))))
 159       (if without-gcing-p
 160           (without-gcing
 161             (%call-with-system-spinlock))
 162           (without-interrupts
 163             (allow-with-interrupts (%call-with-system-spinlock))))))
 164
 165   (defun call-with-recursive-system-spinlock (function lock
 166                                               &optional without-gcing-p)
 167     (declare (function function))
 168     (flet ((%call-with-system-spinlock ()
 169              (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value lock)))
 170                       (got-it nil))
 171                (unwind-protect
 172                     (when (or inner-lock-p (setf got-it (get-spinlock lock)))
 173                       (funcall function))
 174                  (when got-it
 175                    (release-spinlock lock))))))
 176       (if without-gcing-p
 177           (without-gcing
 178             (%call-with-system-spinlock))
 179           (without-interrupts
 180             (allow-with-interrupts (%call-with-system-spinlock))))))
 181
 182   (defun call-with-spinlock (function spinlock)
 183     (declare (function function))
 184     (dx-let ((got-it nil))
 185       (without-interrupts
 186         (unwind-protect
 187              (when (setf got-it (allow-with-interrupts
 188                                  (get-spinlock spinlock)))
 189                (with-local-interrupts (funcall function)))
 190           (when got-it
 191             (release-spinlock spinlock))))))
 192
 193   (defun call-with-mutex (function mutex value waitp)
 194     (declare (function function))
 195     (dx-let ((got-it nil))
 196       (without-interrupts
 197         (unwind-protect
 198              (when (setq got-it (allow-with-interrupts
 199                                  (get-mutex mutex value waitp)))
 200                (with-local-interrupts (funcall function)))
 201           (when got-it
 202             (release-mutex mutex))))))
 203
 204   (defun call-with-recursive-lock (function mutex)
 205     (declare (function function))
 206     (dx-let ((inner-lock-p (eq (mutex-value mutex) *current-thread*))
 207              (got-it nil))
 208       (without-interrupts
 209         (unwind-protect
 210              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 211                                                   (get-mutex mutex))))
 212                (with-local-interrupts (funcall function)))
 213           (when got-it
 214             (release-mutex mutex))))))
 215
 216
 217
 218   (defun call-with-recursive-spinlock (function spinlock)
 219     (declare (function function))
 220     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
 221           (got-it nil))
 222       (without-interrupts
 223         (unwind-protect
 224              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 225                                                   (get-spinlock spinlock))))
 226                (with-local-interrupts (funcall function)))
 227           (when got-it
 228             (release-spinlock spinlock)))))))