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 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
 123 ;;; closes over GOT-IT causes a value-cell to be allocated for it -- and
 124 ;;; we prefer that to go on the stack since it can.
 125 (progn
 126   (defun call-with-system-mutex (function mutex &optional without-gcing-p)
 127     (declare (function function))
 128     (flet ((%call-with-system-mutex ()
 129              (dx-let (got-it)
 130                (unwind-protect
 131                     (when (setf got-it (get-mutex mutex))
 132                       (funcall function))
 133                  (when got-it
 134                    (release-mutex mutex))))))
 135       (if without-gcing-p
 136           (without-gcing
 137             (%call-with-system-mutex))
 138           (without-interrupts
 139             (%call-with-system-mutex)))))
 140
 141   (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p)
 142     (declare (function function))
 143     (flet ((%call-with-system-spinlock ()
 144              (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value lock)))
 145                       (got-it nil))
 146                (unwind-protect
 147                     (when (or inner-lock-p (setf got-it (get-spinlock lock)))
 148                       (funcall function))
 149                  (when got-it
 150                    (release-spinlock lock))))))
 151       (if without-gcing-p
 152           (without-gcing
 153             (%call-with-system-spinlock))
 154           (without-interrupts
 155             (%call-with-system-spinlock)))))
 156
 157   (defun call-with-spinlock (function spinlock)
 158     (declare (function function))
 159     (dx-let ((got-it nil))
 160       (without-interrupts
 161         (unwind-protect
 162              (when (setf got-it (allow-with-interrupts
 163                                  (get-spinlock spinlock)))
 164                (with-local-interrupts (funcall function)))
 165           (when got-it
 166             (release-spinlock spinlock))))))
 167
 168   (defun call-with-mutex (function mutex value waitp)
 169     (declare (function function))
 170     (dx-let ((got-it nil))
 171       (without-interrupts
 172         (unwind-protect
 173              (when (setq got-it (allow-with-interrupts
 174                                  (get-mutex mutex value waitp)))
 175                (with-local-interrupts (funcall function)))
 176           (when got-it
 177             (release-mutex mutex))))))
 178
 179   (defun call-with-recursive-lock (function mutex)
 180     (declare (function function))
 181     (dx-let ((inner-lock-p (eq (mutex-value mutex) *current-thread*))
 182              (got-it nil))
 183       (without-interrupts
 184         (unwind-protect
 185              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 186                                                   (get-mutex mutex))))
 187                (with-local-interrupts (funcall function)))
 188           (when got-it
 189             (release-mutex mutex))))))
 190
 191
 192
 193   (defun call-with-recursive-spinlock (function spinlock)
 194     (declare (function function))
 195     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
 196           (got-it nil))
 197       (without-interrupts
 198         (unwind-protect
 199              (when (or inner-lock-p (setf got-it (allow-with-interrupts
 200                                                   (get-spinlock spinlock))))
 201                (with-local-interrupts (funcall function)))
 202           (when got-it
 203             (release-spinlock spinlock)))))))