X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fthread.lisp;h=3d1ecd4086c76206f96621797818c88c0c1c7a2a;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=4d6a83cfa3bb1bbcccff2b816a80718e8fcd782a;hpb=7bb4c044e09f02a2115095af3733b0673b98a726;p=sbcl.git diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 4d6a83c..3d1ecd4 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -11,6 +11,9 @@ (in-package "SB!THREAD") +(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!xc:proclaim '(sb!ext:always-bound *current-thread*))) + (def!type thread-name () 'simple-string) @@ -20,6 +23,7 @@ in future versions." (name nil :type (or thread-name null)) (%alive-p nil :type boolean) + (%ephemeral-p nil :type boolean) (os-thread nil :type (or integer null)) (interruptions nil :type list) (result nil :type list) @@ -31,6 +35,21 @@ in future versions." :type mutex) waiting-for) +(def!struct (foreign-thread + (:include thread) + (:conc-name "THREAD-")) + #!+sb-doc + "Type of native threads which are attached to the runtime as Lisp threads +temporarily.") + +#!+(and sb-safepoint-strictly (not win32)) +(def!struct (signal-handling-thread + (:include foreign-thread) + (:conc-name "THREAD-")) + #!+sb-doc + "Asynchronous signal handling thread." + (signal-number nil :type integer)) + (def!struct mutex #!+sb-doc "Mutex type." @@ -94,8 +113,8 @@ stale value, use MUTEX-OWNER instead." ,@body)) (sb!xc:defmacro with-spinlock ((lock) &body body) - (deprecation-warning :early "1.0.53.11" 'with-recursive-spinlock 'with-mutex) - `(with-lock (,lock) + (deprecation-warning :early "1.0.53.11" 'with-spinlock 'with-mutex) + `(with-mutex (,lock) ,@body)) (sb!xc:defmacro without-thread-waiting-for ((&key already-without-interrupts) &body body) @@ -118,22 +137,39 @@ stale value, use MUTEX-OWNER instead." (setf (thread-waiting-for ,thread) nil) (barrier (:write)) (,with (exec))) - (setf (thread-waiting-for ,thread) ,prev) - (barrier (:write)))) + ;; If we were waiting on a waitqueue, this becomes a bogus + ;; wakeup. + (when (mutex-p ,prev) + (setf (thread-waiting-for ,thread) ,prev) + (barrier (:write))))) (exec))))))) -(sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t)) +(sb!xc:defmacro with-mutex ((mutex &key (wait-p t) timeout value) &body body) #!+sb-doc - "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" + "Acquire MUTEX for the dynamic scope of BODY. If WAIT-P is true (the default), +and the MUTEX is not immediately available, sleep until it is available. + +If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long +the system should try to acquire the lock in the contested case. + +If the mutex isn't acquired succesfully due to either WAIT-P or TIMEOUT, the +body is not executed, and WITH-MUTEX returns NIL. + +Otherwise body is executed with the mutex held by current thread, and +WITH-MUTEX returns the values of BODY. + +Historically WITH-MUTEX also accepted a VALUE argument, which when provided +was used as the new owner of the mutex instead of the current thread. This is +no longer supported: if VALUE is provided, it must be either NIL or the +current thread." `(dx-flet ((with-mutex-thunk () ,@body)) (call-with-mutex #'with-mutex-thunk ,mutex ,value - ,wait-p))) + ,wait-p + ,timeout))) (sb!xc:defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts) @@ -148,16 +184,30 @@ is in use, sleep until it is available" #'with-system-mutex-thunk ,mutex))) -(sb!xc:defmacro with-recursive-lock ((mutex) &body body) +(sb!xc:defmacro with-recursive-lock ((mutex &key (wait-p t) timeout) &body body) #!+sb-doc - "Acquires MUTEX for the dynamic scope of BODY. Within that scope -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." + "Acquire MUTEX for the dynamic scope of BODY. + +If WAIT-P is true (the default), and the MUTEX is not immediately available or +held by the current thread, sleep until it is available. + +If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long +the system should try to acquire the lock in the contested case. + +If the mutex isn't acquired succesfully due to either WAIT-P or TIMEOUT, the +body is not executed, and WITH-RECURSIVE-LOCK returns NIL. + +Otherwise body is executed with the mutex held by current thread, and +WITH-RECURSIVE-LOCK returns the values of BODY. + +Unlike WITH-MUTEX, which signals an error on attempt to re-acquire an already +held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed." `(dx-flet ((with-recursive-lock-thunk () ,@body)) (call-with-recursive-lock #'with-recursive-lock-thunk - ,mutex))) + ,mutex + ,wait-p + ,timeout))) (sb!xc:defmacro with-recursive-system-lock ((lock &key without-gcing) @@ -177,7 +227,7 @@ provided the default value is used for the mutex." (flet ((%call-with-system-mutex () (dx-let (got-it) (unwind-protect - (when (setf got-it (get-mutex mutex)) + (when (setf got-it (grab-mutex mutex)) (funcall function)) (when got-it (release-mutex mutex)))))) @@ -196,13 +246,17 @@ provided the default value is used for the mutex." #!-sb-thread (progn - (defun call-with-mutex (function mutex value waitp) - (declare (ignore mutex value waitp) + (defun call-with-mutex (function mutex value waitp timeout) + (declare (ignore mutex waitp timeout) (function function)) + (unless (or (null value) (eq *current-thread* value)) + (error "~S called with non-nil :VALUE that isn't the current thread." + 'with-mutex)) (funcall function)) - (defun call-with-recursive-lock (function mutex) - (declare (ignore mutex) (function function)) + (defun call-with-recursive-lock (function mutex waitp timeout) + (declare (ignore mutex waitp timeout) + (function function)) (funcall function)) (defun call-with-recursive-system-lock (function lock) @@ -220,25 +274,30 @@ 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 - (defun call-with-mutex (function mutex value waitp) + (defun call-with-mutex (function mutex value waitp timeout) (declare (function function)) + (unless (or (null value) (eq *current-thread* value)) + (error "~S called with non-nil :VALUE that isn't the current thread." + 'with-mutex)) (dx-let ((got-it nil)) (without-interrupts (unwind-protect (when (setq got-it (allow-with-interrupts - (get-mutex mutex value waitp))) + (grab-mutex mutex :waitp waitp + :timeout timeout))) (with-local-interrupts (funcall function))) (when got-it (release-mutex mutex)))))) - (defun call-with-recursive-lock (function mutex) + (defun call-with-recursive-lock (function mutex waitp timeout) (declare (function function)) (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 - (get-mutex mutex)))) + (grab-mutex mutex :waitp waitp + :timeout timeout)))) (with-local-interrupts (funcall function))) (when got-it (release-mutex mutex))))))