X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fthread.lisp;h=6e6ebecd26041488d5f5170fba61f18ca45bc466;hb=5d5894082c39ca44da75d38859d669c7b2108f6a;hp=7cf49b8e4efb04f7d8786974e3802996d36564fa;hpb=617d4fa1db5a4a11564e7c59bfb684c7eb25633d;p=sbcl.git diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 7cf49b8..6e6ebec 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -15,10 +15,30 @@ #!+sb-doc "Mutex type." (name nil :type (or null simple-string)) - (value nil) + (%owner nil :type (or null thread)) + #!+(and (not sb-lutex) sb-thread) + (state 0 :type fixnum) #!+(and sb-lutex sb-thread) (lutex (make-lutex))) +;;; FIXME: We probably want to rename the accessor MUTEX-OWNER. +(defun mutex-value (mutex) + "Current owner of the mutex, NIL if the mutex is free." + (mutex-%owner mutex)) + +(defsetf mutex-value set-mutex-value) + +(declaim (inline set-mutex-value)) +(defun set-mutex-value (mutex value) + (declare (ignore mutex value)) + (error "~S is no longer supported." '(setf mutex-value))) + +(define-compiler-macro set-mutex-value (&whole form mutex value) + (declare (ignore mutex value)) + (warn "~S is no longer supported, and will signal an error at runtime." + '(setf mutex-value)) + form) + (def!struct spinlock #!+sb-doc "Spinlock type." @@ -31,17 +51,29 @@ "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" - `(call-with-mutex - (lambda () ,@body) - ,mutex - ,value - ,wait-p)) - -(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing) &body body) - `(call-with-system-mutex - (lambda () ,@body) - ,mutex - ,without-gcing)) + `(dx-flet ((with-mutex-thunk () ,@body)) + (call-with-mutex + #'with-mutex-thunk + ,mutex + ,value + ,wait-p))) + +(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts) &body body) + `(dx-flet ((with-system-mutex-thunk () ,@body)) + (,(cond (without-gcing + 'call-with-system-mutex/without-gcing) + (allow-with-interrupts + 'call-with-system-mutex/allow-with-interrupts) + (t + 'call-with-system-mutex)) + #'with-system-mutex-thunk + ,mutex))) + +(sb!xc:defmacro with-system-spinlock ((spinlock &key) &body body) + `(dx-flet ((with-system-spinlock-thunk () ,@body)) + (call-with-system-spinlock + #'with-system-spinlock-thunk + ,spinlock))) (sb!xc:defmacro with-recursive-lock ((mutex) &body body) #!+sb-doc @@ -49,26 +81,33 @@ and the mutex is in use, sleep until it is available" 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)) + `(dx-flet ((with-recursive-lock-thunk () ,@body)) + (call-with-recursive-lock + #'with-recursive-lock-thunk + ,mutex))) (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body) - `(call-with-recursive-spinlock - (lambda () ,@body) - ,spinlock)) + `(dx-flet ((with-recursive-spinlock-thunk () ,@body)) + (call-with-recursive-spinlock + #'with-recursive-spinlock-thunk + ,spinlock))) -(sb!xc:defmacro with-recursive-system-spinlock ((spinlock &key without-gcing) +(sb!xc:defmacro with-recursive-system-spinlock ((spinlock + &key without-gcing) &body body) - `(call-with-recursive-system-spinlock - (lambda () ,@body) - ,spinlock - ,without-gcing)) + `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body)) + (,(cond (without-gcing + 'call-with-recursive-system-spinlock/without-gcing) + (t + 'call-with-recursive-system-spinlock)) + #'with-recursive-system-spinlock-thunk + ,spinlock))) (sb!xc:defmacro with-spinlock ((spinlock) &body body) - `(call-with-spinlock - (lambda () ,@body) - ,spinlock)) + `(dx-flet ((with-spinlock-thunk () ,@body)) + (call-with-spinlock + #'with-spinlock-thunk + ,spinlock))) ;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not ;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented. @@ -76,24 +115,22 @@ provided the default value is used for the mutex." ;;; 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-recursive-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)))) + (macrolet ((def (name &optional variant) + `(defun ,(if variant (symbolicate name "/" variant) name) (function lock) + (declare (ignore lock) (function function)) + ,(ecase variant + (:without-gcing + `(without-gcing (funcall function))) + (:allow-with-interrupts + `(without-interrupts (allow-with-interrupts (funcall function)))) + ((nil) + `(without-interrupts (funcall function))))))) + (def call-with-system-mutex) + (def call-with-system-mutex :without-gcing) + (def call-with-system-mutex :allow-with-interrupts) + (def call-with-system-spinlock) + (def call-with-recursive-system-spinlock) + (def call-with-recursive-system-spinlock :without-gcing)) (defun call-with-mutex (function mutex value waitp) (declare (ignore mutex value waitp) @@ -113,41 +150,76 @@ provided the default value is used for the mutex." (funcall function))) #!+sb-thread +;;; KLUDGE: These need to use DX-LET, because the cleanup form that +;;; closes over GOT-IT causes a value-cell to be allocated for it -- +;;; and we prefer that to go on the stack since it can. (progn - (defun call-with-system-mutex (function mutex &optional without-gcing-p) + (macrolet ((def (name &optional variant) + `(defun ,(if variant (symbolicate name "/" variant) name) (function mutex) + (declare (function function)) + (flet ((%call-with-system-mutex () + (dx-let (got-it) + (unwind-protect + (when (setf got-it (get-mutex mutex)) + (funcall function)) + (when got-it + (release-mutex mutex)))))) + (declare (inline %call-with-system-mutex)) + ,(ecase variant + (:without-gcing + `(without-gcing (%call-with-system-mutex))) + (:allow-with-interrupts + `(without-interrupts (allow-with-interrupts (%call-with-system-mutex)))) + ((nil) + `(without-interrupts (%call-with-system-mutex)))))))) + (def call-with-system-mutex) + (def call-with-system-mutex :without-gcing) + (def call-with-system-mutex :allow-with-interrupts)) + + (defun call-with-system-spinlock (function spinlock) (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) + (without-interrupts + (dx-let (got-it) + (unwind-protect + (when (setf got-it (get-spinlock spinlock)) + (funcall function)) + (when got-it + (release-spinlock spinlock)))))) + + (macrolet ((def (name &optional variant) + `(defun ,(if variant (symbolicate name "/" variant) name) (function spinlock) + (declare (function function)) + (flet ((%call-with-system-spinlock () + (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value spinlock))) + (got-it nil)) + (unwind-protect + (when (or inner-lock-p (setf got-it (get-spinlock spinlock))) + (funcall function)) + (when got-it + (release-spinlock spinlock)))))) + (declare (inline %call-with-system-spinlock)) + ,(ecase variant + (:without-gcing + `(without-gcing (%call-with-system-spinlock))) + ((nil) + `(without-interrupts (%call-with-system-spinlock)))))))) + (def call-with-recursive-system-spinlock) + (def call-with-recursive-system-spinlock :without-gcing)) + + (defun call-with-spinlock (function spinlock) (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))))) + (dx-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-mutex (function mutex value waitp) (declare (function function)) - (let ((got-it nil)) + (dx-let ((got-it nil)) (without-interrupts (unwind-protect (when (setq got-it (allow-with-interrupts @@ -158,8 +230,8 @@ provided the default value is used for the mutex." (defun call-with-recursive-lock (function mutex) (declare (function function)) - (let ((inner-lock-p (eq (mutex-value mutex) *current-thread*)) - (got-it nil)) + (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*)) + (got-it nil)) (without-interrupts (unwind-protect (when (or inner-lock-p (setf got-it (allow-with-interrupts @@ -168,20 +240,11 @@ provided the default value is used for the mutex." (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*)) + (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*)) (got-it nil)) (without-interrupts (unwind-protect