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
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
;; Atomic operations
"COMPARE-AND-SWAP"
"ATOMIC-INCF"
+ "ATOMIC-DECF"
;; Time related things
"CALL-WITH-TIMING"
(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
(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
#!+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.")
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
(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.
(: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)))
(: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)
(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))
(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)
(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
(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)))
;; 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)))
;;; 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"
projects / sbcl.git / commitdiff