Adding atomic-fetch-compare-and-swap! procedure

Author: ktakashi

doc/sagittarius/atomic.md

@@ -4,10 +4,12 @@
 ###### [!Library] `(sagittarius atomic)` **[@since] `0.9.13`**
 
 This library provides atomic operation. The underlying implementation
-of this library can be either `stdatomic` from C11 or `libatomic_ops`.
+of this library can be either `stdatomic` from C11 or `<atomic>` from C++11.
 If the platform supports the first one, then that'd be chosen, otherwise
 the latter one.
 
+NOTE: if the platform doesn't support none of them, then compilation error.
+
 ###### [!Function] `atomic?` _obj_
 
 Returns `#t` if the given _obj_ is an atomic object, otherwise `#f`.
@@ -16,6 +18,14 @@ Returns `#t` if the given _obj_ is an atomic object, otherwise `#f`.
 
 Creates a fresh atomic object whoes initial value is _obj_.
 
+###### [!Function] `atomic-flag?` _obj_
+
+Returns `#t` if the given _obj_ is an atomic flag object, otherwise `#f`.
+
+###### [!Function] `make-atomic-flag`
+
+Creates a fresh atomic flag. The flag is unset.
+
 ###### [!Function] `atomic-fixnum?` _obj_
 
 Returns `#t` if the given _obj_ is an atomic fixnum object, otherwise `#f`.
@@ -24,6 +34,16 @@ Returns `#t` if the given _obj_ is an atomic fixnum object, otherwise `#f`.
 
 Creates a fresh atomic fixnum object whoes initial value is _n_.
 
+###### [!Function] `atomic-pair?` _obj_
+
+Returns `#t` if the given _obj_ is an atomic pair object, otherwise `#f`.
+
+###### [!Function] `make-atomic-pair` _head_ _tail_
+
+Creates a fresh atomic pair object whoes initial values are _first_ and _tail_.
+
+This is double word atomic object.
+
 ###### [!Function] `memory-order?` _obj_
 
 Returns `#t` if the given _obj_ is a fixnum and value of memory order.
@@ -73,11 +93,22 @@ and returns the previous value of _a_.
 Exchange the value of _a_ with given _v_ or _n_ and returns the old value
 of _a_.
 
-###### [!Function] `atomic-compare-and-swap!` (_a_ `atomic?`) _v_ :optional (_order_ `memory-order?`)
+###### [!Function] `atomic-compare-and-swap!` (_a_ `atomic?`) _e_ _v_ :optional (_order_ `memory-order?`)
+
+CAS operation. Returns `#t` if the operation succeed, otherwise `#f`.
+
+###### [!Function] `atomic-fetch-compare-and-swap!` (_a_ `atomic?`) _e_ _v_ :optional (_order_ `memory-order?`)
 
-CAS operation.
+CAS operation. Returns previously set value if the operation **failed**,
+otherwise the _e_.
 
 ###### [!Function] `atomic-fixnum-inc!` (_a_ `atomic-fixnum?`) :optional (_order_ `memory-order?`)
 ###### [!Function] `atomic-fixnum-dec!` (_a_ `atomic-fixnum?`) :optional (_order_ `memory-order?`)
 
 Increment or decrement the value of given _a_ and updates the value.
+
+
+###### [!Function] `atomic-thread-fence` (_order_ `memory-order?`)
+
+Establishes memory synchronization ordering of non-atomic and relaxed
+atomic accesses.

ext/atomic/atomic.stub

@@ -71,7 +71,21 @@
 (define-c-proc atomic-exchange! (a::<atomic> v :optional (order::<memory-order> (default-memory-order))) Sg_AtomicExchange)
 (define-c-proc atomic-fixnum-exchange! (a::<atomic-fixnum> v::<fixnum> :optional (order::<memory-order> (default-memory-order))) ::<fixnum> Sg_AtomicFixnumExchange)
 
-(define-c-proc atomic-compare-and-swap! (a::<atomic> e v :optional (success::<memory-order> (default-memory-order)) (failure::<memory-order> (default-memory-order))) ::<boolean> Sg_AtomicCompareAndSwap)
+(define-c-proc atomic-compare-and-swap!
+  (a::<atomic> e v 
+   :optional (success::<memory-order> (default-memory-order)) 
+	     (failure::<memory-order> (default-memory-order)))
+  ::<boolean>
+  (result (Sg_AtomicCompareAndSwap a e v NULL success failure)))
+
+(define-c-proc atomic-fetch-compare-and-swap!
+  (a::<atomic> e v 
+   :optional (success::<memory-order> (default-memory-order)) 
+	     (failure::<memory-order> (default-memory-order)))
+  (let ((r NULL))
+    (if (Sg_AtomicCompareAndSwap a e v (& r) success failure)
+	(result e)
+	(result r))))
 
 (define-c-proc atomic-flag-test-and-set! (a::<atomic-flag> :optional (order::<memory-order> (default-memory-order))) ::<boolean> Sg_AtomicFlagTestAndSet)
 (define-c-proc atomic-flag-clear! (a::<atomic-flag> :optional (order::<memory-order> (default-memory-order))) ::<void> Sg_AtomicFlagClear)

ext/atomic/sagittarius-atomic.c

@@ -445,8 +445,10 @@ long Sg_AtomicFixnumAnd(volatile SgAtomic *o, long v, SgMemoryOrder order)
 }
 
 int Sg_AtomicCompareAndSwap(volatile SgAtomic *o, SgObject e, SgObject v,
+			    SgObject *r,
 			    SgMemoryOrder success, SgMemoryOrder failure)
 {
+  int result;
   no_atomic_flag(o);
   switch (o->type) {
   case SG_ATOMIC_FIXNUM:
@@ -455,29 +457,42 @@ int Sg_AtomicCompareAndSwap(volatile SgAtomic *o, SgObject e, SgObject v,
     }
     {
       long ev = SG_INT_VALUE(e);
-      return atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_FIXNUM(o),
-						     &ev,
-						     SG_INT_VALUE(v),
-						     success, failure);
+      result = atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_FIXNUM(o),
+						       &ev,
+						       SG_INT_VALUE(v),
+						       success, failure);
+      if (!result && r) {
+	*r = SG_MAKE_INT(ev);
+      }
     }
+    break;
   case SG_ATOMIC_PAIR:
     if (!SG_PAIRP(e) && !SG_PAIRP(v)) {
       Sg_Error(UC("atomic_pair must take pair but got %S and %S"), e, v);
     }
     {
       pair_t ev = { SG_CAR(e), SG_CDR(e) };
       pair_t vv = { SG_CAR(v), SG_CDR(v) };
-      return atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_PAIR(o),
+      result = atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_PAIR(o),
 						     &ev, vv, success, failure);
+      if (!result && r) {
+	*r = Sg_Cons(ev.car, ev.cdr);
+      }
     }
+    break;
   default:
     {
       object_t ev = (object_t)e;
-      return atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_OBJECT(o),
-						     &ev, (object_t)v,
-						     success, failure);
+      result = atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_OBJECT(o),
+						       &ev, (object_t)v,
+						       success, failure);
+      if (!result && r) {
+	*r = SG_OBJ(ev);
+      }
     }
+    break;
   }
+  return result;
 }
 
 int Sg_AtomicFlagTestAndSet(volatile SgAtomic *o, SgMemoryOrder order)

ext/atomic/sagittarius-atomic.h

@@ -174,6 +174,7 @@ SG_EXTERN long     Sg_AtomicFixnumAnd(volatile SgAtomic *o, long v,
 
 SG_EXTERN int      Sg_AtomicCompareAndSwap(volatile SgAtomic *o,
 					   SgObject e, SgObject v,
+					   SgObject *r,
 					   SgMemoryOrder success,
 					   SgMemoryOrder failure);
 SG_EXTERN int      Sg_AtomicFlagTestAndSet(volatile SgAtomic *o,

ext/atomic/sagittarius/atomic.scm

@@ -50,7 +50,7 @@
 
 	    atomic-exchange! atomic-fixnum-exchange!
 
-	    atomic-compare-and-swap!
+	    atomic-compare-and-swap! atomic-fetch-compare-and-swap!
 
 	    atomic-flag-test-and-set! atomic-flag-clear!
 

sitelib/srfi/%3a230/atomic.scm

@@ -62,19 +62,7 @@
     (import (rnrs)
 	    (rename (except (sagittarius atomic) memory-order?)
 		    (atomic-flag-test-and-set! a:atomic-flag-test-and-set!)
-		    (atomic-flag-clear! a:atomic-flag-clear!)) 
-	    (srfi :18 multithreading))
-(define *lock* (make-mutex))
-(define-syntax lock-guard
-  (syntax-rules ()
-    ((_ expr ...)
-     (dynamic-wind
-	 (lambda ()
-	   (guard (c ((abandoned-mutex-exception? c) #f))
-	     (mutex-lock! *lock*)))
-	 (lambda () expr ...)
-	 (lambda () (mutex-unlock! *lock*))))))
-
+		    (atomic-flag-clear! a:atomic-flag-clear!)) )
 ;; memory order
 (define-enumeration memory-order
   (relaxed acquire release acquire-release sequentially-consistent)
@@ -106,10 +94,7 @@
   (atomic-exchange! box obj (memory-order->value order)))
 (define (atomic-box-compare-and-swap! (box atomic-box?) old new 
 				      :optional (order *default-order*))
-  (lock-guard
-   (let ((r (atomic-box-ref box order)))
-     (atomic-compare-and-swap! box old new (memory-order->value order))
-     r)))
+  (atomic-fetch-compare-and-swap! box old new (memory-order->value order)))
 
 ;; atomic fixnum
 (define (make-atomic-fxbox (fx fixnum?)) (make-atomic-fixnum fx))
@@ -126,10 +111,7 @@
 (define (atomic-fxbox-compare-and-swap! (afx atomic-fxbox?)
 					(old fixnum?) (new fixnum?)
 					:optional (order *default-order*))
-  (lock-guard
-   (let ((r (atomic-fxbox-ref afx order)))
-     (atomic-compare-and-swap! afx old new (memory-order->value order))
-     r)))
+  (atomic-fetch-compare-and-swap! afx old new (memory-order->value order)))
 (define (atomic-fxbox+/fetch! (afx atomic-fxbox?) (fx fixnum?) 
 			      :optional (order *default-order*))
   (atomic-fixnum-add! afx fx (memory-order->value order)))
@@ -162,10 +144,8 @@
 (define (atomic-pair-compare-and-swap! (ap atomic-pair?) oa od na nd 
 				       :optional (order *default-order*))
   (define morder (memory-order->value order))
-  (lock-guard
-   (let-values (((ra rd) (atomic-pair-ref ap order)))
-     (atomic-compare-and-swap! ap (cons oa od) (cons na nd) morder)
-     (values ra rd))))
+  (let ((r (atomic-fetch-compare-and-swap! ap (cons oa od) (cons na nd) morder)))
+    (values (car r) (cdr r))))
 
 (define (atomic-fence (order memory-order?))
   (atomic-thread-fence (memory-order->value order)))

sitelib/util/concurrent/atomic.scm

@@ -51,7 +51,7 @@
 
 	    atomic-exchange! atomic-fixnum-exchange!
 
-	    atomic-compare-and-swap!
+	    atomic-compare-and-swap! atomic-fetch-compare-and-swap!
 
 	    atomic-flag-test-and-set! atomic-flag-clear!