Add atomic boxes

* doc/ref/api-scheduling.texi (Atomics): New manual section.
* libguile.h: Include atomic.h.
* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
  (DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Add atomic.
* libguile/atomic.c:
* libguile/atomic.h: New files.
* libguile/atomics-internal.h (scm_atomic_set_scm, scm_atomic_ref_scm)
  (scm_atomic_swap_scm, scm_atomic_compare_and_swap_scm): New
  facilities.
* libguile/goops.c (class_atomic_box, scm_sys_goops_early_init): Add
  support for <atomic-box>.  Remove duplicate <keyword> fetch.
* libguile/init.c (scm_i_init_guile): Call scm_register_atomic_box.
* libguile/print.c (iprin1): Add atomic box case.
* libguile/tags.h (scm_tc7_atomic_box): New tag.
* libguile/validate.h (SCM_VALIDATE_ATOMIC_BOX): New macro.
* module/Makefile.am (SOURCES): Add ice-9/atomic.scm.
* module/ice-9/atomic.scm: New file.
* module/oop/goops.scm (<atomic-box>): New var.

doc/ref/api-scheduling.texi

@@ -10,6 +10,7 @@
 @menu
 * Arbiters::                    Synchronization primitives.
 * Asyncs::                      Asynchronous procedure invocation.
+* Atomics::                     Atomic references.
 * Threads::                     Multiple threads of execution.
 * Mutexes and Condition Variables:: Synchronization primitives.
 * Blocking::                    How to block properly in guile mode.
@@ -191,6 +192,72 @@ Mark the user async @var{a} for future execution.
 Execute all thunks from the marked asyncs of the list @var{list_of_a}.
 @end deffn
 
+@node Atomics
+@subsection Atomics
+
+When accessing data in parallel from multiple threads, updates made by
+one thread are not generally guaranteed to be visible by another thread.
+It could be that your hardware requires special instructions to be
+emitted to propagate a change from one CPU core to another.  Or, it
+could be that your hardware updates values with a sequence of
+instructions, and a parallel thread could see a value that is in the
+process of being updated but not fully updated.
+
+Atomic references solve this problem.  Atomics are a standard, primitive
+facility to allow for concurrent access and update of mutable variables
+from multiple threads with guaranteed forward-progress and well-defined
+intermediate states.
+
+Atomic references serve not only as a hardware memory barrier but also
+as a compiler barrier.  Normally a compiler might choose to reorder or
+elide certain memory accesses due to optimizations like common
+subexpression elimination.  Atomic accesses however will not be
+reordered relative to each other, and normal memory accesses will not be
+reordered across atomic accesses.
+
+As an implementation detail, currently all atomic accesses and updates
+use the sequential consistency memory model from C11.  We may relax this
+in the future to the acquire/release semantics, which still issues a
+memory barrier so that non-atomic updates are not reordered across
+atomic accesses or updates.
+
+To use Guile's atomic operations, load the @code{(ice-9 atomic)} module:
+
+@example
+(use-modules (ice-9 atomic))
+@end example
+
+@deffn {Scheme Procedure} make-atomic-box init
+Return an atomic box initialized to value @var{init}.
+@end deffn
+
+@deffn {Scheme Procedure} atomic-box? obj
+Return @code{#t} if @var{obj} is an atomic-box object, else
+return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} atomic-box-ref box
+Fetch the value stored in the atomic box @var{box} and return it.
+@end deffn
+
+@deffn {Scheme Procedure} atomic-box-set! box  val
+Store @var{val} into the atomic box @var{box}.
+@end deffn
+
+@deffn {Scheme Procedure} atomic-box-swap! box val
+Store @var{val} into the atomic box @var{box}, and return the value that
+was previously stored in the box.
+@end deffn
+
+@deffn {Scheme Procedure} atomic-box-compare-and-swap! box expected desired
+If the value of the atomic box @var{box} is the same as, @var{expected}
+(in the sense of @code{eq?}), replace the contents of the box with
+@var{desired}.  Otherwise does not update the box.  Returns the previous
+value of the box in either case, so you can know if the swap worked by
+checking if the return value is @code{eq?} to @var{expected}.
+@end deffn
+
+
 @node Threads
 @subsection Threads
 @cindex threads

libguile.h

@@ -35,6 +35,7 @@ extern "C" {
 #include "libguile/array-map.h"
 #include "libguile/arrays.h"
 #include "libguile/async.h"
+#include "libguile/atomic.h"
 #include "libguile/boolean.h"
 #include "libguile/bitvectors.h"
 #include "libguile/bytevectors.h"

libguile/Makefile.am

@@ -125,6 +125,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =				\
 	array-map.c				\
 	arrays.c				\
 	async.c					\
+	atomic.c				\
 	backtrace.c				\
 	boolean.c				\
 	bitvectors.c				\
@@ -235,6 +236,7 @@ DOT_X_FILES =					\
 	array-map.x				\
 	arrays.x				\
 	async.x					\
+	atomic.x				\
 	backtrace.x				\
 	boolean.x				\
 	bitvectors.x				\
@@ -342,6 +344,7 @@ DOT_DOC_FILES = 				\
 	array-map.doc				\
 	arrays.doc				\
 	async.doc				\
+	atomic.doc				\
 	backtrace.doc				\
 	boolean.doc				\
 	bitvectors.doc				\
@@ -569,6 +572,7 @@ modinclude_HEADERS =				\
 	array-map.h				\
 	arrays.h				\
 	async.h					\
+	atomic.h				\
 	backtrace.h				\
 	bdw-gc.h				\
 	boolean.h				\

libguile/atomic.c

@@ -0,0 +1,128 @@
+/* Copyright (C) 2016 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/ports.h"
+#include "libguile/validate.h"
+#include "libguile/atomics-internal.h"
+#include "libguile/atomic.h"
+
+
+SCM_DEFINE (scm_make_atomic_box, "make-atomic-box", 1, 0, 0,
+            (SCM init),
+            "Return an atomic box initialized to value @var{init}.")
+#define FUNC_NAME s_scm_make_atomic_box
+{
+  SCM ret = scm_cell (scm_tc7_atomic_box, SCM_UNPACK (SCM_UNDEFINED));
+  scm_atomic_box_set_x (ret, init);
+  return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_atomic_box_p, "atomic-box?", 1, 0, 0,
+            (SCM obj),
+            "Return @code{#t} if @var{obj} is an atomic-box object, else\n"
+	    "return @code{#f}.")
+#define FUNC_NAME s_scm_atomic_box_p
+{
+  return scm_from_bool (scm_is_atomic_box (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_atomic_box_ref, "atomic-box-ref", 1, 0, 0,
+            (SCM box),
+            "Fetch the value stored in the atomic box @var{box} and\n"
+            "return it.")
+#define FUNC_NAME s_scm_atomic_box_ref
+{
+  SCM_VALIDATE_ATOMIC_BOX (1, box);
+  return scm_atomic_ref_scm (scm_atomic_box_loc (box));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_atomic_box_set_x, "atomic-box-set!", 2, 0, 0,
+            (SCM box, SCM val),
+            "Store @var{val} into the atomic box @var{box}.")
+#define FUNC_NAME s_scm_atomic_box_set_x
+{
+  SCM_VALIDATE_ATOMIC_BOX (1, box);
+  scm_atomic_set_scm (scm_atomic_box_loc (box), val);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_atomic_box_swap_x, "atomic-box-swap!", 2, 0, 0,
+            (SCM box, SCM val),
+            "Store @var{val} into the atomic box @var{box},\n"
+            "and return the value that was previously stored in\n"
+            "the box.")
+#define FUNC_NAME s_scm_atomic_box_swap_x
+{
+  SCM_VALIDATE_ATOMIC_BOX (1, box);
+  return scm_atomic_swap_scm (scm_atomic_box_loc (box), val);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_atomic_box_compare_and_swap_x,
+            "atomic-box-compare-and-swap!", 3, 0, 0,
+            (SCM box, SCM expected, SCM desired),
+            "If the value of the atomic box @var{box} is the same as,\n"
+            "@var{expected} (in the sense of @code{eq?}), replace the\n"
+            "contents of the box with @var{desired}.  Otherwise does not\n"
+            "update the box.  Returns the previous value of the box in\n"
+            "either case, so you can know if the swap worked by checking\n"
+            "if the return value is @code{eq?} to @var{expected}.")
+#define FUNC_NAME s_scm_atomic_box_compare_and_swap_x
+{
+  SCM_VALIDATE_ATOMIC_BOX (1, box);
+  scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (box),
+                                   &expected, desired);
+  return expected;
+}
+#undef FUNC_NAME
+
+void
+scm_i_atomic_box_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+  scm_puts ("#<atomic-box ", port);
+  scm_uintprint (SCM_UNPACK (exp), 16, port);
+  scm_puts (" value: ", port);
+  scm_iprin1 (scm_atomic_box_ref (exp), port, pstate);
+  scm_putc ('>', port);
+}
+
+static void
+scm_init_atomic (void)
+{
+#include "libguile/atomic.x"
+}
+
+void
+scm_register_atomic (void)
+{
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_atomic",
+			    (scm_t_extension_init_func) scm_init_atomic,
+			    NULL);
+}

libguile/atomic.h

@@ -0,0 +1,56 @@
+#ifndef SCM_ATOMIC_H
+#define SCM_ATOMIC_H
+
+/* Copyright (C) 2016 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+#include "libguile/gc.h"
+#include "libguile/tags.h"
+
+
+
+static inline int
+scm_is_atomic_box (SCM obj)
+{
+  return SCM_HAS_TYP7 (obj, scm_tc7_atomic_box);
+}
+
+static inline SCM*
+scm_atomic_box_loc (SCM obj)
+{
+  return SCM_CELL_OBJECT_LOC (obj, 1);
+}
+
+
+
+#ifdef BUILDING_LIBGUILE
+SCM_INTERNAL SCM scm_make_atomic_box (SCM init);
+SCM_INTERNAL SCM scm_atomic_box_p (SCM obj);
+SCM_INTERNAL SCM scm_atomic_box_ref (SCM box);
+SCM_INTERNAL SCM scm_atomic_box_set_x (SCM box, SCM val);
+SCM_INTERNAL SCM scm_atomic_box_swap_x (SCM box, SCM val);
+SCM_INTERNAL SCM scm_atomic_box_compare_and_swap_x (SCM box, SCM expected, SCM desired);
+SCM_INTERNAL void scm_i_atomic_box_print (SCM box, SCM port, scm_print_state *pstate);
+
+SCM_INTERNAL void scm_register_atomic (void);
+#endif  /* BUILDING_LIBGUILE */
+
+#endif  /* SCM_ATOMIC_H */

libguile/atomics-internal.h

@@ -34,46 +34,110 @@
 
 #include <stdatomic.h>
 static inline uint32_t
-scm_atomic_subtract_uint32 (uint32_t *obj, uint32_t arg)
+scm_atomic_subtract_uint32 (uint32_t *loc, uint32_t arg)
 {
-  return atomic_fetch_sub (obj, arg);
+  return atomic_fetch_sub (loc, arg);
 }
 static inline _Bool
-scm_atomic_compare_and_swap_uint32 (uint32_t *obj, uint32_t *expected,
+scm_atomic_compare_and_swap_uint32 (uint32_t *loc, uint32_t *expected,
                                     uint32_t desired)
 {
-  return atomic_compare_exchange_weak (obj, expected, desired);
+  return atomic_compare_exchange_weak (loc, expected, desired);
+}
+static inline void
+scm_atomic_set_scm (SCM *loc, SCM val)
+{
+  atomic_store (loc, val);
+}
+static inline SCM
+scm_atomic_ref_scm (SCM *loc)
+{
+  return atomic_load (loc);
+}
+static inline SCM
+scm_atomic_swap_scm (SCM *loc, SCM val)
+{
+  return atomic_exchange (loc, val);
+}
+static inline _Bool
+scm_atomic_compare_and_swap_scm (SCM *loc, SCM *expected, SCM desired)
+{
+  return atomic_compare_exchange_weak (loc, expected, desired);
 }
-
 #else /* HAVE_C11_ATOMICS */
 
 /* Fallback implementation using locks.  */
 #include "libguile/threads.h"
 static scm_i_pthread_mutex_t atomics_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 static inline uint32_t
-scm_atomic_subtract_uint32 (uint32_t *obj, uint32_t arg)
+scm_atomic_subtract_uint32 (uint32_t *loc, uint32_t arg)
 {
   uint32_t ret;
   scm_i_pthread_mutex_lock (&atomics_lock);
-  ret = *obj;
-  *obj -= arg;
+  ret = *loc;
+  *loc -= arg;
   scm_i_pthread_mutex_unlock (&atomics_lock);
   return ret;
 }
 static inline int
-scm_atomic_compare_and_swap_uint32 (uint32_t *obj, uint32_t *expected,
+scm_atomic_compare_and_swap_uint32 (uint32_t *loc, uint32_t *expected,
                                     uint32_t desired)
 {
   int ret;
   scm_i_pthread_mutex_lock (&atomics_lock);
-  if (*obj == *expected)
+  if (*loc == *expected)
     {
-      *obj = desired;
+      *loc = desired;
       ret = 1;
     }
   else
     {
-      *expected = *obj;
+      *expected = *loc;
+      ret = 0;
+    }
+  scm_i_pthread_mutex_unlock (&atomics_lock);
+  return ret;
+}
+
+static inline void
+scm_atomic_set_scm (SCM *loc, SCM val)
+{
+  scm_i_pthread_mutex_lock (&atomics_lock);
+  *loc = val;
+  scm_i_pthread_mutex_unlock (&atomics_lock);
+}
+static inline SCM
+scm_atomic_ref_scm (SCM *loc)
+{
+  SCM ret;
+  scm_i_pthread_mutex_lock (&atomics_lock);
+  ret = *loc;
+  scm_i_pthread_mutex_unlock (&atomics_lock);
+  return ret;
+}
+static inline SCM
+scm_atomic_swap_scm (SCM *loc, SCM val)
+{
+  SCM ret;
+  scm_i_pthread_mutex_lock (&atomics_lock);
+  ret = *loc;
+  *loc = val;
+  scm_i_pthread_mutex_unlock (&atomics_lock);
+  return ret;
+}
+static inline int
+scm_atomic_compare_and_swap_scm (SCM *loc, SCM *expected, SCM desired)
+{
+  int ret;
+  scm_i_pthread_mutex_lock (&atomics_lock);
+  if (*loc == *expected)
+    {
+      *loc = desired;
+      ret = 1;
+    }
+  else
+    {
+      *expected = *loc;
       ret = 0;
     }
   scm_i_pthread_mutex_unlock (&atomics_lock);

libguile/goops.c

@@ -110,6 +110,7 @@ static SCM class_applicable_struct_class;
 static SCM class_applicable_struct_with_setter_class;
 static SCM class_number, class_list;
 static SCM class_keyword;
+static SCM class_atomic_box;
 static SCM class_port, class_input_output_port;
 static SCM class_input_port, class_output_port;
 static SCM class_foreign_slot;
@@ -124,7 +125,6 @@ static SCM class_hashtable;
 static SCM class_fluid;
 static SCM class_dynamic_state;
 static SCM class_frame;
-static SCM class_keyword;
 static SCM class_vm_cont;
 static SCM class_bytevector;
 static SCM class_uvec;
@@ -227,6 +227,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 	  return class_frame;
         case scm_tc7_keyword:
 	  return class_keyword;
+        case scm_tc7_atomic_box:
+	  return class_atomic_box;
         case scm_tc7_vm_cont:
 	  return class_vm_cont;
 	case scm_tc7_bytevector:
@@ -998,6 +1000,7 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
   class_dynamic_state = scm_variable_ref (scm_c_lookup ("<dynamic-state>"));
   class_frame = scm_variable_ref (scm_c_lookup ("<frame>"));
   class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
+  class_atomic_box = scm_variable_ref (scm_c_lookup ("<atomic-box>"));
   class_vm_cont = scm_variable_ref (scm_c_lookup ("<vm-continuation>"));
   class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
   class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
@@ -1008,7 +1011,6 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
   class_real = scm_variable_ref (scm_c_lookup ("<real>"));
   class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
   class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
-  class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
   class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
   class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
   class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));

libguile/init.c

@@ -37,6 +37,7 @@
 #include "libguile/alist.h"
 #include "libguile/arbiters.h"
 #include "libguile/async.h"
+#include "libguile/atomic.h"
 #include "libguile/backtrace.h"
 #include "libguile/bitvectors.h"
 #include "libguile/boolean.h"
@@ -398,6 +399,7 @@ scm_i_init_guile (void *base)
   scm_bootstrap_loader ();
   scm_bootstrap_programs ();
   scm_bootstrap_vm ();
+  scm_register_atomic ();
   scm_register_r6rs_ports ();
   scm_register_fdes_finalizers ();
   scm_register_foreign ();

libguile/print.c

@@ -717,6 +717,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
           scm_puts ("#:", port);
           scm_iprin1 (scm_keyword_to_symbol (exp), port, pstate);
           break;
+	case scm_tc7_atomic_box:
+	  scm_i_atomic_box_print (exp, port, pstate);
+	  break;
 	case scm_tc7_vm_cont:
 	  scm_i_vm_cont_print (exp, port, pstate);
 	  break;

libguile/tags.h

@@ -415,7 +415,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
 #define scm_tc7_dynamic_state	0x2d
 #define scm_tc7_frame		0x2f
 #define scm_tc7_keyword		0x35
-#define scm_tc7_unused_37	0x37
+#define scm_tc7_atomic_box	0x37
 #define scm_tc7_unused_3d	0x3d
 #define scm_tc7_unused_3f	0x3f
 #define scm_tc7_program		0x45

libguile/validate.h

@@ -300,6 +300,12 @@
 
 #define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable")
 
+#define SCM_VALIDATE_ATOMIC_BOX(pos, var) \
+  do { \
+    SCM_ASSERT_TYPE (scm_is_atomic_box (var), var, pos, FUNC_NAME, \
+                     "atomic box");                                \
+  } while (0)
+
 #define SCM_VALIDATE_PROC(pos, proc) \
   do { \
     SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \

module/Makefile.am

@@ -44,6 +44,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
 
 SOURCES =					\
   ice-9/and-let-star.scm			\
+  ice-9/atomic.scm				\
   ice-9/binary-ports.scm			\
   ice-9/boot-9.scm				\
   ice-9/buffered-input.scm			\

module/ice-9/atomic.scm

@@ -0,0 +1,30 @@
+;; Atomic operations
+
+;;;; Copyright (C) 2016 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 atomic)
+  #:export (make-atomic-box
+            atomic-box?
+            atomic-box-ref
+            atomic-box-set!
+            atomic-box-swap!
+            atomic-box-compare-and-swap!))
+
+(eval-when (expand load eval)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_atomic"))

module/oop/goops.scm

@@ -62,7 +62,7 @@
             <boolean> <char> <list> <pair> <null> <string> <symbol>
             <vector> <bytevector> <uvec> <foreign> <hashtable>
             <fluid> <dynamic-state> <frame> <vm> <vm-continuation>
-            <keyword>
+            <keyword> <atomic-box>
 
             ;; Numbers.
             <number> <complex> <real> <integer> <fraction>
@@ -1009,6 +1009,7 @@ slots as we go."
 (define-standard-class <integer> (<real>))
 (define-standard-class <fraction> (<real>))
 (define-standard-class <keyword> (<top>))
+(define-standard-class <atomic-box> (<top>))
 (define-standard-class <unknown> (<top>))
 (define-standard-class <procedure> (<applicable>)
   #:metaclass <procedure-class>)

test-suite/tests/atomic.test

@@ -0,0 +1,59 @@
+;;;; atomic.test --- test suite for Guile's atomic operations -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2016 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite atomic)
+  #:use-module (ice-9 atomic)
+  #:use-module ((oop goops) #:select (class-of <atomic-box>))
+  #:use-module (test-suite lib))
+
+(pass-if (atomic-box? (make-atomic-box 42)))
+
+(pass-if-equal 42 (atomic-box-ref (make-atomic-box 42)))
+
+(pass-if-equal 42 (atomic-box-swap! (make-atomic-box 42) 10))
+
+(pass-if-equal 10
+  (let ((box (make-atomic-box 42)))
+    (atomic-box-set! box 10)
+    (atomic-box-ref box)))
+
+(pass-if-equal 10
+  (let ((box (make-atomic-box 42)))
+    (atomic-box-swap! box 10)
+    (atomic-box-ref box)))
+
+(pass-if-equal 42
+  (let ((box (make-atomic-box 42)))
+    (atomic-box-compare-and-swap! box 42 10)))
+
+(pass-if-equal 42
+  (let ((box (make-atomic-box 42)))
+    (atomic-box-compare-and-swap! box 43 10)))
+
+(pass-if-equal 10
+  (let ((box (make-atomic-box 42)))
+    (atomic-box-compare-and-swap! box 42 10)
+    (atomic-box-ref box)))
+
+(pass-if-equal 42
+  (let ((box (make-atomic-box 42)))
+    (atomic-box-compare-and-swap! box 43 10)
+    (atomic-box-ref box)))
+
+(pass-if-equal <atomic-box>
+  (class-of (make-atomic-box 42)))