[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/06: Add atomic boxes
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 04/06: Add atomic boxes |
|
Date: |
Tue, 6 Sep 2016 10:21:49 +0000 (UTC) |
wingo pushed a commit to branch master
in repository guile.
commit 3425290a7b1249b8901eabf089869846d05eeb1e
Author: Andy Wingo <address@hidden>
Date: Tue Sep 6 11:04:25 2016 +0200
Add atomic boxes
* doc/ref/api-scheduling.texi (Atomics): New manual section.
* libguile.h: Include atomic.h.
* libguile/Makefile.am (address@hidden@_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 | 67 ++++++++++++++++++++++
libguile.h | 1 +
libguile/Makefile.am | 4 ++
libguile/atomic.c | 128 ++++++++++++++++++++++++++++++++++++++++++
libguile/atomic.h | 56 ++++++++++++++++++
libguile/atomics-internal.h | 88 +++++++++++++++++++++++++----
libguile/goops.c | 6 +-
libguile/init.c | 2 +
libguile/print.c | 3 +
libguile/tags.h | 2 +-
libguile/validate.h | 6 ++
module/Makefile.am | 1 +
module/ice-9/atomic.scm | 30 ++++++++++
module/oop/goops.scm | 3 +-
test-suite/tests/atomic.test | 59 +++++++++++++++++++
15 files changed, 440 insertions(+), 16 deletions(-)
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index 0d036be..38f5ac4 100644
--- a/doc/ref/api-scheduling.texi
+++ b/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
address@hidden Atomics
address@hidden 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:
+
address@hidden
+(use-modules (ice-9 atomic))
address@hidden example
+
address@hidden {Scheme Procedure} make-atomic-box init
+Return an atomic box initialized to value @var{init}.
address@hidden deffn
+
address@hidden {Scheme Procedure} atomic-box? obj
+Return @code{#t} if @var{obj} is an atomic-box object, else
+return @code{#f}.
address@hidden deffn
+
address@hidden {Scheme Procedure} atomic-box-ref box
+Fetch the value stored in the atomic box @var{box} and return it.
address@hidden deffn
+
address@hidden {Scheme Procedure} atomic-box-set! box val
+Store @var{val} into the atomic box @var{box}.
address@hidden deffn
+
address@hidden {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.
address@hidden deffn
+
address@hidden {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
address@hidden 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}.
address@hidden deffn
+
+
@node Threads
@subsection Threads
@cindex threads
diff --git a/libguile.h b/libguile.h
index d2030eb..8354e7c 100644
--- a/libguile.h
+++ b/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"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ba6be20..e5011da 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -125,6 +125,7 @@ address@hidden@_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 \
diff --git a/libguile/atomic.c b/libguile/atomic.c
new file mode 100644
index 0000000..9508740
--- /dev/null
+++ b/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);
+}
diff --git a/libguile/atomic.h b/libguile/atomic.h
new file mode 100644
index 0000000..9a33f8d
--- /dev/null
+++ b/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 */
diff --git a/libguile/atomics-internal.h b/libguile/atomics-internal.h
index 1859daa..9d18cbc 100644
--- a/libguile/atomics-internal.h
+++ b/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)
+ {
+ *loc = desired;
+ ret = 1;
+ }
+ else
+ {
+ *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)
{
- *obj = desired;
+ *loc = desired;
ret = 1;
}
else
{
- *expected = *obj;
+ *expected = *loc;
ret = 0;
}
scm_i_pthread_mutex_unlock (&atomics_lock);
diff --git a/libguile/goops.c b/libguile/goops.c
index 3ed60d3..4e28d06 100644
--- a/libguile/goops.c
+++ b/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>"));
diff --git a/libguile/init.c b/libguile/init.c
index 1e4889c..3738538 100644
--- a/libguile/init.c
+++ b/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 ();
diff --git a/libguile/print.c b/libguile/print.c
index 2485d97..8161d65 100644
--- a/libguile/print.c
+++ b/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;
diff --git a/libguile/tags.h b/libguile/tags.h
index 3d6f4bb..8f44d96 100644
--- a/libguile/tags.h
+++ b/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
diff --git a/libguile/validate.h b/libguile/validate.h
index 516a6f7..7c0ce9b 100644
--- a/libguile/validate.h
+++ b/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); \
diff --git a/module/Makefile.am b/module/Makefile.am
index 00c3947..0d1f128 100644
--- a/module/Makefile.am
+++ b/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 \
diff --git a/module/ice-9/atomic.scm b/module/ice-9/atomic.scm
new file mode 100644
index 0000000..21dba39
--- /dev/null
+++ b/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"))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 5a5d469..6dae454 100644
--- a/module/oop/goops.scm
+++ b/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>)
diff --git a/test-suite/tests/atomic.test b/test-suite/tests/atomic.test
new file mode 100644
index 0000000..f6e0c88
--- /dev/null
+++ b/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)))
- [Guile-commits] branch master updated (605a01b -> 32f309d), Andy Wingo, 2016/09/06
- [Guile-commits] 02/06: Tweak value of tc7-smob., Andy Wingo, 2016/09/06
- [Guile-commits] 04/06: Add atomic boxes,
Andy Wingo <=
- [Guile-commits] 03/06: Reorder tc7 type codes, Andy Wingo, 2016/09/06
- [Guile-commits] 05/06: Fix fixnum min/max for assembler, Andy Wingo, 2016/09/06
- [Guile-commits] 06/06: Compiler support for atomics, Andy Wingo, 2016/09/06
- [Guile-commits] 01/06: Convert tc7 values to hex in tags.h and elsewhere, Andy Wingo, 2016/09/06