diff options
author | Andy Wingo <wingo@pobox.com> | 2018-04-12 18:14:00 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2018-04-13 10:09:56 +0200 |
commit | dff85f6f9f62fae93b240f018212542a58e86437 (patch) | |
tree | e7b31984cd01d451094e9bfdd608aa3a61c3e499 | |
parent | b32d3cc6f7f521f67637f30f83327110264b9dee (diff) | |
download | guile-dff85f6f9f62fae93b240f018212542a58e86437.tar.gz |
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.
-rw-r--r-- | libguile/instructions.c | 3 | ||||
-rw-r--r-- | libguile/vm-engine.c | 93 | ||||
-rw-r--r-- | module/language/bytecode.scm | 1 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 28 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 4 | ||||
-rw-r--r-- | module/language/cps/types.scm | 4 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 79 | ||||
-rw-r--r-- | module/system/base/types/internal.scm | 1 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 13 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 2 |
10 files changed, 174 insertions, 54 deletions
diff --git a/libguile/instructions.c b/libguile/instructions.c index 3d20a6be8..15ea94c0d 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 b6638c41e..8f06c5769 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 e072a09bd..ec0392ba4 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 01eb57b93..88da19421 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 684adef90..3484a1065 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 74a73bb84..1fc360510 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 ab3f6e2b9..4574c8bb0 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 1941d1f75..9e4e4cc9c 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 6d97d6070..6b249d4cf 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 68406688f..ac4c55cdc 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) |