Moving atomic library to extension

Using C++ <atomic> if C11 one is not available
(Most likely Visual Studio on Windows)

Author: ktakashi

.gitignore

@@ -14,6 +14,8 @@ CTestTestfile.cmake
 cmake_install.cmake
 cmake_uninstall.cmake
 Makefile
+/Testing
+DartConfiguration.tcl
 
 *.bin
 *.pc
@@ -31,6 +33,7 @@ sagittarius-package
 
 /doc/*.html
 /doc/sections
+/ext/atomic/atomic.c
 /ext/crypto/bytevector.c
 /ext/crypto/cipher.c
 /ext/crypto/digest.c

CMakeLists.txt

@@ -89,7 +89,6 @@ CHECK_INCLUDE_FILE(pthread.h   HAVE_PTHREAD_H)
 # C11 features
 CHECK_INCLUDE_FILE(uchar.h     HAVE_UCHAR_H)
 CHECK_INCLUDE_FILE(stdnoreturn.h HAVE_STDNORETURN_H)
-CHECK_INCLUDE_FILE(stdatomic.h HAVE_STDATOMIC_H)
 
 IF (HAVE_TIME_H)
   CHECK_STRUCT_EXISTS("struct timespec" time.h HAVE_TIMESPEC)
@@ -374,9 +373,6 @@ IF(USE_BOEHM_GC)
 	  AND NOT EXISTS ${GC_DIR}/libatomic_ops)
 	FILE(RENAME ${GC_DIR}/${LIBATOMIC_OPS} ${GC_DIR}/libatomic_ops)
       ENDIF()
-      IF (NOT HAVE_STDATOMIC_H)
-	INCLUDE_DIRECTORIES(${GC_DIR}/libatomic_ops/src)
-      ENDIF()
     ENDIF()
   ENDIF() 
 ENDIF()

cmake/config-cmake.h.in

@@ -40,7 +40,6 @@
 /* C11 features */
 #cmakedefine HAVE_UCHAR_H
 #cmakedefine HAVE_STDNORETURN_H
-#cmakedefine HAVE_STDATOMIC_H
 
 #cmakedefine HAVE_TIMESPEC
 

ext/CMakeLists.txt

@@ -117,6 +117,7 @@ ELSE()
   ENDIF()
 ENDIF()
 
+ADD_SUBDIRECTORY(atomic atomic)
 ADD_SUBDIRECTORY(zlib zlib)
 ADD_SUBDIRECTORY(threads threads)
 ADD_SUBDIRECTORY(time time)

ext/CMakeLists.txt.in

@@ -21,9 +21,15 @@ ENDIF()
 INCLUDE_DIRECTORIES(${CMAKE_CURRENT_SOURCE_DIR})
 
 SET_TARGET_PROPERTIES(sagittarius--@module@ PROPERTIES PREFIX "")
+IF (APPLE)
+  SET_TARGET_PROPERTIES(sagittarius--@module@ PROPERTIES PREFIX ".dylib")
+ENDIF()
 TARGET_LINK_LIBRARIES(sagittarius--@module@ sagittarius)
 
 INSTALL(TARGETS sagittarius--@module@
   DESTINATION ${SAGITTARIUS_DYNLIB_PATH})
 INSTALL(FILES sagittarius/@module@.scm
   DESTINATION ${SAGITTARIUS_SHARE_LIB_PATH}/sagittarius)
+
+# for test
+FILE(APPEND ${EXT_TEST_RESOURCE_FILE} "${CMAKE_CURRENT_SOURCE_DIR}\n")

ext/atomic/CMakeLists.txt

@@ -0,0 +1,81 @@
+# Sagittarius extensions -*- CMake -*-
+# 
+# Build file for atomic
+
+CHECK_INCLUDE_FILE(stdatomic.h HAVE_STDATOMIC_H)
+# C++ for VS :(
+CHECK_INCLUDE_FILE_CXX(atomic  HAVE_CPP_ATOMIC)
+
+IF (HAVE_STDATOMIC_H)
+  ADD_DEFINITIONS("-DHAVE_STDATOMIC_H")
+ENDIF()
+IF (HAVE_CPP_ATOMIC)
+  ADD_DEFINITIONS("-D HAVE_CPP_ATOMIC")
+ENDIF()
+
+ADD_LIBRARY(sagittarius--atomic MODULE
+  sagittarius-atomic.c 
+  ${CMAKE_CURRENT_BINARY_DIR}/atomic.c)
+
+INCLUDE(${CMAKE_CURRENT_SOURCE_DIR}/../addstub.cmake)
+ADD_STUBS(sagittarius--atomic
+  COMMAND ${GENSTUB}
+  FILES atomic.stub)
+
+IF (MSVC OR CYGWIN)
+  # ugly solution
+  SET_SOURCE_FILES_PROPERTIES(sagittarius-atomic.c
+    ${CMAKE_CURRENT_BINARY_DIR}/atomic.c 
+    PROPERTIES LANGUAGE CXX)
+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()
+
+  # for CAS16
+  IF (NOT CAS16_WORKS)
+    TARGET_LINK_LIBRARIES(sagittarius--atomic atomic)
+  ENDIF()
+ENDIF()
+
+INCLUDE_DIRECTORIES(${CMAKE_CURRENT_SOURCE_DIR})
+
+SET_TARGET_PROPERTIES(sagittarius--atomic PROPERTIES PREFIX "")
+IF(APPLE)
+  SET_TARGET_PROPERTIES(sagittarius--atomic PROPERTIES SUFFIX ".dylib")
+ENDIF()
+TARGET_LINK_LIBRARIES(sagittarius--atomic sagittarius)
+
+INSTALL(TARGETS sagittarius--atomic
+  DESTINATION ${SAGITTARIUS_DYNLIB_PATH})
+INSTALL(FILES sagittarius/atomic.scm
+  DESTINATION ${SAGITTARIUS_SHARE_LIB_PATH}/sagittarius)
+
+FILE(APPEND ${EXT_TEST_RESOURCE_FILE} "${CMAKE_CURRENT_SOURCE_DIR}\n")

src/lib_atomic.stub renamed to ext/atomic/atomic.stub

@@ -25,25 +25,22 @@
 ;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 ;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-(library (sagittarius atomic)
-    (export :only-bindings)
-    (import (core))
-
 (decl-code
- (.define "LIBSAGITTARIUS_BODY")
+ (.define "LIBSAGITTARIUS_EXT_BODY")
  (.include <sagittarius/private.h>
-	   <sagittarius/private/atomic.h>))
+	   <sagittarius/extend.h>
+	   "sagittarius-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"
-  "Sg_MemoryOrderP" "SG_INT_VALUE" "SG_MAKE_INT")
+  "Sg_MemoryOrderP" "SCM_TO_MEMORY_ORDER" "MEMORY_ORDER_TO_SCM")
 
 (define-cise-expr default-memory-order
-  ((_) '(SG_MAKE_INT memory_order_seq_cst)))
+  ((_) '(MEMORY_ORDER_TO_SCM memory_order_seq_cst)))
 
 (define-c-proc memory-order? (obj) ::<boolean> Sg_MemoryOrderP)
 
@@ -63,7 +60,7 @@
 
 (define-c-proc atomic-fixnum-add! (a::<atomic-fixnum> v::<fixnum> :optional (order::<memory-order> (default-memory-order))) ::<fixnum> Sg_AtomicFixnumAdd)
 (define-c-proc atomic-fixnum-sub! (a::<atomic-fixnum> v::<fixnum> :optional (order::<memory-order> (default-memory-order))) ::<fixnum> Sg_AtomicFixnumSub)
-(define-c-proc atomic-fixnum-or! (a::<atomic-fixnum> v::<fixnum> :optional (order::<memory-order> (default-memory-order))) ::<fixnum> Sg_AtomicFixnumOr)
+(define-c-proc atomic-fixnum-ior! (a::<atomic-fixnum> v::<fixnum> :optional (order::<memory-order> (default-memory-order))) ::<fixnum> Sg_AtomicFixnumIor)
 (define-c-proc atomic-fixnum-xor! (a::<atomic-fixnum> v::<fixnum> :optional (order::<memory-order> (default-memory-order))) ::<fixnum> Sg_AtomicFixnumXor)
 (define-c-proc atomic-fixnum-and! (a::<atomic-fixnum> v::<fixnum> :optional (order::<memory-order> (default-memory-order))) ::<fixnum> Sg_AtomicFixnumAnd)
 
@@ -74,9 +71,3 @@
 
 (define-c-proc atomic-thread-fence (order::<memory-order>) ::<void> Sg_AtomicThreadFence)
 
-(define (atomic-fixnum-inc! atomic . opts)
-  (apply atomic-fixnum-add! atomic 1 opts))
-(define (atomic-fixnum-dec! atomic . opts)
-  (apply atomic-fixnum-sub! atomic 1 opts))
-
-)

src/atomic.c renamed to ext/atomic/sagittarius-atomic.c

@@ -26,16 +26,21 @@
  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  */
 #include <stddef.h>
-#define LIBSAGITTARIUS_BODY
-#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"
+#define LIBSAGITTARIUS_EXT_BODY
+#include <sagittarius/extend.h>
+#include "sagittarius-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>
 
-#ifndef HAVE_STDATOMIC_H
+#if !defined(HAVE_STDATOMIC_H) && defined(HAVE_CPP_ATOMIC)
+
+using namespace std;
+
+#elif !defined(HAVE_STDATOMIC_H) && !defined(HAVE_CPP_ATOMIC)
 
 #include <atomic_ops.h>
 
@@ -72,6 +77,8 @@ static void ao_store_explicit(volatile AO_t *o, AO_t v, memory_order order)
 {
   switch (order) {
   case memory_order_release:
+  case memory_order_acq_rel:
+  case memory_order_seq_cst:
     AO_store_release(o, v);
     break;
   default:
@@ -141,7 +148,7 @@ static AO_t ao_fetch_or(volatile AO_t *o, AO_t v, memory_order order)
   }
   return r;
 }
-static void ao_fetch_xor(volatile AO_t *o, AO_t v, memory_order order)
+static AO_t ao_fetch_xor(volatile AO_t *o, AO_t v, memory_order order)
 {
   AO_t r = ao_load_explicit(o, order);
   /* handle_memory_order((void), AO_xor, order, o, v); */
@@ -163,7 +170,7 @@ static void ao_fetch_xor(volatile AO_t *o, AO_t v, memory_order order)
   }
   return r;
 }
-static void ao_fetch_and(volatile AO_t *o, AO_t v, memory_order order)
+static AO_t ao_fetch_and(volatile AO_t *o, AO_t v, memory_order order)
 {
   AO_t r = ao_load_explicit(o, order);
   /* handle_memory_order((void), AO_and, order, o, v); */
@@ -190,18 +197,18 @@ static void ao_thread_fence(memory_order order)
 {
   switch (order) {
     case memory_order_relaxed:
-      AO_nop(o, v);
+      AO_nop();
       break;
     case memory_order_consume:
     case memory_order_acquire:
-      AO_nop_read(o, v);
+      AO_nop_read();
       break;
     case memory_order_release:
-      AO_nop_write(o, v);
+      AO_nop_write();
       break;
     case memory_order_acq_rel:
     case memory_order_seq_cst:
-      AO_nop_full(o, v);
+      AO_nop_full();
       break;
   }
 }
@@ -266,6 +273,9 @@ static void atomic_print(SgObject obj, SgPort *port, SgWriteContext *ctx)
   if (SG_ATOMIC_FIXNUM_P(obj)) {
     Sg_Printf(port, UC("#<atomic-fixnum %d>"),
 	      atomic_load_explicit(&SG_ATOMIC_REF_FIXNUM(obj), memory_order_relaxed));
+  } else if (SG_ATOMIC_PAIR_P(obj)) {
+    pair_t v = atomic_load_explicit(&SG_ATOMIC_REF_PAIR(obj), memory_order_relaxed);
+    Sg_Printf(port, UC("#<atomic-pair %S>"), Sg_Cons(v.car, v.cdr));
   } else {
     Sg_Printf(port, UC("#<atomic %S>"),
 	      atomic_load_explicit(&SG_ATOMIC_REF_OBJECT(obj), memory_order_relaxed));
@@ -330,7 +340,7 @@ void Sg_AtomicStore(volatile SgAtomic *o, SgObject v, SgMemoryOrder order)
     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 v2 = { SG_CAR(v), 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);
@@ -350,7 +360,7 @@ SgObject Sg_AtomicExchange(volatile SgAtomic *o, SgObject v, SgMemoryOrder order
     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 v2 = { SG_CAR(v), SG_CDR(v) };
     pair_t r = atomic_exchange_explicit(&SG_ATOMIC_REF_PAIR(o), v2, order);
     return Sg_Cons(r.car, r.cdr);
   } else {
@@ -402,7 +412,7 @@ long Sg_AtomicFixnumSub(volatile SgAtomic *o, long v, SgMemoryOrder order)
 {
   atomic_math(o, v, order, atomic_fetch_sub_explicit);
 }
-long Sg_AtomicFixnumOr(volatile SgAtomic *o, long v, SgMemoryOrder order)
+long Sg_AtomicFixnumIor(volatile SgAtomic *o, long v, SgMemoryOrder order)
 {
   atomic_math(o, v, order, atomic_fetch_or_explicit);
 }
@@ -435,8 +445,8 @@ int Sg_AtomicCompareAndSwap(volatile SgAtomic *o, SgObject e, SgObject 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) };
+      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),
 						     &ev, vv, success, failure);
     }
@@ -455,16 +465,16 @@ void Sg_AtomicThreadFence(SgMemoryOrder order)
   atomic_thread_fence(order);
 }
 
-extern void Sg__Init_sagittarius_atomic();
+extern void Sg__Init_atomic(SgLibrary *lib);
 
-void Sg__InitAtomic()
+SG_EXTENSION_ENTRY void CDECL Sg_Init_sagittarius__atomic()
 {
   SgObject lib = Sg_FindLibrary(SG_INTERN("(sagittarius atomic)"), TRUE);
-
-  Sg__Init_sagittarius_atomic();
-
+  SG_INIT_EXTENSION(sagittarius__atomic);
+  Sg__Init_atomic(SG_LIBRARY(lib));
+  
 #define insert_binding(name, value)					\
-  Sg_MakeBinding(SG_LIBRARY(lib), SG_INTERN(#name), SG_MAKE_INT(value), TRUE)
+  Sg_MakeBinding(SG_LIBRARY(lib), SG_INTERN(#name), MEMORY_ORDER_TO_SCM(value), TRUE)
 
   insert_binding(*memory-order:relaxed*, memory_order_relaxed);
   insert_binding(*memory-order:consume*, memory_order_consume);