X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=218e355a878b089198e2d0efb45fbc1be4caab1f;hb=fe420bb47ea909070ee82c6e48642c9ff41dbcc8;hp=c2fe73c43a1948ed1ba6b347b6c8969e4805bd0f;hpb=776a2f1275624352bbba37b03dabea03ec13a9e5;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index c2fe73c..218e355 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -60,12 +60,7 @@ in future versions." (defvar *all-threads-lock* (make-mutex :name "all threads lock")) (defmacro with-all-threads-lock (&body body) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex (*all-threads-lock*) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) *all-threads-lock*)) (defun list-all-threads () #!+sb-doc @@ -115,25 +110,25 @@ in future versions." (declaim (inline %lutex-init %lutex-wait %lutex-wake %lutex-lock %lutex-unlock)) - (sb!alien:define-alien-routine ("lutex_init" %lutex-init) + (define-alien-routine ("lutex_init" %lutex-init) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait) + (define-alien-routine ("lutex_wait" %lutex-wait) int (queue-lutex unsigned-long) (mutex-lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake) + (define-alien-routine ("lutex_wake" %lutex-wake) int (lutex unsigned-long) (n int)) - (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock) + (define-alien-routine ("lutex_lock" %lutex-lock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock) + (define-alien-routine ("lutex_trylock" %lutex-trylock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock) + (define-alien-routine ("lutex_unlock" %lutex-unlock) int (lutex unsigned-long)) - (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy) + (define-alien-routine ("lutex_destroy" %lutex-destroy) int (lutex unsigned-long)) ;; FIXME: Defining a whole bunch of alien-type machinery just for @@ -160,13 +155,17 @@ in future versions." #!-sb-lutex (progn - (declaim (inline futex-wait futex-wake)) + (declaim (inline futex-wait %futex-wait futex-wake)) - (sb!alien:define-alien-routine "futex_wait" + (define-alien-routine ("futex_wait" %futex-wait) int (word unsigned-long) (old-value unsigned-long) (to-sec long) (to-usec unsigned-long)) - (sb!alien:define-alien-routine "futex_wake" + (defun futex-wait (word old to-sec to-usec) + (with-interrupts + (%futex-wait word old to-sec to-usec))) + + (define-alien-routine "futex_wake" int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts @@ -182,24 +181,28 @@ in future versions." (declare (type (unsigned-byte 27) n)) (sb!vm::current-thread-offset-sap n)) -;;;; spinlocks -(define-structure-slot-compare-and-swap - compare-and-swap-spinlock-value - :structure spinlock - :slot value) - (declaim (inline get-spinlock release-spinlock)) +;; Should always be called with interrupts disabled. (defun get-spinlock (spinlock) (declare (optimize (speed 3) (safety 0))) (let* ((new *current-thread*) - (old (compare-and-swap-spinlock-value spinlock nil new))) + (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new))) (when old (when (eq old new) (error "Recursive lock attempt on ~S." spinlock)) #!+sb-thread - (loop while (compare-and-swap-spinlock-value spinlock nil new)))) - t) + (flet ((cas () + (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) + (return-from get-spinlock t)))) + (if (and (not *interrupts-enabled*) *allow-with-interrupts*) + ;; If interrupts are enabled, but we are allowed to enabled them, + ;; check for pending interrupts every once in a while. + (loop + (loop repeat 128 do (cas)) ; 128 is arbitrary here + (sb!unix::%check-interrupts)) + (loop (cas))))) + t)) (defun release-spinlock (spinlock) (declare (optimize (speed 3) (safety 0))) @@ -212,83 +215,131 @@ in future versions." (setf (fdocumentation 'make-mutex 'function) "Create a mutex." (fdocumentation 'mutex-name 'function) - "The name of the mutex. Setfable." - (fdocumentation 'mutex-value 'function) - "The value of the mutex. NIL if the mutex is free. Setfable.") + "The name of the mutex. Setfable.") #!+(and sb-thread (not sb-lutex)) (progn - (define-structure-slot-addressor mutex-value-address - :structure mutex - :slot value) - (define-structure-slot-compare-and-swap - compare-and-swap-mutex-value + (define-structure-slot-addressor mutex-state-address :structure mutex - :slot value)) - -(defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t)) + :slot state) + ;; Important: current code assumes these are fixnums or other + ;; lisp objects that don't need pinning. + (defconstant +lock-free+ 0) + (defconstant +lock-taken+ 1) + (defconstant +lock-contested+ 2)) + +(defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp t)) #!+sb-doc - "Acquire MUTEX, setting it to NEW-VALUE or some suitable default -value if NIL. If WAITP is non-NIL and the mutex is in use, sleep -until it is available." - (declare (type mutex mutex) (optimize (speed 3))) - (/show0 "Entering GET-MUTEX") - (unless new-value - (setq new-value *current-thread*)) - #!-sb-thread - (let ((old (mutex-value mutex))) - (when (and old waitp) - (error "In unithread mode, mutex ~S was requested with WAITP ~S and ~ - new-value ~S, but has already been acquired (with value ~S)." - mutex waitp new-value old)) - (setf (mutex-value mutex) new-value) - t) + "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If +NEW-OWNER is NIL, it defaults to the current thread. If WAITP is +non-NIL and the mutex is in use, sleep until it is available. + +Note: using GET-MUTEX to assign a MUTEX to another thread then the +current one is not recommended, and liable to be deprecated. + +GET-MUTEX is not interrupt safe. The correct way to call it is: + + (WITHOUT-INTERRUPTS + ... + (ALLOW-WITH-INTERRUPTS (GET-MUTEX ...)) + ...) + +WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the +call while the mutex is in an inconsistent state while +ALLOW-WITH-INTERRUPTS allows the call to be interrupted from sleep. + +It is recommended that you use WITH-MUTEX instead of calling GET-MUTEX +directly." + (declare (type mutex mutex) (optimize (speed 3)) + #!-sb-thread (ignore waitp)) + (unless new-owner + (setq new-owner *current-thread*)) + (when (eql new-owner (mutex-%owner mutex)) + (error "Recursive lock attempt ~S." mutex)) #!+sb-thread (progn - (when (eql new-value (mutex-value mutex)) - (warn "recursive lock attempt ~S~%" mutex) - (format *debug-io* "Thread: ~A~%" *current-thread*) - (sb!debug:backtrace most-positive-fixnum *debug-io*) - (force-output *debug-io*)) ;; FIXME: Lutexes do not currently support deadlines, as at least ;; on Darwin pthread_foo_timedbar functions are not supported: ;; this means that we probably need to use the Carbon multiprocessing ;; functions on Darwin. + ;; + ;; FIXME: This is definitely not interrupt safe: what happens if + ;; we get hit (1) during the lutex calls (ok, they may be safe, + ;; but has that been checked?) (2) after the lutex call, but + ;; before setting the mutex owner. #!+sb-lutex (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) (if waitp - (%lutex-lock lutex) + (with-interrupts (%lutex-lock lutex)) (%lutex-trylock lutex)))) - (setf (mutex-value mutex) new-value)) + (setf (mutex-%owner mutex) new-owner) + t) #!-sb-lutex - (let (old) - (when (and (setf old (compare-and-swap-mutex-value mutex nil new-value)) - waitp) - (loop while old - do (multiple-value-bind (to-sec to-usec) (decode-timeout nil) - (when (= 1 (with-pinned-objects (mutex old) - (futex-wait (mutex-value-address mutex) - (get-lisp-obj-address old) - (or to-sec -1) - (or to-usec 0)))) - (signal-deadline))) - (setf old (compare-and-swap-mutex-value mutex nil new-value)))) - (not old)))) + (let ((old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-free+ + +lock-taken+))) + (unless (or (eql +lock-free+ old) (not waitp)) + (tagbody + :retry + (when (or (eql +lock-contested+ old) + (not (eql +lock-free+ + (sb!ext:compare-and-swap (mutex-state mutex) + +lock-taken+ + +lock-contested+)))) + ;; Wait on the contested lock. + (multiple-value-bind (to-sec to-usec) (decode-timeout nil) + (when (= 1 (with-pinned-objects (mutex) + (futex-wait (mutex-state-address mutex) + (get-lisp-obj-address +lock-contested+) + (or to-sec -1) + (or to-usec 0)))) + (signal-deadline)))) + (setf old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-free+ + +lock-contested+)) + ;; Did we get it? + (unless (eql +lock-free+ old) + (go :retry)))) + (cond ((eql +lock-free+ old) + (let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex) + nil new-owner))) + (when prev + (bug "Old owner in free mutex: ~S" prev)) + t)) + (waitp + (bug "Failed to acquire lock with WAITP.")))))) (defun release-mutex (mutex) #!+sb-doc "Release MUTEX by setting it to NIL. Wake up threads waiting for -this mutex." +this mutex. + +RELEASE-MUTEX is not interrupt safe: interrupts should be disabled +around calls to it. + +Signals a WARNING is current thread is not the current owner of the +mutex." (declare (type mutex mutex)) - (/show0 "Entering RELEASE-MUTEX") - (setf (mutex-value mutex) nil) + ;; Order matters: set owner to NIL before releasing state. + (let* ((self *current-thread*) + (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil))) + (unless (eql self old-owner) + (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner) + (setf (mutex-%owner mutex) nil))) #!+sb-thread (progn #!+sb-lutex (with-lutex-address (lutex (mutex-lutex mutex)) (%lutex-unlock lutex)) #!-sb-lutex - (futex-wake (mutex-value-address mutex) 1))) + (let ((old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-taken+ +lock-free+))) + (when (eql old +lock-contested+) + (sb!ext:compare-and-swap (mutex-state mutex) + +lock-contested+ +lock-free+) + (with-pinned-objects (mutex) + (futex-wake (mutex-state-address mutex) 1)))) + nil)) ;;;; waitqueues/condition variables @@ -324,20 +375,21 @@ time we reacquire MUTEX and return to the caller." (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread - (let ((value (mutex-value mutex))) + (let ((owner (mutex-%owner mutex))) (/show0 "CONDITION-WAITing") #!+sb-lutex (progn - (setf (mutex-value mutex) nil) + ;; FIXME: This doesn't look interrupt safe! + (setf (mutex-%owner mutex) nil) (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) (%lutex-wait queue-lutex-address mutex-lutex-address))) - (setf (mutex-value mutex) value)) + (setf (mutex-%owner mutex) owner)) #!-sb-lutex (unwind-protect (let ((me *current-thread*)) - ;; XXX we should do something to ensure that the result of this setf - ;; is visible to all CPUs + ;; FIXME: should we do something to ensure that the result + ;; of this setf is visible to all CPUs? (setf (waitqueue-data queue) me) (release-mutex mutex) ;; Now we go to sleep using futex-wait. If anyone else @@ -357,7 +409,7 @@ time we reacquire MUTEX and return to the caller." ;; before returning. Ideally, in the case of an unhandled signal, ;; we should do them before entering the debugger, but this is ;; better than nothing. - (get-mutex mutex value)))) + (get-mutex mutex owner)))) (defun condition-notify (queue &optional (n 1)) #!+sb-doc @@ -395,41 +447,48 @@ time we reacquire MUTEX and return to the caller." ;;;; semaphores -(defstruct (semaphore (:constructor %make-semaphore)) +(defstruct (semaphore (:constructor %make-semaphore (name %count))) #!+sb-doc - "Semaphore type." + "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT +should be considered an implementation detail, and may change in the +future." (name nil :type (or null simple-string)) - (count 0 :type (integer 0)) + (%count 0 :type (integer 0)) (mutex (make-mutex)) (queue (make-waitqueue))) +(setf (fdocumentation 'semaphore-name 'function) + "The name of the semaphore INSTANCE. Setfable.") + +(declaim (inline semaphore-count)) +(defun semaphore-count (instance) + "Returns the current count of the semaphore INSTANCE." + (semaphore-%count instance)) + (defun make-semaphore (&key name (count 0)) #!+sb-doc - "Create a semaphore with the supplied COUNT." - (%make-semaphore :name name :count count)) - -(setf (fdocumentation 'semaphore-name 'function) - "The name of the semaphore. Setfable.") + "Create a semaphore with the supplied COUNT and NAME." + (%make-semaphore name count)) -(defun wait-on-semaphore (sem) +(defun wait-on-semaphore (semaphore) #!+sb-doc - "Decrement the count of SEM if the count would not be negative. Else -block until the semaphore can be decremented." + "Decrement the count of SEMAPHORE if the count would not be +negative. Else blocks until the semaphore can be decremented." ;; a more direct implementation based directly on futexes should be ;; possible - (with-mutex ((semaphore-mutex sem)) - (loop until (> (semaphore-count sem) 0) - do (condition-wait (semaphore-queue sem) (semaphore-mutex sem)) - finally (decf (semaphore-count sem))))) + (with-mutex ((semaphore-mutex semaphore)) + (loop until (> (semaphore-%count semaphore) 0) + do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore)) + finally (decf (semaphore-%count semaphore))))) -(defun signal-semaphore (sem &optional (n 1)) +(defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc - "Increment the count of SEM by N. If there are threads waiting on -this semaphore, then N of them is woken up." - (declare (type (and fixnum (integer 1)) n)) - (with-mutex ((semaphore-mutex sem)) - (when (= n (incf (semaphore-count sem) n)) - (condition-notify (semaphore-queue sem) n)))) + "Increment the count of SEMAPHORE by N. If there are threads waiting +on this semaphore, then N of them is woken up." + (declare (type (integer 1) n)) + (with-mutex ((semaphore-mutex semaphore)) + (when (= n (incf (semaphore-%count semaphore) n)) + (condition-notify (semaphore-queue semaphore) n)))) ;;;; job control, independent listeners @@ -445,13 +504,7 @@ this semaphore, then N of them is woken up." ;;; funny situations (like getting a sigint while holding the session ;;; lock) occur (defmacro with-session-lock ((session) &body body) - #!-sb-thread (declare (ignore session)) - #!-sb-thread - `(locally ,@body) - #!+sb-thread - `(without-interrupts - (with-mutex ((session-lock ,session)) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) (session-lock ,session))) (defun new-session () (make-session :threads (list *current-thread*) @@ -630,12 +683,14 @@ around and can be retrieved by JOIN-THREAD." (*restart-clusters* nil) (*handler-clusters* nil) (*condition-restarts* nil) + (sb!impl::*deadline* nil) (sb!impl::*step-out* nil) ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) - (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small! - (sb!impl::*zap-array-data-temp* (vector)) ; + (empty (vector)) + (sb!impl::*merge-sort-temp-vector* empty) + (sb!impl::*zap-array-data-temp* empty) (sb!impl::*internal-symbol-output-fun* nil) (sb!impl::*descriptor-handlers* nil)) ; serve-event (setf (thread-os-thread thread) (current-thread-sap-id)) @@ -723,9 +778,7 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(without-interrupts - (with-mutex ((thread-interruptions-lock ,thread)) - ,@body))) + `(call-with-system-mutex (lambda () ,@body) (thread-interruptions-lock ,thread))) ;; Called from the signal handler in C. (defun run-interruption () @@ -734,8 +787,6 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." (let ((interruption (with-interruptions-lock (*current-thread*) (pop (thread-interruptions *current-thread*))))) (if interruption - ;; This is safe because it's the IN-INTERRUPTION that - ;; has disabled interrupts. (with-interrupts (funcall interruption)) (return)))))) @@ -755,29 +806,21 @@ nature: if you interrupt a thread that was holding important locks then do something that turns out to need those locks, you probably won't like the effect." #!-sb-thread (declare (ignore thread)) - (flet ((interrupt-self () - ;; *IN-INTERRUPTION* is true IFF we're being called as an - ;; interruption without an intervening WITHOUT-INTERRUPTS, - ;; in which case it is safe to enable interrupts. Otherwise - ;; interrupts are either already enabled, or there is an outer - ;; WITHOUT-INTERRUPTS we know nothing about, which makes it - ;; unsafe to enable interrupts. - (if *in-interruption* - (with-interrupts (funcall function)) - (funcall function)))) - #!-sb-thread - (interrupt-self) - #!+sb-thread - (if (eq thread *current-thread*) - (interrupt-self) - (let ((os-thread (thread-os-thread thread))) - (cond ((not os-thread) - (error 'interrupt-thread-error :thread thread)) - (t - (with-interruptions-lock (thread) - (push function (thread-interruptions thread))) - (when (minusp (signal-interrupt-thread os-thread)) - (error 'interrupt-thread-error :thread thread)))))))) + #!-sb-thread + (with-interrupt-bindings + (with-interrupts (funcall function))) + #!+sb-thread + (if (eq thread *current-thread*) + (with-interrupt-bindings + (with-interrupts (funcall function))) + (let ((os-thread (thread-os-thread thread))) + (cond ((not os-thread) + (error 'interrupt-thread-error :thread thread)) + (t + (with-interruptions-lock (thread) + (push function (thread-interruptions thread))) + (when (minusp (signal-interrupt-thread os-thread)) + (error 'interrupt-thread-error :thread thread))))))) (defun terminate-thread (thread) #!+sb-doc @@ -802,6 +845,12 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (sap-ref-sap thread-sap (* sb!vm:n-word-bytes sb!vm::thread-next-slot))))))) +(define-alien-routine "thread_yield" int) + +#!+sb-doc +(setf (fdocumentation 'thread-yield 'function) + "Yield the processor to other threads.") + #!+sb-thread (defun symbol-value-in-thread (symbol thread-sap) (let* ((index (sb!vm::symbol-tls-index symbol))