mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Compiler support for atomics

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2016-09-06 12:18:35 +02:00
parent 73efa8fb06
commit 32f309d5ce
10 changed files with 208 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

32
doc/ref/vm.texi
View file

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

95
libguile/vm-engine.c
View file

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

30
libguile/vm.c
View file

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

10
module/ice-9/atomic.scm
View file

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

15
module/language/cps/compile-bytecode.scm
View file

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

4
module/language/cps/effects-analysis.scm
View file

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

4
module/language/cps/reify-primitives.scm
View file

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

4
module/language/tree-il/primitives.scm
View file

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

5
module/system/vm/assembler.scm
View file

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

55
test-suite/tests/atomic.test
View file

@ -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
(let ((box (make-atomic-box 42)))
(atomic-box-set! box 10)
(atomic-box-ref box)))
(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
(let ((box (make-atomic-box 42)))
(atomic-box-swap! box 10)
(atomic-box-ref box)))
(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
(let ((box (make-atomic-box 42)))
(atomic-box-compare-and-swap! box 42 10)))
(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
(let ((box (make-atomic-box 42)))
(atomic-box-compare-and-swap! box 43 10)))
(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
(let ((box (make-atomic-box 42)))
(atomic-box-compare-and-swap! box 42 10)
(atomic-box-ref box)))
(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
(let ((box (make-atomic-box 42)))
(atomic-box-compare-and-swap! box 43 10)
(atomic-box-ref box)))
(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))))