mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Define intrinsics for atomic ops

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2018-08-13 21:42:43 +02:00
parent 0188bd3816
commit e6304fb242
3 changed files with 45 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

30
libguile/intrinsics.c
View file

@ -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",

8
libguile/intrinsics.h
View file

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

14
libguile/vm-engine.c
View file

@ -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);
}