Adding atomic pair

ktakashi · ktakashi · commit 30755062167c · 2025-01-09T10:40:48.000+01:00
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
@@ -126,6 +126,35 @@ IF(MSYS OR (NOT MSVC AND WIN32))
 ENDIF()
 
 IF(NOT WIN32)
+  if (HAVE_STDATOMIC_H)
+    CHECK_C_SOURCE_COMPILES(
+"#include <stdatomic.h>
+#include <stddef.h>
+typedef struct {
+    void *a;
+    void *b;
+} cas16_t;
+typedef _Atomic cas16_t atomic_cas16_t;
+int main()
+{
+   cas16_t v = { NULL, NULL };
+   atomic_cas16_t a;
+   atomic_init(&a, v);
+   atomic_exchange(&a, v);
+   return 0;
+}
+"
+      CAS16_WORKS)
+  ELSE()
+    # TODO libatomic_ops?
+    SET(CAS16_WORKS TRUE)
+  ENDIF()
+  IF (CAS16_WORKS)
+    MESSAGE(STATUS "CAS16 works ... yes")
+  ELSE()
+    MESSAGE(STATUS "CAS16 works ... no")
+  ENDIF()
+
   IF (NOT ${SAGITTARIUS_OS} STREQUAL "qnx")
     TARGET_LINK_LIBRARIES(sagittarius pthread)
   ENDIF()
@@ -142,6 +171,10 @@ IF(NOT WIN32)
   IF (${SAGITTARIUS_OS} STREQUAL "linux")
     # for clock_gettime
     TARGET_LINK_LIBRARIES(sagittarius rt)
+    # for CAS16
+    IF (NOT CAS16_WORKS)
+      TARGET_LINK_LIBRARIES(sagittarius atomic)
+    ENDIF()
   ENDIF()
   # linux needs this
   TARGET_LINK_LIBRARIES(sagittarius m)
diff --git a/src/atomic.c b/src/atomic.c
@@ -30,6 +30,7 @@
 #include "sagittarius/private/atomic.h"
 #include "sagittarius/private/error.h"
 #include "sagittarius/private/library.h"
+#include "sagittarius/private/pair.h"
 #include "sagittarius/private/port.h"
 #include "sagittarius/private/symbol.h"
 #include "sagittarius/private/writer.h"
@@ -288,6 +289,14 @@ SgObject Sg_MakeAtomic(SgObject obj)
   return SG_OBJ(a);
 }
 
+SgObject Sg_MakeAtomicPair(SgObject car, SgObject cdr)
+{
+  SgAtomic *a = make_atomic(SG_ATOMIC_PAIR);
+  pair_t v = { car, cdr };
+  atomic_init(&SG_ATOMIC_REF_PAIR(a), v);
+  return SG_OBJ(a);
+}
+
 SgObject Sg_MakeAtomicFixnum(long n)
 {
   SgAtomic *a = make_atomic(SG_ATOMIC_FIXNUM);
@@ -301,6 +310,9 @@ SgObject Sg_AtomicLoad(volatile SgAtomic *o, SgMemoryOrder order)
   if (SG_ATOMIC_FIXNUM_P(o)) {
     long v = atomic_load_explicit(&SG_ATOMIC_REF_FIXNUM(o), order);
     return SG_MAKE_INT(v);
+  } else if (SG_ATOMIC_PAIR_P(o)) {
+    pair_t v = atomic_load_explicit(&SG_ATOMIC_REF_PAIR(o), order);
+    return Sg_Cons(v.car, v.cdr);
   } else {
     object_t v = atomic_load_explicit(&SG_ATOMIC_REF_OBJECT(o), order);
     return SG_OBJ(v);
@@ -314,6 +326,12 @@ void Sg_AtomicStore(volatile SgAtomic *o, SgObject v, SgMemoryOrder order)
       Sg_Error(UC("fixnum is required for atomic-fixnum but got %A"), v);
     }
     atomic_store_explicit(&SG_ATOMIC_REF_FIXNUM(o), SG_INT_VALUE(v), order);
+  } else if (SG_ATOMIC_PAIR_P(o)) {
+    if (!SG_PAIRP(v)) {
+      Sg_Error(UC("pair is required for atomic-pair but got %A"), v);
+    }
+    pair_t v2 = { .car = SG_CAR(v), .cdr = SG_CDR(v) };
+    atomic_store_explicit(&SG_ATOMIC_REF_PAIR(o), v2, order);
   } else {
     atomic_store_explicit(&SG_ATOMIC_REF_OBJECT(o), (object_t)v, order);
   }
@@ -328,6 +346,13 @@ SgObject Sg_AtomicExchange(volatile SgAtomic *o, SgObject v, SgMemoryOrder order
     long vl = SG_INT_VALUE(v);
     long l = atomic_exchange_explicit(&SG_ATOMIC_REF_FIXNUM(o), vl, order);
     return SG_MAKE_INT(l);
+  } else if (SG_ATOMIC_PAIR_P(o)) {
+    if (!SG_PAIRP(v)) {
+      Sg_Error(UC("pair is required for atomic-pair but got %A"), v);
+    }
+    pair_t v2 = { .car = SG_CAR(v), .cdr = SG_CDR(v) };
+    pair_t r = atomic_exchange_explicit(&SG_ATOMIC_REF_PAIR(o), v2, order);
+    return Sg_Cons(r.car, r.cdr);
   } else {
     object_t r = atomic_exchange_explicit(&SG_ATOMIC_REF_OBJECT(o),
 					  (object_t)v, order);
@@ -400,15 +425,25 @@ int Sg_AtomicCompareAndSwap(volatile SgAtomic *o, SgObject e, SgObject v,
     }
     {
       long ev = SG_INT_VALUE(e);
-      return atomic_compare_exchange_strong_explicit(&(o->reference.fixnum),
+      return atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_FIXNUM(o),
 						     &ev,
 						     SG_INT_VALUE(v),
 						     success, failure);
     }
+  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 = { .car = SG_CAR(e), .cdr = SG_CDR(e) };
+      pair_t vv = { .car = SG_CAR(v), .cdr = SG_CDR(v) };
+      return atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_PAIR(o),
+						     &ev, vv, success, failure);
+    }
   default:
     {
       object_t ev = (object_t)e;
-      return atomic_compare_exchange_strong_explicit(&(o->reference.object),
+      return atomic_compare_exchange_strong_explicit(&SG_ATOMIC_REF_OBJECT(o),
 						     &ev, (object_t)v,
 						     success, failure);
     }
diff --git a/src/lib_atomic.stub b/src/lib_atomic.stub
@@ -35,6 +35,8 @@
 	   <sagittarius/private/atomic.h>))
 
 (define-type <atomic> "SgAtomic*" )
+(define-type <atomic-pair> "SgAtomic*" "atomic-pair"
+  "SG_ATOMIC_PAIR_P" "SG_ATOMIC")
 (define-type <atomic-fixnum> "SgAtomic*" "atomic-fixnum"
   "SG_ATOMIC_FIXNUM_P" "SG_ATOMIC")
 (define-type <memory-order> "SgMemoryOrder" "memory-order"
@@ -46,9 +48,11 @@
 (define-c-proc memory-order? (obj) ::<boolean> Sg_MemoryOrderP)
 
 (define-c-proc make-atomic (obj) Sg_MakeAtomic)
+(define-c-proc make-atomic-pair (a d) Sg_MakeAtomicPair)
 (define-c-proc make-atomic-fixnum (n::<fixnum>) Sg_MakeAtomicFixnum)
 
 (define-c-proc atomic? (obj) ::<boolean> SG_ATOMICP)
+(define-c-proc atomic-pair? (obj) ::<boolean> SG_ATOMIC_PAIR_P)
 (define-c-proc atomic-fixnum? (obj) ::<boolean> SG_ATOMIC_FIXNUM_P)
 
 (define-c-proc atomic-load (a::<atomic> :optional (order::<memory-order> (default-memory-order))) Sg_AtomicLoad)
diff --git a/src/sagittarius/private/atomic.h b/src/sagittarius/private/atomic.h
@@ -33,9 +33,16 @@
 #include "sagittariusdefs.h"
 #include "clos.h"
 
+typedef struct {
+  SgObject car;
+  SgObject cdr;
+} pair_t;
+
 #ifdef HAVE_STDATOMIC_H
 # include <stdatomic.h>
 
+typedef _Atomic pair_t atomic_pair_t;
+
 # ifdef HAVE_ATOMIC_INTPTR_T
 typedef atomic_intptr_t atomic_object_t;
 typedef intptr_t object_t;
@@ -49,6 +56,7 @@ typedef size_t object_t;
 /* We define only what we need here */
 typedef long     atomic_long;
 typedef intptr_t atomic_object_t;
+typedef pair_t	 atomic_pair_t;
 typedef intptr_t object_t;
 
 typedef enum memory_order {
@@ -64,6 +72,7 @@ typedef enum memory_order {
 typedef memory_order SgMemoryOrder;
 typedef enum {
   SG_ATOMIC_FIXNUM,
+  SG_ATOMIC_PAIR,
   SG_ATOMIC_OBJECT
 } SgAtomicType;
 
@@ -73,6 +82,7 @@ typedef struct SgAtomicRefRec
   SgAtomicType type;
   union {
     atomic_long fixnum;
+    atomic_pair_t pair;
     atomic_object_t object;
   } reference;
   
@@ -86,16 +96,20 @@ SG_CLASS_DECL(Sg_AtomicClass);
 #define SG_ATOMIC_TYPE(obj) SG_ATOMIC(obj)->type
 #define SG_ATOMIC_FIXNUM_P(obj)					\
   (SG_ATOMICP(obj) && SG_ATOMIC_TYPE(obj) == SG_ATOMIC_FIXNUM)
+#define SG_ATOMIC_PAIR_P(obj)					\
+  (SG_ATOMICP(obj) && SG_ATOMIC_TYPE(obj) == SG_ATOMIC_PAIR)
 #define SG_ATOMIC_OBJECT_P(obj)					\
   (SG_ATOMICP(obj) && SG_ATOMIC_TYPE(obj) == SG_ATOMIC_OBJECT)
 #define SG_ATOMIC_REF_FIXNUM(obj) SG_ATOMIC(obj)->reference.fixnum
+#define SG_ATOMIC_REF_PAIR(obj) SG_ATOMIC(obj)->reference.pair
 #define SG_ATOMIC_REF_OBJECT(obj) SG_ATOMIC(obj)->reference.object
 
 SG_CDECL_BEGIN
 
 SG_EXTERN int      Sg_MemoryOrderP(SgObject o);
 
 SG_EXTERN SgObject Sg_MakeAtomic(SgObject obj);
+SG_EXTERN SgObject Sg_MakeAtomicPair(SgObject car, SgObject cdr);
 SG_EXTERN SgObject Sg_MakeAtomicFixnum(long n);
 SG_EXTERN SgObject Sg_AtomicLoad(volatile SgAtomic *o, SgMemoryOrder order);
 SG_EXTERN void     Sg_AtomicStore(volatile SgAtomic *o, SgObject v,
