X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fthread.lisp;h=5dfb84e6eb6c0feaf5aac3d3b23193c84e0c2c5f;hb=5abf3b4b94c8c2315777e63729293395dc54992c;hp=54092dedee2cebadc2ba5d53d8818e06c1c5b13b;hpb=496071a75429677a2c064e4995c379d3ba6ec458;p=sbcl.git diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 54092de..5dfb84e 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -11,21 +11,47 @@ (in-package "SB!THREAD") +(def!type thread-name () + 'simple-string) + +(def!struct (thread (:constructor %make-thread)) + #!+sb-doc + "Thread type. Do not rely on threads being structs as it may change +in future versions." + (name nil :type (or thread-name null)) + (%alive-p nil :type boolean) + (os-thread nil :type (or integer null)) + (interruptions nil :type list) + (result nil :type list) + (interruptions-lock + (make-mutex :name "thread interruptions lock") + :type mutex) + (result-lock + (make-mutex :name "thread result lock") + :type mutex) + waiting-for) + (def!struct mutex #!+sb-doc "Mutex type." - (name nil :type (or null simple-string)) + (name nil :type (or null thread-name)) (%owner nil :type (or null thread)) #!+(and (not sb-lutex) sb-thread) - (state 0 :type fixnum) + (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." + "Current owner of the mutex, NIL if the mutex is free. May return a +stale value, use MUTEX-OWNER instead." (mutex-%owner mutex)) +(defun holding-mutex-p (mutex) + "Test whether the current thread is holding MUTEX." + ;; This is about the only use for which a stale value of owner is + ;; sufficient. + (eq sb!thread:*current-thread* (mutex-%owner mutex))) + (defsetf mutex-value set-mutex-value) (declaim (inline set-mutex-value)) @@ -42,15 +68,35 @@ (def!struct spinlock #!+sb-doc "Spinlock type." - (name nil :type (or null simple-string)) + (name nil :type (or null thread-name)) (value nil)) +(sb!xc:defmacro without-thread-waiting-for ((&key already-without-interrupts) &body body) + (with-unique-names (thread prev) + (let ((without (if already-without-interrupts + 'progn + 'without-interrupts)) + (with (if already-without-interrupts + 'progn + 'with-local-interrupts))) + `(let* ((,thread *current-thread*) + (,prev (thread-waiting-for ,thread))) + (flet ((exec () ,@body)) + (if ,prev + (,without + (unwind-protect + (progn + (setf (thread-waiting-for ,thread) nil) + (,with (exec))) + (setf (thread-waiting-for ,thread) ,prev))) + (exec))))))) + (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" + "Acquire MUTEX for the dynamic scope of BODY, setting it to 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" `(dx-flet ((with-mutex-thunk () ,@body)) (call-with-mutex #'with-mutex-thunk @@ -58,7 +104,9 @@ and the mutex is in use, sleep until it is available" ,value ,wait-p))) -(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts) &body body) +(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) @@ -109,25 +157,44 @@ provided the default value is used for the mutex." #'with-spinlock-thunk ,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. +(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)) + #!-sb-thread (progn (macrolet ((def (name &optional variant) - `(defun ,(if variant (symbolicate name "/" variant) name) (function lock) + `(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)))) + `(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)) @@ -154,34 +221,10 @@ provided the default value is used for the mutex." ;;; 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 - (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) - #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells)) - (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)) (without-interrupts (dx-let (got-it) - #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells)) (unwind-protect (when (setf got-it (get-spinlock spinlock)) (funcall function)) @@ -189,14 +232,18 @@ provided the default value is used for the mutex." (release-spinlock spinlock)))))) (macrolet ((def (name &optional variant) - `(defun ,(if variant (symbolicate name "/" variant) name) (function spinlock) + `(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))) + (dx-let ((inner-lock-p + (eq *current-thread* + (spinlock-value spinlock))) (got-it nil)) - #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells)) (unwind-protect - (when (or inner-lock-p (setf got-it (get-spinlock spinlock))) + (when (or inner-lock-p + (setf got-it + (get-spinlock spinlock))) (funcall function)) (when got-it (release-spinlock spinlock)))))) @@ -212,7 +259,6 @@ provided the default value is used for the mutex." (defun call-with-spinlock (function spinlock) (declare (function function)) (dx-let ((got-it nil)) - #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells)) (without-interrupts (unwind-protect (when (setf got-it (allow-with-interrupts @@ -224,7 +270,6 @@ provided the default value is used for the mutex." (defun call-with-mutex (function mutex value waitp) (declare (function function)) (dx-let ((got-it nil)) - #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells)) (without-interrupts (unwind-protect (when (setq got-it (allow-with-interrupts @@ -237,7 +282,6 @@ provided the default value is used for the mutex." (declare (function function)) (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*)) (got-it nil)) - #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells)) (without-interrupts (unwind-protect (when (or inner-lock-p (setf got-it (allow-with-interrupts @@ -246,13 +290,10 @@ provided the default value is used for the mutex." (when got-it (release-mutex mutex)))))) - - (defun call-with-recursive-spinlock (function spinlock) (declare (function function)) (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*)) (got-it nil)) - #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells)) (without-interrupts (unwind-protect (when (or inner-lock-p (setf got-it (allow-with-interrupts