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           (funcall function))))
  93
  94   (defun call-with-recursive-system-spinlock (function lock
  95                                               &optional without-gcing-p)
  96     (declare (ignore lock)
  97              (function function))
  98     (if without-gcing-p
  99         (without-gcing
 100           (funcall function))
 101         (without-interrupts
 102           (funcall function))))
 103
 104   (defun call-with-mutex (function mutex value waitp)
 105     (declare (ignore mutex value waitp)
 106              (function function))
 107     (funcall function))
 108
 109   (defun call-with-recursive-lock (function mutex)
 110     (declare (ignore mutex) (function function))
 111     (funcall function))
 112
 113   (defun call-with-spinlock (function spinlock)
 114     (declare (ignore spinlock) (function function))
 115     (funcall function))
 116
 117   (defun call-with-recursive-spinlock (function spinlock)
 118     (declare (ignore spinlock) (function function))
 119     (funcall function)))
 120
 121 #!+sb-thread
 122 (progn
 123   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
 124     (declare (function function))
 125     (flet ((%call-with-system-mutex ()
 126              (let (got-it)
 127                (unwind-protect
 128                     (when (setf got-it (get-mutex mutex))
 129                       (funcall function))
 130                  (when got-it
 131                    (release-mutex mutex))))))
 132       (if without-gcing-p
 133           (without-gcing
 134             (%call-with-system-mutex))
 135           (without-interrupts
 136             (%call-with-system-mutex)))))
 137
 138   (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p)
 139     (declare (function function))
 140     (flet ((%call-with-system-spinlock ()
 141              (let ((inner-lock-p (eq *current-thread* (spinlock-value lock)))
 142                    (got-it nil))
 143                (unwind-protect
 144                     (when (or inner-lock-p (setf got-it (get-spinlock lock)))
 145                       (funcall function))
 146                  (when got-it
 147                    (release-spinlock lock))))))
 148       (if without-gcing-p
 149           (without-gcing
 150             (%call-with-system-spinlock))
 151           (without-interrupts
 152             (%call-with-system-spinlock)))))
 153
 154   (defun call-with-mutex (function mutex value waitp)
 155     (declare (function function))
 156     (let ((got-it nil))
 157       (without-interrupts
 158         (unwind-protect
 159              (when (setq got-it (allow-with-interrupts
 160                                  (get-mutex mutex value waitp)))
 161                (with-local-interrupts (funcall function)))
 162           (when got-it
 163             (release-mutex mutex))))))
 164
 165   (defun call-with-recursive-lock (function mutex)
 166     (declare (function function))
 167     (let ((inner-lock-p (eq (mutex-value mutex) *current-thread*))
 168           (got-it nil))
 169       (without-interrupts
 170         (unwind-protect
 171              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 172                                                   (get-mutex mutex))))
 173                (with-local-interrupts (funcall function)))
 174           (when got-it
 175             (release-mutex mutex))))))
 176
 177   (defun call-with-spinlock (function spinlock)
 178     (declare (function function))
 179     (let ((got-it nil))
 180       (without-interrupts
 181         (unwind-protect
 182              (when (setf got-it (allow-with-interrupts
 183                                  (get-spinlock spinlock)))
 184                (with-local-interrupts (funcall function)))
 185           (when got-it
 186             (release-spinlock spinlock))))))
 187
 188   (defun call-with-recursive-spinlock (function spinlock)
 189     (declare (function function))
 190     (let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
 191           (got-it nil))
 192       (without-interrupts
 193         (unwind-protect
 194              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 195                                                   (get-spinlock spinlock))))
 196                (with-local-interrupts (funcall function)))
 197           (when got-it
 198             (release-spinlock spinlock)))))))