summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/vm.texi32
-rw-r--r--libguile/vm-engine.c95
-rw-r--r--libguile/vm.c30
-rw-r--r--module/ice-9/atomic.scm10
-rw-r--r--module/language/cps/compile-bytecode.scm15
-rw-r--r--module/language/cps/effects-analysis.scm4
-rw-r--r--module/language/cps/reify-primitives.scm4
-rw-r--r--module/language/tree-il/primitives.scm4
-rw-r--r--module/system/vm/assembler.scm5
-rw-r--r--test-suite/tests/atomic.test55
10 files changed, 208 insertions, 46 deletions
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 9766ccb67..e870f7391 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -580,6 +580,7 @@ all operands and results are boxed as SCM values.
* Dynamic Environment Instructions::
* Miscellaneous Instructions::
* Inlined Scheme Instructions::
+* Inlined Atomic Instructions::
* Inlined Mathematical Instructions::
* Inlined Bytevector Instructions::
* Unboxed Integer Arithmetic::
@@ -1365,6 +1366,37 @@ Convert the Scheme character in @var{src} to an integer, and place it in
@end deftypefn
+@node Inlined Atomic Instructions
+@subsubsection Inlined Atomic Instructions
+
+@xref{Atomics}, for more on atomic operations in Guile.
+
+@deftypefn Instruction {} make-atomic-box s12:@var{dst} s12:@var{src}
+Create a new atomic box initialized to @var{src}, and place it in
+@var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} atomic-box-ref s12:@var{dst} s12:@var{box}
+Fetch the value of the atomic box at @var{box} into @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} atomic-box-set! s12:@var{box} s12:@var{val}
+Set the contents of the atomic box at @var{box} to @var{val}.
+@end deftypefn
+
+@deftypefn Instruction {} atomic-box-swap! s12:@var{dst} s12:@var{box} x8:@var{_} s24:@var{val}
+Replace the contents of the atomic box at @var{box} to @var{val} and
+store the previous value at @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} atomic-box-compare-and-swap! s12:@var{dst} s12:@var{box} x8:@var{_} s24:@var{expected} x8:@var{_} s24:@var{desired}
+If the value of the atomic box at @var{box} is the same as the SCM value
+at @var{expected} (in the sense of @code{eq?}), replace the contents of
+the box with the SCM value at @var{desired}. Otherwise does not update
+the box. Set @var{dst} to the previous value of the box in either case.
+@end deftypefn
+
+
@node Inlined Mathematical Instructions
@subsubsection Inlined Mathematical Instructions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index f508cd2f2..852e10d06 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -441,6 +441,8 @@
#define VM_VALIDATE(x, pred, proc, what) \
VM_ASSERT (pred (x), vm_error_not_a_ ## what (proc, x))
+#define VM_VALIDATE_ATOMIC_BOX(x, proc) \
+ VM_VALIDATE (x, scm_is_atomic_box, proc, atomic_box)
#define VM_VALIDATE_BYTEVECTOR(x, proc) \
VM_VALIDATE (x, SCM_BYTEVECTOR_P, proc, bytevector)
#define VM_VALIDATE_CHAR(x, proc) \
@@ -3818,11 +3820,93 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (178, unused_178, NULL, NOP)
- VM_DEFINE_OP (179, unused_179, NULL, NOP)
- VM_DEFINE_OP (180, unused_180, NULL, NOP)
- VM_DEFINE_OP (181, unused_181, NULL, NOP)
- VM_DEFINE_OP (182, unused_182, NULL, NOP)
+ /* make-atomic-box dst:12 src:12
+ *
+ * Create a new atomic box initialized to SRC, and place it in DST.
+ */
+ VM_DEFINE_OP (178, make_atomic_box, "make-atomic-box", OP1 (X8_S12_S12) | OP_DST)
+ {
+ SCM box;
+ scm_t_uint16 dst, src;
+ UNPACK_12_12 (op, dst, src);
+ SYNC_IP ();
+ box = scm_inline_cell (thread, scm_tc7_atomic_box,
+ SCM_UNPACK (SCM_UNSPECIFIED));
+ scm_atomic_set_scm (scm_atomic_box_loc (box), SP_REF (src));
+ SP_SET (dst, box);
+ NEXT (1);
+ }
+
+ /* atomic-box-ref dst:12 src:12
+ *
+ * Fetch the value of the atomic box at SRC into DST.
+ */
+ VM_DEFINE_OP (179, atomic_box_ref, "atomic-box-ref", OP1 (X8_S12_S12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+ SCM box;
+ UNPACK_12_12 (op, dst, src);
+ box = SP_REF (src);
+ VM_VALIDATE_ATOMIC_BOX (box, "atomic-box-ref");
+ SP_SET (dst, scm_atomic_ref_scm (scm_atomic_box_loc (box)));
+ NEXT (1);
+ }
+
+ /* atomic-box-set! dst:12 src:12
+ *
+ * Set the contents of the atomic box at DST to SRC.
+ */
+ VM_DEFINE_OP (180, atomic_box_set, "atomic-box-set!", OP1 (X8_S12_S12))
+ {
+ scm_t_uint16 dst, src;
+ SCM box;
+ UNPACK_12_12 (op, dst, src);
+ box = SP_REF (dst);
+ VM_VALIDATE_ATOMIC_BOX (box, "atomic-box-set!");
+ scm_atomic_set_scm (scm_atomic_box_loc (box), SP_REF (src));
+ NEXT (1);
+ }
+
+ /* atomic-box-swap! dst:12 box:12 _:8 val:24
+ *
+ * Replace the contents of the atomic box at BOX to VAL and store the
+ * previous value at DST.
+ */
+ VM_DEFINE_OP (181, atomic_box_swap, "atomic-box-swap!", OP2 (X8_S12_S12, X8_S24) | OP_DST)
+ {
+ scm_t_uint16 dst, box;
+ scm_t_uint32 val;
+ SCM scm_box;
+ UNPACK_12_12 (op, dst, box);
+ UNPACK_24 (ip[1], val);
+ scm_box = SP_REF (box);
+ VM_VALIDATE_ATOMIC_BOX (scm_box, "atomic-box-swap!");
+ SP_SET (dst,
+ scm_atomic_swap_scm (scm_atomic_box_loc (scm_box), SP_REF (val)));
+ NEXT (2);
+ }
+
+ /* atomic-box-compare-and-swap! dst:12 box:12 _:8 expected:24 _:8 desired:24
+ *
+ * Set the contents of the atomic box at DST to SET.
+ */
+ VM_DEFINE_OP (182, atomic_box_compare_and_swap, "atomic-box-compare-and-swap!", OP3 (X8_S12_S12, X8_S24, X8_S24) | OP_DST)
+ {
+ scm_t_uint16 dst, box;
+ scm_t_uint32 expected, desired;
+ SCM scm_box, scm_expected;
+ UNPACK_12_12 (op, dst, box);
+ UNPACK_24 (ip[1], expected);
+ UNPACK_24 (ip[2], desired);
+ scm_box = SP_REF (box);
+ VM_VALIDATE_ATOMIC_BOX (scm_box, "atomic-box-compare-and-swap!");
+ scm_expected = SP_REF (expected);
+ scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (scm_box),
+ &scm_expected, SP_REF (desired));
+ SP_SET (dst, scm_expected);
+ NEXT (3);
+ }
+
VM_DEFINE_OP (183, unused_183, NULL, NOP)
VM_DEFINE_OP (184, unused_184, NULL, NOP)
VM_DEFINE_OP (185, unused_185, NULL, NOP)
@@ -3959,6 +4043,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
#undef VM_DEFINE_OP
#undef VM_INSTRUCTION_TO_LABEL
#undef VM_USE_HOOKS
+#undef VM_VALIDATE_ATOMIC_BOX
#undef VM_VALIDATE_BYTEVECTOR
#undef VM_VALIDATE_PAIR
#undef VM_VALIDATE_STRUCT
diff --git a/libguile/vm.c b/libguile/vm.c
index 60469f631..86e1a0576 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -34,16 +34,19 @@
#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
-#include "_scm.h"
-#include "control.h"
-#include "frames.h"
-#include "gc-inline.h"
-#include "instructions.h"
-#include "loader.h"
-#include "programs.h"
-#include "simpos.h"
-#include "vm.h"
-#include "vm-builtins.h"
+#include "libguile/_scm.h"
+#include "libguile/atomic.h"
+#include "libguile/atomics-internal.h"
+#include "libguile/control.h"
+#include "libguile/control.h"
+#include "libguile/frames.h"
+#include "libguile/gc-inline.h"
+#include "libguile/instructions.h"
+#include "libguile/loader.h"
+#include "libguile/programs.h"
+#include "libguile/simpos.h"
+#include "libguile/vm.h"
+#include "libguile/vm-builtins.h"
static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
@@ -442,6 +445,7 @@ static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_char (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_atomic_box (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE;
@@ -553,6 +557,12 @@ vm_error_not_a_string (const char *subr, SCM x)
}
static void
+vm_error_not_a_atomic_box (const char *subr, SCM x)
+{
+ scm_wrong_type_arg_msg (subr, 1, x, "atomic box");
+}
+
+static void
vm_error_not_a_bytevector (const char *subr, SCM x)
{
scm_wrong_type_arg_msg (subr, 1, x, "bytevector");
diff --git a/module/ice-9/atomic.scm b/module/ice-9/atomic.scm
index 21dba3938..2a8af901d 100644
--- a/module/ice-9/atomic.scm
+++ b/module/ice-9/atomic.scm
@@ -18,6 +18,8 @@
;;;;
(define-module (ice-9 atomic)
+ #:use-module ((language tree-il primitives)
+ :select (add-interesting-primitive!))
#:export (make-atomic-box
atomic-box?
atomic-box-ref
@@ -27,4 +29,10 @@
(eval-when (expand load eval)
(load-extension (string-append "libguile-" (effective-version))
- "scm_init_atomic"))
+ "scm_init_atomic")
+ (add-interesting-primitive! 'make-atomic-box)
+ (add-interesting-primitive! 'atomic-box?)
+ (add-interesting-primitive! 'atomic-box-ref)
+ (add-interesting-primitive! 'atomic-box-set!)
+ (add-interesting-primitive! 'atomic-box-swap!)
+ (add-interesting-primitive! 'atomic-box-compare-and-swap!))
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 7c69fa6fb..5157ecb70 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -260,6 +260,17 @@
(($ $primcall 'bv-f64-ref (bv idx val))
(emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
+ (($ $primcall 'make-atomic-box (init))
+ (emit-make-atomic-box asm (from-sp dst) (from-sp (slot init))))
+ (($ $primcall 'atomic-box-ref (box))
+ (emit-atomic-box-ref asm (from-sp dst) (from-sp (slot box))))
+ (($ $primcall 'atomic-box-swap! (box val))
+ (emit-atomic-box-swap! asm (from-sp dst) (from-sp (slot box))
+ (from-sp (slot val))))
+ (($ $primcall 'atomic-box-compare-and-swap! (box expected desired))
+ (emit-atomic-box-compare-and-swap!
+ asm (from-sp dst) (from-sp (slot box))
+ (from-sp (slot expected)) (from-sp (slot desired))))
(($ $primcall name args)
;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name)))
@@ -351,7 +362,9 @@
(emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'unwind ())
- (emit-unwind asm))))
+ (emit-unwind asm))
+ (($ $primcall 'atomic-box-set! (box val))
+ (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))))
(define (compile-values label exp syms)
(match exp
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 9c408391c..38c0bab7e 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -491,6 +491,10 @@ is or might be a read or a write to the same location as A."
((integer->char _) &type-check)
((char->integer _) &type-check))
+;; Atomics are a memory and a compiler barrier; they cause all effects
+;; so no need to have a case for them here. (Though, see
+;; https://jfbastien.github.io/no-sane-compiler/.)
+
(define (primitive-effects constants name args)
(let ((proc (hashq-ref *primitive-effects* name)))
(if proc
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 9b700bd83..df4dd248c 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -75,6 +75,10 @@
bytevector-ieee-double-ref bytevector-ieee-double-set!
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
'(rnrs bytevectors))
+ ((atomic-box?
+ make-atomic-box atomic-box-ref atomic-box-set!
+ atomic-box-swap! atomic-box-compare-and-swap!)
+ '(ice-9 atomic))
((class-of) '(oop goops))
((u8vector-ref
u8vector-set! s8vector-ref s8vector-set!
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 4f960e534..71db1a635 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -171,7 +171,7 @@
not
pair? null? nil? list?
symbol? variable? vector? struct? string? number? char?
- bytevector? keyword? bitvector?
+ bytevector? keyword? bitvector? atomic-box?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
integer->char char->integer number->string string->number
@@ -194,7 +194,7 @@
pair? null? nil? list?
symbol? variable? vector? struct? string? number? char?
bytevector? keyword? bitvector?
- procedure? thunk?
+ procedure? thunk? atomic-box?
acons cons cons* list vector))
;; Primitives that don't always return one value.
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 3b9834bcb..c72622e70 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -216,6 +216,11 @@
emit-bv-s64-set!
emit-bv-f32-set!
emit-bv-f64-set!
+ emit-make-atomic-box
+ emit-atomic-box-ref
+ emit-atomic-box-set!
+ emit-atomic-box-swap!
+ emit-atomic-box-compare-and-swap!
emit-text
link-assembly))
diff --git a/test-suite/tests/atomic.test b/test-suite/tests/atomic.test
index f6e0c8863..8fc8ba9d3 100644
--- a/test-suite/tests/atomic.test
+++ b/test-suite/tests/atomic.test
@@ -21,39 +21,40 @@
#:use-module ((oop goops) #:select (class-of <atomic-box>))
#:use-module (test-suite lib))
-(pass-if (atomic-box? (make-atomic-box 42)))
+(with-test-prefix/c&e "atomics"
+ (pass-if "predicate" (atomic-box? (make-atomic-box 42)))
-(pass-if-equal 42 (atomic-box-ref (make-atomic-box 42)))
+ (pass-if-equal "ref" 42 (atomic-box-ref (make-atomic-box 42)))
-(pass-if-equal 42 (atomic-box-swap! (make-atomic-box 42) 10))
+ (pass-if-equal "swap" 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 "set and ref" 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 "swap and ref" 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 "compare and swap" 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 "compare and swap (wrong)" 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 "compare and swap and ref" 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 "compare and swap (wrong) and ref" 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)))
+ (pass-if-equal "class-of" <atomic-box>
+ (class-of (make-atomic-box 42))))