summaryrefslogtreecommitdiff
path: root/libguile/vm-engine.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-09-06 12:18:35 +0200
committerAndy Wingo <wingo@pobox.com>2016-09-06 12:18:35 +0200
commit32f309d5ce3263bde34d392e3df2d1062796d762 (patch)
tree6395d1f72395f86a9a1c7b09d337bd5163f309e3 /libguile/vm-engine.c
parent73efa8fb06e92eda8221a8a25603fde141ec7949 (diff)
downloadguile-32f309d5ce3263bde34d392e3df2d1062796d762.tar.gz
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.
Diffstat (limited to 'libguile/vm-engine.c')
-rw-r--r--libguile/vm-engine.c95
1 files changed, 90 insertions, 5 deletions
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