diff options
| -rw-r--r-- | doc/ref/api-scheduling.texi | 67 | ||||
| -rw-r--r-- | libguile.h | 1 | ||||
| -rw-r--r-- | libguile/Makefile.am | 4 | ||||
| -rw-r--r-- | libguile/atomic.c | 128 | ||||
| -rw-r--r-- | libguile/atomic.h | 56 | ||||
| -rw-r--r-- | libguile/atomics-internal.h | 88 | ||||
| -rw-r--r-- | libguile/goops.c | 6 | ||||
| -rw-r--r-- | libguile/init.c | 2 | ||||
| -rw-r--r-- | libguile/print.c | 3 | ||||
| -rw-r--r-- | libguile/tags.h | 2 | ||||
| -rw-r--r-- | libguile/validate.h | 6 | ||||
| -rw-r--r-- | module/Makefile.am | 1 | ||||
| -rw-r--r-- | module/ice-9/atomic.scm | 30 | ||||
| -rw-r--r-- | module/oop/goops.scm | 3 | ||||
| -rw-r--r-- | 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 0d036be9e..38f5ac4a2 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 +@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 diff --git a/libguile.h b/libguile.h index d2030eb86..8354e7cca 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 ba6be2019..e5011da91 100644 --- a/libguile/Makefile.am +++ b/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 \ diff --git a/libguile/atomic.c b/libguile/atomic.c new file mode 100644 index 000000000..950874030 --- /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 000000000..9a33f8d1a --- /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 1859daa92..9d18cbc1a 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 3ed60d3f3..4e28d06fb 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 1e4889c97..3738538ae 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 2485d9716..8161d6581 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 3d6f4bb6a..8f44d96b2 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 516a6f750..7c0ce9bbd 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 00c394738..0d1f128f1 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 000000000..21dba3938 --- /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 5a5d469eb..6dae45418 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 000000000..f6e0c8863 --- /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))) |