[Sbcl-commits] CVS: sbcl/src/code late-extensions.lisp, 1.23, 1.24 target-thread.lisp, 1.121, 1.122

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27202/src/code

Modified Files:
	late-extensions.lisp target-thread.lisp 
Log Message:
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.


Index: late-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-extensions.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- late-extensions.lisp	7 Oct 2009 18:06:36 -0000	1.23
+++ late-extensions.lisp	28 Mar 2010 15:19:12 -0000	1.24
@@ -167,25 +167,9 @@
   (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 @@
               (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

Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.121
retrieving revision 1.122
diff -u -d -r1.121 -r1.122
--- target-thread.lisp	28 Mar 2010 13:37:22 -0000	1.121
+++ target-thread.lisp	28 Mar 2010 15:19:12 -0000	1.122
@@ -524,7 +524,10 @@
   #!+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 @@
                        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