X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=3493cfce2f4897fa7a034edb9a02575174f34a64;hb=8eee0d3a30bf39d9f201acff28c92059fe6c3e4e;hp=c37afefa5dfa6b91ef1d53bca827cbd05d022f3d;hpb=74a1797f60e26c7adbc491840f89bbaab08e504d;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index c37afef..3493cfc 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -204,8 +204,9 @@ in future versions." (error "Recursive lock attempt on ~S." spinlock)) #!+sb-thread (flet ((cas () - (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) - (return-from get-spinlock t)))) + (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) + (thread-yield) + (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. @@ -265,8 +266,13 @@ directly." #!-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)) + (let ((old (mutex-%owner mutex))) + (when (eq new-owner old) + (error "Recursive lock attempt ~S." mutex)) + #!-sb-thread + (if old + (error "Strange deadlock on ~S in an unithreaded build?" mutex) + (setf (mutex-%owner mutex) new-owner))) #!+sb-thread (progn ;; FIXME: Lutexes do not currently support deadlines, as at least @@ -386,41 +392,50 @@ time we reacquire MUTEX and return to the caller." (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread - (let ((owner (mutex-%owner mutex))) + (let ((me *current-thread*)) + (assert (eq me (mutex-%owner mutex))) (/show0 "CONDITION-WAITing") #!+sb-lutex - (progn - ;; 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-%owner mutex) owner)) + ;; Need to disable interrupts so that we don't miss setting the owner on + ;; our way out. (pthread_cond_wait handles the actual re-acquisition.) + (without-interrupts + (unwind-protect + (progn + (setf (mutex-%owner mutex) nil) + (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) + (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) + (with-local-interrupts + (%lutex-wait queue-lutex-address mutex-lutex-address))))) + (setf (mutex-%owner mutex) me))) #!-sb-lutex - (unwind-protect - (let ((me *current-thread*)) - ;; 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 - ;; manages to grab MUTEX and call CONDITION-NOTIFY during - ;; this comment, it will change queue->data, and so - ;; futex-wait returns immediately instead of sleeping. - ;; Ergo, no lost wakeup. We may get spurious wakeups, - ;; but that's ok. - (multiple-value-bind (to-sec to-usec) (decode-timeout nil) - (when (= 1 (with-pinned-objects (queue me) - (futex-wait (waitqueue-data-address queue) - (get-lisp-obj-address me) - (or to-sec -1) ;; our way if saying "no timeout" - (or to-usec 0)))) - (signal-deadline)))) - ;; If we are interrupted while waiting, we should do these things - ;; 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 owner)))) + ;; Need to disable interrupts so that we don't miss grabbing the mutex + ;; on our way out. + (without-interrupts + (unwind-protect + (let ((me *current-thread*)) + ;; 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 + ;; manages to grab MUTEX and call CONDITION-NOTIFY during + ;; this comment, it will change queue->data, and so + ;; futex-wait returns immediately instead of sleeping. + ;; Ergo, no lost wakeup. We may get spurious wakeups, + ;; but that's ok. + (multiple-value-bind (to-sec to-usec) (decode-timeout nil) + (when (= 1 (with-pinned-objects (queue me) + (allow-with-interrupts + (futex-wait (waitqueue-data-address queue) + (get-lisp-obj-address me) + (or to-sec -1) ;; our way if saying "no timeout" + (or to-usec 0))))) + (signal-deadline)))) + ;; If we are interrupted while waiting, we should do these things + ;; 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))))) (defun condition-notify (queue &optional (n 1)) #!+sb-doc @@ -465,6 +480,7 @@ should be considered an implementation detail, and may change in the future." (name nil :type (or null simple-string)) (%count 0 :type (integer 0)) + (waitcount 0 :type (integer 0)) (mutex (make-mutex)) (queue (make-waitqueue))) @@ -485,21 +501,37 @@ future." #!+sb-doc "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 semaphore)) - (loop until (> (semaphore-%count semaphore) 0) - do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore)) - finally (decf (semaphore-%count semaphore))))) + ;; A more direct implementation based directly on futexes should be + ;; possible. + ;; + ;; We need to disable interrupts so that we don't forget to decrement the + ;; waitcount (which would happen if an asynch interrupt should catch us on + ;; our way out from the loop.) + (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) + ;; Quick check: is it positive? If not, enter the wait loop. + (let ((count (semaphore-%count semaphore))) + (if (plusp count) + (setf (semaphore-%count semaphore) (1- count)) + (unwind-protect + (progn + (incf (semaphore-waitcount semaphore)) + (loop until (plusp (setf count (semaphore-%count semaphore))) + do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore))) + (setf (semaphore-%count semaphore) (1- count))) + (decf (semaphore-waitcount semaphore))))))) (defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc "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)))) + ;; Need to disable interrupts so that we don't lose a wakeup after we have + ;; incremented the count. + (with-system-mutex ((semaphore-mutex semaphore)) + (let ((waitcount (semaphore-waitcount semaphore)) + (count (incf (semaphore-%count semaphore) n))) + (when (plusp waitcount) + (condition-notify (semaphore-queue semaphore) (min waitcount count)))))) ;;;; job control, independent listeners