Compiler support for atomics

* doc/ref/vm.texi (Inlined Atomic Instructions): New section.
* libguile/vm-engine.c (VM_VALIDATE_ATOMIC_BOX, make-atomic-box)
  (atomic-box-ref, atomic-box-set!, atomic-box-swap!)
  (atomic-box-compare-and-swap!): New instructions.
* libguile/vm.c: Include atomic and atomics-internal.h.
  (vm_error_not_a_atomic_box): New function.
* module/ice-9/atomic.scm: Register primitives with the compiler.
* module/language/cps/compile-bytecode.scm (compile-function): Add
  support for atomic ops.
* module/language/cps/effects-analysis.scm: Add comment about why no
  effects analysis needed.
* module/language/cps/reify-primitives.scm (primitive-module): Add case
  for (ice-9 atomic).
* module/language/tree-il/primitives.scm (*effect-free-primitives*):
  (*effect+exception-free-primitives*): Add atomic-box?.
* module/system/vm/assembler.scm: Add new instructions.

* test-suite/tests/atomic.test: Test with compilation and
  interpretation.

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
 

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

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;
@@ -552,6 +556,12 @@ vm_error_not_a_string (const char *subr, SCM x)
   scm_wrong_type_arg_msg (subr, 1, x, "string");
 }
 
+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)
 {

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!))

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

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

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!

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.

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))

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
+ (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
+ (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
+ (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
+ (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
+ (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
+ (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))))