Define intrinsics for atomic ops

* libguile/intrinsics.h:
* libguile/intrinsics.c (atomic_ref_scm, atomic_set_scm):
  (atomic_swap_scm, atomic_compare_and_swap_scm): New intrinsics, given
  that lightning doesn't know atomics.
  (scm_bootstrap_intrinsics): Init new intrinsics.
* libguile/vm-engine.c (atomic-scm-ref/immediate)
  (atomic-scm-set!/immediate, atomic-scm-swap!/immediate)
  (atomic-scm-compare-and-swap!/immediate): Use intrinsics, to be like
  the JIT.

3 files changed, 45 insertions, 7 deletions

diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index c9fc22e9c..89eed1867 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -22,6 +22,7 @@
 #endif
 
 #include "alist.h"
+#include "atomics-internal.h"
 #include "boolean.h"
 #include "cache-internal.h"
 #include "extensions.h"
@@ -410,6 +411,31 @@ push_prompt (scm_thread *thread, uint8_t escape_only_p,
                             vra, mra, thread->vm.registers);
 }
 
+static SCM
+atomic_ref_scm (SCM *loc)
+{
+  return scm_atomic_ref_scm (loc);
+}
+
+static void
+atomic_set_scm (SCM *loc, SCM val)
+{
+  scm_atomic_set_scm (loc, val);
+}
+
+static SCM
+atomic_swap_scm (SCM *loc, SCM val)
+{
+  return scm_atomic_swap_scm (loc, val);
+}
+
+static SCM
+atomic_compare_and_swap_scm (SCM *loc, SCM expected, SCM desired)
+{
+  scm_atomic_compare_and_swap_scm (loc, &expected, desired);
+  return expected;
+}
+
 void
 scm_bootstrap_intrinsics (void)
 {
@@ -478,6 +504,10 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.allocate_words = allocate_words;
   scm_vm_intrinsics.current_module = current_module;
   scm_vm_intrinsics.push_prompt = push_prompt;
+  scm_vm_intrinsics.atomic_ref_scm = atomic_ref_scm;
+  scm_vm_intrinsics.atomic_set_scm = atomic_set_scm;
+  scm_vm_intrinsics.atomic_swap_scm = atomic_swap_scm;
+  scm_vm_intrinsics.atomic_compare_and_swap_scm = atomic_compare_and_swap_scm;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 44b996bdf..b00471123 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -88,6 +88,10 @@ typedef void (*scm_t_thread_mra_intrinsic) (scm_thread*, uint8_t*);
 typedef uint32_t* (*scm_t_vra_from_thread_intrinsic) (scm_thread*);
 typedef uint8_t* (*scm_t_mra_from_thread_scm_intrinsic) (scm_thread*, SCM);
 typedef uint8_t* (*scm_t_mra_from_thread_mra_intrinsic) (scm_thread*, uint8_t*);
+typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*);
+typedef void (*scm_t_ptr_scm_intrinsic) (SCM*, SCM);
+typedef SCM (*scm_t_scm_from_ptr_scm_intrinsic) (SCM*, SCM);
+typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -159,6 +163,10 @@ typedef uint8_t* (*scm_t_mra_from_thread_mra_intrinsic) (scm_thread*, uint8_t*);
   M(thread, invoke_return_hook, "invoke-return-hook", INVOKE_RETURN_HOOK) \
   M(thread, invoke_next_hook, "invoke-next-hook", INVOKE_NEXT_HOOK) \
   M(thread, invoke_abort_hook, "invoke-abort-hook", INVOKE_ABORT_HOOK) \
+  M(scm_from_ptr, atomic_ref_scm, "atomic-ref-scm", ATOMIC_REF_SCM) \
+  M(ptr_scm, atomic_set_scm, "atomic-set-scm", ATOMIC_SET_SCM) \
+  M(scm_from_ptr_scm, atomic_swap_scm, "atomic-swap-scm", ATOMIC_SWAP_SCM) \
+  M(scm_from_ptr_scm_scm, atomic_compare_and_swap_scm, "atomic-compare-and-swap-scm", ATOMIC_COMPARE_AND_SWAP_SCM) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index d64ce9ee7..2af02dcea 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1784,7 +1784,7 @@ VM_NAME (scm_thread *thread)
       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));
+      SP_SET (dst, CALL_INTRINSIC (atomic_ref_scm, (loc)));
       NEXT (1);
     }
 
@@ -1794,7 +1794,7 @@ VM_NAME (scm_thread *thread)
       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));
+      CALL_INTRINSIC (atomic_set_scm, (loc, SP_REF (val)));
       NEXT (1);
     }
 
@@ -1807,7 +1807,7 @@ VM_NAME (scm_thread *thread)
       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)));
+      SP_SET (dst, CALL_INTRINSIC (atomic_swap_scm, (loc, SP_REF (val))));
       NEXT (3);
     }
 
@@ -1816,15 +1816,15 @@ VM_NAME (scm_thread *thread)
       uint32_t dst, obj, expected, desired;
       uint8_t offset;
       SCM *loc;
-      SCM scm_expected;
+      SCM got;
       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);
+      got = CALL_INTRINSIC (atomic_compare_and_swap_scm,
+                            (loc, SP_REF (expected), SP_REF (desired)));
+      SP_SET (dst, got);
       NEXT (4);
     }