From 955ce74879cc8220d4c97bb1c0f3becd26ad68fc Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 28 Mar 2010 15:19:11 +0000 Subject: [PATCH] 1.0.37.8: add ATOMIC-DECF, fix WAIT-ON-SEMAPHORE-BUGLET * We already had SB-EXT:ATOMIC-INCF, so this seems a sensible companion. I really cannot remember why I didn't do things like this in the first place -- lack of time, maybe? * Use ATOMIC-DECF instead of DECF in WAIT-ON-SEMAPHORE to decrement the waitcount: if we unwind from CONDITION-WAIT due to timeout the mutex might no longer be ours. --- NEWS | 4 ++ package-data-list.lisp-expr | 1 + src/code/late-extensions.lisp | 86 +++++++++++++++++++++++++----------- src/code/target-thread.lisp | 15 +++---- src/compiler/generic/vm-fndb.lisp | 2 +- src/compiler/x86-64/cell.lisp | 4 +- src/compiler/x86/cell.lisp | 4 +- tests/compare-and-swap.impure.lisp | 14 +++++- tests/threads.impure.lisp | 4 +- version.lisp-expr | 2 +- 10 files changed, 91 insertions(+), 45 deletions(-) diff --git a/NEWS b/NEWS index 5ce534b..c0d524e 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ changes relative to sbcl-1.0.36: * new feature: added SB-THREAD:TRY-SEMAPHORE, a non-blocking variant of SB-THREAD:WAIT-ON-SEMAPHORE. + * new feature: SB-EXT:ATOMIC-DECF has been added as a companion to + SB-EXT:ATOMIC-INCF. * enhancement: *STANDARD-OUTPUT*, *STANDARD-INPUT*, and *ERROR-OUTPUT* are now bivalent. * enhancement: errors from NO-APPLICABLE-METHOD and @@ -9,6 +11,8 @@ changes relative to sbcl-1.0.36: generic function call. * bug fix: correct restart text for the continuable error in MAKE-PACKAGE. * bug fix: a rare case of startup-time page table corruption. + * bug fix: a semaphore with multiple waiters and some of them unwinding due + to timeouts could be left in an inconsistent state. changes in sbcl-1.0.37 relative to sbcl-1.0.36: * enhancement: Backtrace from THROW to uncaught tag on x86oids now shows diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 78a32b5..87913c8 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -586,6 +586,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; Atomic operations "COMPARE-AND-SWAP" "ATOMIC-INCF" + "ATOMIC-DECF" ;; Time related things "CALL-WITH-TIMING" diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index e2950d6..3c992d0 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -167,25 +167,9 @@ EXPERIMENTAL: Interface subject to change." (def %compare-and-swap-symbol-value (symbol) symbol-value) (def %compare-and-swap-svref (vector index) svref)) -(defmacro atomic-incf (place &optional (diff 1)) - #!+sb-doc - "Atomically increments PLACE by DIFF, and returns the value of PLACE before -the increment. - -The incrementation is done using word-size modular arithmetic: on 32 bit -platforms ATOMIC-INCF of #xFFFFFFFF by one results in #x0 being stored in -PLACE. - -PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor -whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms, -and (UNSIGNED-BYTE 64) on 64 bit platforms. - -DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms, -and (SIGNED-BYTE 64) on 64 bit platforms. - -EXPERIMENTAL: Interface subject to change." +(defun expand-atomic-frob (name place diff) (flet ((invalid-place () - (error "Invalid first argument to ATOMIC-INCF: ~S" place))) + (error "Invalid first argument to ~S: ~S" name place))) (unless (consp place) (invalid-place)) (destructuring-bind (op &rest args) place @@ -200,27 +184,75 @@ EXPERIMENTAL: Interface subject to change." (declare (ignorable structure index)) (unless (and (eq 'sb!vm:word (dsd-raw-type slotd)) (type= (specifier-type type) (specifier-type 'sb!vm:word))) - (error "ATOMIC-INCF requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" - sb!vm:n-word-bits type place)) + (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" + name sb!vm:n-word-bits type place)) (when (dsd-read-only slotd) - (error "Cannot use ATOMIC-INCF with structure accessor for a read-only slot: ~S" - place)) + (error "Cannot use ~S with structure accessor for a read-only slot: ~S" + name place)) #!+(or x86 x86-64) `(truly-the sb!vm:word - (%raw-instance-atomic-incf/word (the ,structure ,@args) - ,index - (the sb!vm:signed-word ,diff))) + (%raw-instance-atomic-incf/word + (the ,structure ,@args) ,index + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,(ecase name + (atomic-incf + `(the sb!vm:signed-word ,diff)) + (atomic-decf + `(- (the sb!vm:signed-word ,diff))))))) ;; No threads outside x86 and x86-64 for now, so this is easy... #!-(or x86 x86-64) (with-unique-names (structure old) `(sb!sys:without-interrupts (let* ((,structure ,@args) (,old (,op ,structure))) - (setf (,op ,structure) (logand #.(1- (ash 1 sb!vm:n-word-bits)) - (+ ,old (the sb!vm:signed-word ,diff)))) + (setf (,op ,structure) + (logand #.(1- (ash 1 sb!vm:n-word-bits)) + ,(ecase name + (atomic-incf + `(+ ,old (the sb!vm:signed-word ,diff))) + (atomic-decf + `(- ,old (the sb!vm:signed-word ,diff)))))) ,old)))) (invalid-place)))))) +(defmacro atomic-incf (place &optional (diff 1)) + #!+sb-doc + "Atomically increments PLACE by DIFF, and returns the value of PLACE before +the increment. + +The incrementation is done using word-size modular arithmetic: on 32 bit +platforms ATOMIC-INCF of #xFFFFFFFF by one results in #x0 being stored in +PLACE. + +PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor +whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms, +and (UNSIGNED-BYTE 64) on 64 bit platforms. + +DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms, +and (SIGNED-BYTE 64) on 64 bit platforms. + +EXPERIMENTAL: Interface subject to change." + (expand-atomic-frob 'atomic-incf place diff)) + +(defmacro atomic-decf (place &optional (diff 1)) + #!+sb-doc + "Atomically decrements PLACE by DIFF, and returns the value of PLACE before +the increment. + +The decrementation is done using word-size modular arithmetic: on 32 bit +platforms ATOMIC-DECF of #x0 by one results in #xFFFFFFFF being stored in +PLACE. + +PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor +whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms, +and (UNSIGNED-BYTE 64) on 64 bit platforms. + +DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms, +and (SIGNED-BYTE 64) on 64 bit platforms. + +EXPERIMENTAL: Interface subject to change." + (expand-atomic-frob 'atomic-decf place diff)) + (defun call-hooks (kind hooks &key (on-error :error)) (dolist (hook hooks) (handler-case diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 7d5a786..eaf1692 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -524,7 +524,10 @@ IF-NOT-OWNER is :FORCE)." #!+sb-doc "Atomically release MUTEX and enqueue ourselves on QUEUE. Another thread may subsequently notify us using CONDITION-NOTIFY, at which -time we reacquire MUTEX and return to the caller." +time we reacquire MUTEX and return to the caller. + +Note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of +returning normally, it may do so without holding the mutex." #!-sb-thread (declare (ignore queue)) (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") @@ -680,13 +683,9 @@ negative. Else blocks until the semaphore can be decremented." do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore))) (setf (semaphore-%count semaphore) (1- count))) - ;; Even safe when CONDITION-WAIT is unwinded without - ;; having reacquired the lock: a) we know at this point - ;; that an INCF must have happened before, b) the DECF - ;; will become visible to other CPUs as the implicit - ;; RELEASE-MUTEX involves a CAS and hence a memory - ;; barrier. - (decf (semaphore-waitcount semaphore))))))) + ;; Need to use ATOMIC-DECF instead of DECF, as CONDITION-WAIT + ;; may unwind without the lock being held due to timeouts. + (atomic-decf (semaphore-waitcount semaphore))))))) (defun try-semaphore (semaphore) #!+sb-doc diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 492238f..a759e56 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -166,7 +166,7 @@ (unsafe always-translatable)) #!+(or x86 x86-64) -(defknown %raw-instance-atomic-incf/word (instance index sb!vm:signed-word) sb!vm:word +(defknown %raw-instance-atomic-incf/word (instance index sb!vm:word) sb!vm:word (unsafe always-translatable)) ;;; These two are mostly used for bit-bashing operations. diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index a5114eb..f282900 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -599,11 +599,11 @@ (:translate %raw-instance-atomic-incf/word) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (diff :scs (signed-reg) :target result)) + (diff :scs (unsigned-reg) :target result)) (:arg-types * (:constant (load/store-index #.n-word-bytes #.instance-pointer-lowtag #.instance-slots-offset)) - signed-num) + unsigned-num) (:info index) (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (unsigned-reg))) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index d89f989..8ba4680 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -540,8 +540,8 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)) - (diff :scs (signed-reg) :target result)) - (:arg-types * tagged-num signed-num) + (diff :scs (unsigned-reg) :target result)) + (:arg-types * tagged-num unsigned-num) (:temporary (:sc unsigned-reg) tmp) (:results (result :scs (unsigned-reg))) (:result-types unsigned-num) diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp index e35b56d..accb74f 100644 --- a/tests/compare-and-swap.impure.lisp +++ b/tests/compare-and-swap.impure.lisp @@ -105,7 +105,7 @@ (sb-ext:compare-and-swap (symbol-value name) t 42) (error () :error))))) -;;;; ATOMIC-INCF (we should probably rename this file atomic-ops...) +;;;; ATOMIC-INCF and ATOMIC-DECF (we should probably rename this file atomic-ops...) (defstruct box (word 0 :type sb-vm:word)) @@ -118,7 +118,7 @@ (defun dec-box (box n) (declare (fixnum n) (box box)) (loop repeat n - do (sb-ext:atomic-incf (box-word box) -1))) + do (sb-ext:atomic-decf (box-word box)))) (let ((box (make-box))) (inc-box box 10000) @@ -126,6 +126,16 @@ (dec-box box 10000) (assert (= 0 (box-word box)))) +(with-test (:name :atomic-incf-wraparound) + (let ((box (make-box :word (1- (ash 1 sb-vm:n-word-bits))))) + (sb-ext:atomic-incf (box-word box) 2) + (assert (= 1 (box-word box))))) + +(with-test (:name :atomic-decf-wraparound) + (let ((box (make-box :word 0))) + (sb-ext:atomic-decf (box-word box) 2) + (assert (= (- (ash 1 sb-vm:n-word-bits) 2) (box-word box))))) + #+sb-thread (let* ((box (make-box)) (threads (loop repeat 64 diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 602c438..3937dad 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -393,7 +393,7 @@ (test-semaphore-multiple-signals #'busy-wait-on-semaphore))) ;;; Here we test that interrupting TRY-SEMAPHORE does not leave a -;;; semaphore in a bad state. +;;; semaphore in a bad state. (with-test (:name (:try-semaphore :interrupt-safe)) (flet ((make-threads (count fn) (loop repeat count collect (make-thread fn))) @@ -421,7 +421,7 @@ ;; Now ensure that the waiting threads will all be waked up, ;; i.e. that the semaphore is still working. (loop repeat (+ (count-live-threads waiters) - (count-live-threads more-waiters)) + (count-live-threads more-waiters)) do (signal-semaphore sem)) (sleep 0.5) (assert (zerop (count-live-threads triers))) diff --git a/version.lisp-expr b/version.lisp-expr index eb4a606..e29c4bc 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.37.7" +"1.0.37.8" -- 1.7.10.4