Explode atomic box ops to new atomic instructions

* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Add C8_S24
  word type.
* libguile/vm-engine.c (UNPACK_8_24): New helper.
  (atomic-scm-ref/immediate, atomic-scm-set!/immediate)
  (atomic-swap-scm!/immediate, atomic-scm-compare-and-swap!/immediate):
  New instructions.
  (make-atomic-box, atomic-box-ref, atomic-box-set!, atomic-box-swap!)
  (atomic-box-compare-and-swap!): Disable these ops.
* module/language/bytecode.scm (compute-instruction-arity): Add C8_S24
  support.
* module/system/vm/assembler.scm: Add C8_S24 support.  Export assemblers
  for new opcodes.
* module/system/vm/disassembler.scm (disassembler): Support C8_S24.
* module/language/cps/compile-bytecode.scm (compile-function): Replace
  old atomic-box assemblers with the new instructions.
* module/language/cps/effects-analysis.scm (annotation->memory-kind):
* module/language/cps/types.scm (annotation->type): Add cases for atomic
  boxes.  Mark as all memory kinds because atomic ops serialize memory
  accesses.
* module/language/tree-il/compile-cps.scm (make-atomic-box):
  (ensure-atomic-box, atomic-box-ref, atomic-box-set!):
  (atomic-box-swap!, atomic-box-compare-and-swap!): Explode these ops to
  more basic instructions.
* module/system/base/types/internal.scm (%tc7-atomic-box): Add forgotten
  export.

libguile/instructions.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2017 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009-2013, 2017-2018 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
@@ -47,6 +47,7 @@ SCM_SYMBOL (sym_bang, "!");
     M(X8_S8_C8_S8)                              \
     M(X8_S8_S8_C8)                              \
     M(C8_C24)                                   \
+    M(C8_S24)                                   \
     M(C32) /* Unsigned. */                      \
     M(I32) /* Immediate. */                     \
     M(A32) /* Immediate, high bits. */          \

libguile/vm-engine.c

@@ -60,6 +60,14 @@
     }                                     \
   while (0)
 
+#define UNPACK_8_24(op,a,b)               \
+  do                                      \
+    {                                     \
+      a = op & 0xff;                      \
+      b = op >> 8;                        \
+    }                                     \
+  while (0)
+
 #define UNPACK_16_16(op,a,b)              \
   do                                      \
     {                                     \
@@ -2236,10 +2244,56 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (83, unused_83, NULL, NOP)
+  VM_DEFINE_OP (83, atomic_ref_scm_immediate, "atomic-scm-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST)
-  VM_DEFINE_OP (84, unused_84, NULL, NOP)
+    {
-  VM_DEFINE_OP (85, unused_85, NULL, NOP)
+      scm_t_uint8 dst, obj, offset;
-  VM_DEFINE_OP (86, unused_86, NULL, NOP)
+      SCM *loc;
+      UNPACK_8_8_8 (op, dst, obj, offset);
+      loc = SCM_CELL_OBJECT_LOC (SP_REF (obj), offset);
+      SP_SET (dst, scm_atomic_ref_scm (loc));
+      NEXT (1);
+    }
+
+  VM_DEFINE_OP (84, atomic_set_scm_immediate, "atomic-scm-set!/immediate", OP1 (X8_S8_C8_S8))
+    {
+      scm_t_uint8 obj, offset, val;
+      SCM *loc;
+      UNPACK_8_8_8 (op, obj, offset, val);
+      loc = SCM_CELL_OBJECT_LOC (SP_REF (obj), offset);
+      scm_atomic_set_scm (loc, SP_REF (val));
+      NEXT (1);
+    }
+
+  VM_DEFINE_OP (85, atomic_scm_swap_immediate, "atomic-scm-swap!/immediate", OP3 (X8_S24, X8_S24, C8_S24) | OP_DST)
+    {
+      scm_t_uint32 dst, obj, val;
+      scm_t_uint8 offset;
+      SCM *loc;
+      UNPACK_24 (op, dst);
+      UNPACK_24 (ip[1], obj);
+      UNPACK_8_24 (ip[2], offset, val);
+      loc = SCM_CELL_OBJECT_LOC (SP_REF (obj), offset);
+      SP_SET (dst, scm_atomic_swap_scm (loc, SP_REF (val)));
+      NEXT (3);
+    }
+
+  VM_DEFINE_OP (86, atomic_scm_compare_and_swap_immediate, "atomic-scm-compare-and-swap!/immediate", OP4 (X8_S24, X8_S24, C8_S24, X8_S24) | OP_DST)
+    {
+      scm_t_uint32 dst, obj, expected, desired;
+      scm_t_uint8 offset;
+      SCM *loc;
+      SCM scm_expected;
+      UNPACK_24 (op, dst);
+      UNPACK_24 (ip[1], obj);
+      UNPACK_8_24 (ip[2], offset, expected);
+      UNPACK_24 (ip[3], desired);
+      loc = SCM_CELL_OBJECT_LOC (SP_REF (obj), offset);
+      scm_expected = SP_REF (expected);
+      scm_atomic_compare_and_swap_scm (loc, &scm_expected, SP_REF (desired));
+      SP_SET (dst, scm_expected);
+      NEXT (4);
+    }
+
   VM_DEFINE_OP (87, unused_87, NULL, NOP)
   VM_DEFINE_OP (88, unused_88, NULL, NOP)
   VM_DEFINE_OP (89, unused_89, NULL, NOP)
@@ -2714,11 +2768,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  /* make-atomic-box dst:12 src:12
+  VM_DEFINE_OP (178, unused_178, NULL, NOP)
-   *
-   * 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;
@@ -2731,11 +2781,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  /* atomic-box-ref dst:12 src:12
+  VM_DEFINE_OP (179, unused_179, NULL, NOP)
-   *
-   * 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;
@@ -2746,11 +2792,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  /* atomic-box-set! dst:12 src:12
+  VM_DEFINE_OP (180, unused_180, NULL, NOP)
-   *
-   * 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;
@@ -2761,12 +2803,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  /* atomic-box-swap! dst:12 box:12 _:8 val:24
+  VM_DEFINE_OP (181, unused_181, NULL, NOP)
-   *
-   * 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;
@@ -2780,11 +2817,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (2);
     }
 
-  /* atomic-box-compare-and-swap! dst:12 box:12 _:8 expected:24  _:8 desired:24
+  VM_DEFINE_OP (182, unused_182, NULL, NOP)
-   *
-   * 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;

module/language/bytecode.scm

@@ -63,6 +63,7 @@
       ((L32) 1)
       ((LO32) 1)
       ((C8_C24) 2)
+      ((C8_S24) 2)
       ((C16_C16) 2)
       ((B1_C7_L24) 3)
       ((B1_X7_S24) 2)

module/language/cps/compile-bytecode.scm

@@ -251,17 +251,18 @@
          (emit-f64-ref asm (from-sp dst) (from-sp (slot ptr))
                        (from-sp (slot idx))))
 
-        (($ $primcall 'make-atomic-box #f (init))
+        (($ $primcall 'atomic-scm-ref/immediate (annotation . idx) (obj))
-         (emit-make-atomic-box asm (from-sp dst) (from-sp (slot init))))
+         (emit-atomic-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj))
-        (($ $primcall 'atomic-box-ref #f (box))
+                                        idx))
-         (emit-atomic-box-ref asm (from-sp dst) (from-sp (slot box))))
+        (($ $primcall 'atomic-scm-swap!/immediate (annotation . idx) (obj val))
-        (($ $primcall 'atomic-box-swap! #f (box val))
+         (emit-atomic-scm-swap!/immediate asm (from-sp dst) (from-sp (slot obj))
-         (emit-atomic-box-swap! asm (from-sp dst) (from-sp (slot box))
+                                          idx (from-sp (slot val))))
-                                (from-sp (slot val))))
+        (($ $primcall 'atomic-scm-compare-and-swap!/immediate (annotation . idx)
-        (($ $primcall 'atomic-box-compare-and-swap! #f (box expected desired))
+            (obj expected desired))
-         (emit-atomic-box-compare-and-swap!
+         (emit-atomic-scm-compare-and-swap!/immediate
-          asm (from-sp dst) (from-sp (slot box))
+          asm (from-sp dst) (from-sp (slot obj)) idx (from-sp (slot expected))
-          (from-sp (slot expected)) (from-sp (slot desired))))
+          (from-sp (slot desired))))
+
         (($ $primcall 'untag-fixnum #f (src))
          (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'tag-fixnum #f (src))
@@ -350,8 +351,9 @@
          (emit-unwind asm))
         (($ $primcall 'fluid-set! #f (fluid value))
          (emit-fluid-set! asm (from-sp (slot fluid)) (from-sp (slot value))))
-        (($ $primcall 'atomic-box-set! #f (box val))
+        (($ $primcall 'atomic-scm-set!/immediate (annotation . idx) (obj val))
-         (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
+         (emit-atomic-scm-set!/immediate asm (from-sp (slot obj)) idx
+                                         (from-sp (slot val))))
         (($ $primcall 'handle-interrupts #f ())
          (emit-handle-interrupts asm))))
 

module/language/cps/effects-analysis.scm

@@ -342,7 +342,6 @@ the LABELS that are clobbered by the effects of LABEL."
 
 ;; Generic objects.
 (define (annotation->memory-kind annotation)
-  ;; FIXME: Flesh this out.
   (match annotation
     ('pair &pair)
     ('vector &vector)
@@ -352,7 +351,8 @@ the LABELS that are clobbered by the effects of LABEL."
     ('bitmask &bitmask)
     ('box &box)
     ('closure &closure)
-    ('struct &struct)))
+    ('struct &struct)
+    ('atomic-box &unknown-memory-kinds)))
 
 (define-primitive-effects* param
   ((allocate-words size)           (&allocate (annotation->memory-kind param)))

module/language/cps/types.scm

@@ -723,7 +723,6 @@ minimum, and maximum."
 ;;;
 
 (define (annotation->type ann)
-  ;; Expand me!
   (match ann
     ('pair &pair)
     ('vector &vector)
@@ -732,7 +731,8 @@ minimum, and maximum."
     ('bytevector &bytevector)
     ('box &box)
     ('closure &procedure)
-    ('struct &struct)))
+    ('struct &struct)
+    ('atomic-box &all-types)))
 
 (define-type-inferrer/param (allocate-words param size result)
   (define! result (annotation->type param) (&min/0 size) (&max/scm-size size)))

module/language/tree-il/compile-cps.scm

@@ -1294,6 +1294,85 @@
 (define-primcall-converter rsh convert-shift)
 (define-primcall-converter lsh convert-shift)
 
+(define-primcall-converter make-atomic-box
+  (lambda (cps k src op param val)
+    (with-cps cps
+      (letv obj tag)
+      (letk kdone
+            ($kargs () ()
+              ($continue k src ($values (obj)))))
+      (letk kval
+            ($kargs () ()
+              ($continue kdone src
+                ($primcall 'atomic-scm-set!/immediate '(atomic-box . 1) (obj val)))))
+      (letk ktag1
+            ($kargs ('tag) (tag)
+              ($continue kval src
+                ($primcall 'word-set!/immediate '(atomic-box . 0) (obj tag)))))
+      (letk ktag0
+            ($kargs ('obj) (obj)
+              ($continue ktag1 src
+                ($primcall 'load-u64 %tc7-atomic-box ()))))
+      (build-term
+        ($continue ktag0 src
+          ($primcall 'allocate-words/immediate '(atomic-box . 2) ()))))))
+
+(define (ensure-atomic-box cps src op x is-atomic-box)
+  (define bad-type
+    (vector 'wrong-type-arg
+            (symbol->string op)
+            "Wrong type argument in position 1 (expecting atomic box): ~S"))
+  (with-cps cps
+    (letk kbad ($kargs () () ($throw src 'throw/value+data bad-type (x))))
+    (let$ body (is-atomic-box))
+    (letk k ($kargs () () ,body))
+    (letk kheap-object ($kargs () () ($branch kbad k src 'atomic-box? #f (x))))
+    (build-term ($branch kbad kheap-object src 'heap-object? #f (x)))))
+
+(define-primcall-converter atomic-box-ref
+  (lambda (cps k src op param x)
+    (ensure-atomic-box
+     cps src 'atomic-box-ref x
+     (lambda (cps)
+       (with-cps cps
+         (letv val)
+         (build-term
+           ($continue k src
+             ($primcall 'atomic-scm-ref/immediate '(atomic-box . 1) (x)))))))))
+
+(define-primcall-converter atomic-box-set!
+  (lambda (cps k src op param x val)
+    (ensure-atomic-box
+     cps src 'atomic-box-set! x
+     (lambda (cps)
+       (with-cps cps
+         (build-term
+           ($continue k src
+             ($primcall 'atomic-scm-set!/immediate '(atomic-box . 1)
+                        (x val)))))))))
+
+(define-primcall-converter atomic-box-swap!
+  (lambda (cps k src op param x val)
+    (ensure-atomic-box
+     cps src 'atomic-box-swap! x
+     (lambda (cps)
+       (with-cps cps
+         (build-term
+           ($continue k src
+             ($primcall 'atomic-scm-swap!/immediate '(atomic-box . 1)
+                        (x val)))))))))
+
+(define-primcall-converter atomic-box-compare-and-swap!
+  (lambda (cps k src op param x expected desired)
+    (ensure-atomic-box
+     cps src 'atomic-box-compare-and-swap! x
+     (lambda (cps)
+       (with-cps cps
+         (build-term
+           ($continue k src
+             ($primcall 'atomic-scm-compare-and-swap!/immediate '(atomic-box . 1)
+                        (x expected desired)))))))))
+
 ;;; Guile's semantics are that a toplevel lambda captures a reference on
 ;;; the current module, and that all contained lambdas use that module
 ;;; to resolve toplevel variables.  This parameter tracks whether or not

module/system/base/types/internal.scm

@@ -46,6 +46,7 @@
             %tc7-dynamic-state
             %tc7-frame
             %tc7-keyword
+            %tc7-atomic-box
             %tc7-syntax
             %tc7-program
             %tc7-vm-continuation

module/system/vm/assembler.scm

@@ -182,6 +182,11 @@
             emit-f32-set!
             emit-f64-set!
 
+            emit-atomic-scm-ref/immediate
+            emit-atomic-scm-set!/immediate
+            emit-atomic-scm-swap!/immediate
+            emit-atomic-scm-compare-and-swap!/immediate
+
             ;; Intrinsics.
             emit-add
             emit-add/immediate
@@ -270,11 +275,6 @@
             emit-load-f64
             emit-load-u64
             emit-load-s64
-            emit-make-atomic-box
-            emit-atomic-box-ref
-            emit-atomic-box-set!
-            emit-atomic-box-swap!
-            emit-atomic-box-compare-and-swap!
             emit-handle-interrupts
 
             emit-text
@@ -678,6 +678,8 @@ later by the linker."
           (emit asm 0))
          ((C8_C24 a b)
           (emit asm (pack-u8-u24 a b)))
+         ((C8_S24 a b)
+          (emit asm (pack-u8-u24 a b)))
          ((C16_C16 a b)
           (emit asm (pack-u16-u16 a b)))
          ((B1_X7_L24 a label)
@@ -952,6 +954,7 @@ later by the linker."
           ('L32 #'(label))
           ('LO32 #'(label offset))
           ('C8_C24 #'(a b))
+          ('C8_S24 #'(a b))
           ('C16_C16 #'(a b))
           ('B1_X7_L24 #'(a label))
           ('B1_C7_L24 #'(a b label))

module/system/vm/disassembler.scm

@@ -121,7 +121,7 @@
            #'(word))
           ((N32 R32 L32 LO32)
            #'((unpack-s32 word)))
-          ((C8_C24)
+          ((C8_C24 C8_S24)
            #'((logand word #xff)
               (ash word -8)))
           ((C16_C16)