X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fthread.lisp;h=f0c51103e702a1a77c1c77a902f062040a994b21;hb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;hp=9671d60f3d5aa1f9d93a4058a9db9c6a36c1df5b;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 9671d60..f0c5110 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -11,53 +11,168 @@ (in-package "SB!THREAD") -(sb!xc:defmacro with-mutex ((mutex &key value (wait-p t)) &body body) +(def!struct mutex + #!+sb-doc + "Mutex type." + (name nil :type (or null simple-string)) + (value nil) + #!+(and sb-lutex sb-thread) + (lutex (make-lutex))) + +(def!struct spinlock + #!+sb-doc + "Spinlock type." + (name nil :type (or null simple-string)) + (value nil)) + +(sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t)) + &body body) #!+sb-doc "Acquire MUTEX for the dynamic scope of BODY, setting it to NEW-VALUE or some suitable default value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep until it is available" - #!-sb-thread (declare (ignore mutex value wait-p)) - #!+sb-thread - (with-unique-names (got) - `(let ((,got (get-mutex ,mutex ,value ,wait-p))) - (when ,got - (unwind-protect - (locally ,@body) - (release-mutex ,mutex))))) - ;; KLUDGE: this separate expansion for (NOT SB-THREAD) is not - ;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented. - ;; However, there would be a (possibly slight) performance hit in - ;; using them. - #!-sb-thread - `(locally ,@body)) + `(call-with-mutex + (lambda () ,@body) + ,mutex + ,value + ,wait-p)) (sb!xc:defmacro with-recursive-lock ((mutex) &body body) #!+sb-doc "Acquires MUTEX for the dynamic scope of BODY. Within that scope -further recursive lock attempts for the same mutex succeed. However, -it is an error to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same -mutex." - #!-sb-thread (declare (ignore mutex)) - #!+sb-thread - (with-unique-names (cfp inner-lock) - `(let ((,cfp (sb!kernel:current-fp)) - (,inner-lock - (and (mutex-value ,mutex) - (sb!vm:control-stack-pointer-valid-p - (sb!sys:int-sap - (sb!kernel:get-lisp-obj-address (mutex-value ,mutex))))))) - (unless ,inner-lock - ;; this punning with MAKE-LISP-OBJ depends for its safety on - ;; the frame pointer being a lispobj-aligned integer. While - ;; it is, then MAKE-LISP-OBJ will always return a FIXNUM, so - ;; we're safe to do that. Should this ever change, this - ;; MAKE-LISP-OBJ could return something that looks like a - ;; pointer, but pointing into neverneverland, which will - ;; confuse GC completely. -- CSR, 2003-06-03 - (get-mutex ,mutex (sb!kernel:make-lisp-obj (sb!sys:sap-int ,cfp)))) - (unwind-protect - (locally ,@body) - (unless ,inner-lock - (release-mutex ,mutex))))) - #!-sb-thread - `(locally ,@body)) +further recursive lock attempts for the same mutex succeed. It is +allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex +provided the default value is used for the mutex." + `(call-with-recursive-lock + (lambda () ,@body) + ,mutex)) + +(sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body) + `(call-with-recursive-spinlock + (lambda () ,@body) + ,spinlock)) + +(sb!xc:defmacro with-spinlock ((spinlock) &body body) + `(call-with-spinlock + (lambda () ,@body) + ,spinlock)) + +;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not +;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented. +;;; However, there would be a (possibly slight) performance hit in +;;; using them. +#!-sb-thread +(progn + (defun call-with-system-mutex (function mutex &optional without-gcing-p) + (declare (ignore mutex) + (function function)) + (if without-gcing-p + (without-gcing + (funcall function)) + (without-interrupts + (funcall function)))) + + (defun call-with-system-spinlock (function lock &optional without-gcing-p) + (declare (ignore lock) + (function function)) + (if without-gcing-p + (without-gcing + (funcall function)) + (without-interrupts + (funcall function)))) + + (defun call-with-mutex (function mutex value waitp) + (declare (ignore mutex value waitp) + (function function)) + (funcall function)) + + (defun call-with-recursive-lock (function mutex) + (declare (ignore mutex) (function function)) + (funcall function)) + + (defun call-with-spinlock (function spinlock) + (declare (ignore spinlock) (function function)) + (funcall function)) + + (defun call-with-recursive-spinlock (function spinlock) + (declare (ignore spinlock) (function function)) + (funcall function))) + +#!+sb-thread +(progn + (defun call-with-system-mutex (function mutex &optional without-gcing-p) + (declare (function function)) + (flet ((%call-with-system-mutex () + (let (got-it) + (unwind-protect + (when (setf got-it (get-mutex mutex)) + (funcall function)) + (when got-it + (release-mutex mutex)))))) + (if without-gcing-p + (without-gcing + (%call-with-system-mutex)) + (without-interrupts + (%call-with-system-mutex))))) + + (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p) + (declare (function function)) + (flet ((%call-with-system-spinlock () + (let ((inner-lock-p (eq *current-thread* (spinlock-value lock))) + (got-it nil)) + (unwind-protect + (when (or inner-lock-p (setf got-it (get-spinlock lock))) + (funcall function)) + (when got-it + (release-spinlock lock)))))) + (if without-gcing-p + (without-gcing + (%call-with-system-spinlock)) + (without-interrupts + (%call-with-system-spinlock))))) + + (defun call-with-mutex (function mutex value waitp) + (declare (function function)) + (let ((got-it nil)) + (without-interrupts + (unwind-protect + (when (setq got-it (allow-with-interrupts + (get-mutex mutex value waitp))) + (with-local-interrupts (funcall function))) + (when got-it + (release-mutex mutex)))))) + + (defun call-with-recursive-lock (function mutex) + (declare (function function)) + (let ((inner-lock-p (eq (mutex-value mutex) *current-thread*)) + (got-it nil)) + (without-interrupts + (unwind-protect + (when (or inner-lock-p (setf got-it (allow-with-interrupts + (get-mutex mutex)))) + (with-local-interrupts (funcall function))) + (when got-it + (release-mutex mutex)))))) + + (defun call-with-spinlock (function spinlock) + (declare (function function)) + (let ((got-it nil)) + (without-interrupts + (unwind-protect + (when (setf got-it (allow-with-interrupts + (get-spinlock spinlock))) + (with-local-interrupts (funcall function))) + (when got-it + (release-spinlock spinlock)))))) + + (defun call-with-recursive-spinlock (function spinlock) + (declare (function function)) + (let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*)) + (got-it nil)) + (without-interrupts + (unwind-protect + (when (or inner-lock-p (setf got-it (allow-with-interrupts + (get-spinlock spinlock)))) + (with-local-interrupts (funcall function))) + (when got-it + (release-spinlock spinlock)))))))