[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 13/15: Explode atomic box ops to new atomic instructions
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 13/15: Explode atomic box ops to new atomic instructions |
|
Date: |
Fri, 13 Apr 2018 04:41:13 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit dff85f6f9f62fae93b240f018212542a58e86437
Author: Andy Wingo <address@hidden>
Date: Thu Apr 12 18:14:00 2018 +0200
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 | 3 +-
libguile/vm-engine.c | 93 +++++++++++++++++++++-----------
module/language/bytecode.scm | 1 +
module/language/cps/compile-bytecode.scm | 28 +++++-----
module/language/cps/effects-analysis.scm | 4 +-
module/language/cps/types.scm | 4 +-
module/language/tree-il/compile-cps.scm | 79 +++++++++++++++++++++++++++
module/system/base/types/internal.scm | 1 +
module/system/vm/assembler.scm | 13 +++--
module/system/vm/disassembler.scm | 2 +-
10 files changed, 174 insertions(+), 54 deletions(-)
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 3d20a6b..15ea94c 100644
--- a/libguile/instructions.c
+++ b/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. */ \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index b6638c4..8f06c57 100644
--- a/libguile/vm-engine.c
+++ b/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 (84, unused_84, NULL, NOP)
- VM_DEFINE_OP (85, unused_85, NULL, NOP)
- VM_DEFINE_OP (86, unused_86, NULL, NOP)
+ VM_DEFINE_OP (83, atomic_ref_scm_immediate, "atomic-scm-ref/immediate", OP1
(X8_S8_S8_C8) | OP_DST)
+ {
+ scm_t_uint8 dst, obj, offset;
+ 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
- *
- * 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)
+ VM_DEFINE_OP (178, unused_178, NULL, NOP)
{
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
- *
- * 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)
+ VM_DEFINE_OP (179, unused_179, NULL, NOP)
{
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
- *
- * 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))
+ VM_DEFINE_OP (180, unused_180, NULL, NOP)
{
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
- *
- * 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)
+ VM_DEFINE_OP (181, unused_181, NULL, NOP)
{
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
- *
- * 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)
+ VM_DEFINE_OP (182, unused_182, NULL, NOP)
{
scm_t_uint16 dst, box;
scm_t_uint32 expected, desired;
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm
index e072a09..ec0392b 100644
--- a/module/language/bytecode.scm
+++ b/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)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 01eb57b..88da194 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/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))
- (emit-make-atomic-box asm (from-sp dst) (from-sp (slot init))))
- (($ $primcall 'atomic-box-ref #f (box))
- (emit-atomic-box-ref asm (from-sp dst) (from-sp (slot box))))
- (($ $primcall 'atomic-box-swap! #f (box val))
- (emit-atomic-box-swap! asm (from-sp dst) (from-sp (slot box))
- (from-sp (slot val))))
- (($ $primcall 'atomic-box-compare-and-swap! #f (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 'atomic-scm-ref/immediate (annotation . idx) (obj))
+ (emit-atomic-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj))
+ idx))
+ (($ $primcall 'atomic-scm-swap!/immediate (annotation . idx) (obj val))
+ (emit-atomic-scm-swap!/immediate asm (from-sp dst) (from-sp (slot
obj))
+ idx (from-sp (slot val))))
+ (($ $primcall 'atomic-scm-compare-and-swap!/immediate (annotation .
idx)
+ (obj expected desired))
+ (emit-atomic-scm-compare-and-swap!/immediate
+ asm (from-sp dst) (from-sp (slot obj)) idx (from-sp (slot expected))
+ (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))
- (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
+ (($ $primcall 'atomic-scm-set!/immediate (annotation . idx) (obj val))
+ (emit-atomic-scm-set!/immediate asm (from-sp (slot obj)) idx
+ (from-sp (slot val))))
(($ $primcall 'handle-interrupts #f ())
(emit-handle-interrupts asm))))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 684adef..3484a10 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/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)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 74a73bb..1fc3605 100644
--- a/module/language/cps/types.scm
+++ b/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)))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index ab3f6e2..4574c8b 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/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
diff --git a/module/system/base/types/internal.scm
b/module/system/base/types/internal.scm
index 1941d1f..9e4e4cc 100644
--- a/module/system/base/types/internal.scm
+++ b/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
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 6d97d60..6b249d4 100644
--- a/module/system/vm/assembler.scm
+++ b/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))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 6840668..ac4c55c 100644
--- a/module/system/vm/disassembler.scm
+++ b/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)
- [Guile-commits] 03/15: Add reifier for fadd/immediate., (continued)
- [Guile-commits] 03/15: Add reifier for fadd/immediate., Andy Wingo, 2018/04/13
- [Guile-commits] 02/15: Slim heap-allocated flonums, Andy Wingo, 2018/04/13
- [Guile-commits] 01/15: Add scm->f64 intrinsic, Andy Wingo, 2018/04/13
- [Guile-commits] 11/15: logsub is intrinsic, Andy Wingo, 2018/04/13
- [Guile-commits] 09/15: u64->scm, s64->scm intrinsics, Andy Wingo, 2018/04/13
- [Guile-commits] 08/15: Remove scm->u64, etc implementations, Andy Wingo, 2018/04/13
- [Guile-commits] 10/15: Remove implementations of obsolete s64->scm, u64->scm insts, Andy Wingo, 2018/04/13
- [Guile-commits] 12/15: Remove implementation of logsub VM op, Andy Wingo, 2018/04/13
- [Guile-commits] 07/15: scm->u64, scm->s64, scm->u64/truncate intrinsics, Andy Wingo, 2018/04/13
- [Guile-commits] 14/15: Remove implementation of atomic box ops, Andy Wingo, 2018/04/13
- [Guile-commits] 13/15: Explode atomic box ops to new atomic instructions,
Andy Wingo <=
- [Guile-commits] 15/15: Remove unused macros in vm-engine, Andy Wingo, 2018/04/13