[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/13: Add raw u8-ref, etc instructions
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 04/13: Add raw u8-ref, etc instructions |
|
Date: |
Tue, 16 Jan 2018 10:46:29 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 13cafca1681ce830796c453add297a240e7c44b5
Author: Andy Wingo <address@hidden>
Date: Sun Jan 14 12:59:02 2018 +0100
Add raw u8-ref, etc instructions
* libguile/vm-engine.c (PTR_REF, PTR_SET): New helper macros.
(u8-ref, u16-ref, u32-ref, u64-ref, s8-ref, s16-ref, s32-ref, s64-ref)
(u8-set!, u16-set!, u32-set!, u64-set!, s8-set!, s16-set!, s32-set!,
s64-set!)
(f32-ref, f64-ref, f32-set!, f64-set!): New instructions.
* module/system/vm/assembler.scm:
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/types.scm: Add optimizer and backend support for
the new instructions.
---
libguile/vm-engine.c | 94 +++++++++++++++++++++++++-------
module/language/cps/compile-bytecode.scm | 65 ++++++++++++++++++++++
module/language/cps/effects-analysis.scm | 24 ++++++++
module/language/cps/slot-allocation.scm | 3 +
module/language/cps/types.scm | 22 ++++++++
module/system/vm/assembler.scm | 21 +++++++
6 files changed, 209 insertions(+), 20 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 5206b96..5f856c4 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -4059,26 +4059,80 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (223, unused_223, NULL, NOP)
- VM_DEFINE_OP (224, unused_224, NULL, NOP)
- VM_DEFINE_OP (225, unused_225, NULL, NOP)
- VM_DEFINE_OP (226, unused_226, NULL, NOP)
- VM_DEFINE_OP (227, unused_227, NULL, NOP)
- VM_DEFINE_OP (228, unused_228, NULL, NOP)
- VM_DEFINE_OP (229, unused_229, NULL, NOP)
- VM_DEFINE_OP (230, unused_230, NULL, NOP)
- VM_DEFINE_OP (231, unused_231, NULL, NOP)
- VM_DEFINE_OP (232, unused_232, NULL, NOP)
- VM_DEFINE_OP (233, unused_233, NULL, NOP)
- VM_DEFINE_OP (234, unused_234, NULL, NOP)
- VM_DEFINE_OP (235, unused_235, NULL, NOP)
- VM_DEFINE_OP (236, unused_236, NULL, NOP)
- VM_DEFINE_OP (237, unused_237, NULL, NOP)
- VM_DEFINE_OP (238, unused_238, NULL, NOP)
- VM_DEFINE_OP (239, unused_239, NULL, NOP)
- VM_DEFINE_OP (240, unused_240, NULL, NOP)
- VM_DEFINE_OP (241, unused_241, NULL, NOP)
- VM_DEFINE_OP (242, unused_242, NULL, NOP)
+#define PTR_REF(type, slot) \
+ do { \
+ scm_t_uint8 dst, a, b; \
+ char *ptr; \
+ size_t idx; \
+ type val; \
+ UNPACK_8_8_8 (op, dst, a, b); \
+ ptr = SP_REF_PTR (a); \
+ idx = SP_REF_U64 (b); \
+ memcpy (&val, ptr + idx, sizeof (val)); \
+ SP_SET_ ## slot (dst, val); \
+ NEXT (1); \
+ } while (0)
+
+#define PTR_SET(type, slot) \
+ do { \
+ scm_t_uint8 a, b, c; \
+ char *ptr; \
+ size_t idx; \
+ type val; \
+ UNPACK_8_8_8 (op, a, b, c); \
+ ptr = SP_REF_PTR (a); \
+ idx = SP_REF_U64 (b); \
+ val = SP_REF_ ## slot (c); \
+ memcpy (ptr + idx, &val, sizeof (val)); \
+ NEXT (1); \
+ } while (0)
+
+ VM_DEFINE_OP (223, u8_ref, "u8-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (scm_t_uint8, U64);
+ VM_DEFINE_OP (224, u16_ref, "u16-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (scm_t_uint16, U64);
+ VM_DEFINE_OP (225, u32_ref, "u32-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (scm_t_uint32, U64);
+ VM_DEFINE_OP (226, u64_ref, "u64-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (scm_t_uint64, U64);
+
+ VM_DEFINE_OP (227, u8_set, "u8-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (scm_t_uint8, U64);
+ VM_DEFINE_OP (228, u16_set, "u16-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (scm_t_uint16, U64);
+ VM_DEFINE_OP (229, u32_set, "u32-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (scm_t_uint32, U64);
+ VM_DEFINE_OP (230, u64_set, "u64-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (scm_t_uint64, U64);
+
+ VM_DEFINE_OP (231, s8_ref, "s8-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (scm_t_int8, S64);
+ VM_DEFINE_OP (232, s16_ref, "s16-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (scm_t_int16, S64);
+ VM_DEFINE_OP (233, s32_ref, "s32-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (scm_t_int32, S64);
+ VM_DEFINE_OP (234, s64_ref, "s64-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (scm_t_int64, S64);
+
+ VM_DEFINE_OP (235, s8_set, "s8-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (scm_t_int8, S64);
+ VM_DEFINE_OP (236, s16_set, "s16-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (scm_t_int16, S64);
+ VM_DEFINE_OP (237, s32_set, "s32-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (scm_t_int32, S64);
+ VM_DEFINE_OP (238, s64_set, "s64-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (scm_t_int64, S64);
+
+ VM_DEFINE_OP (239, f32_ref, "f32-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (float, F64);
+ VM_DEFINE_OP (240, f64_ref, "f64-ref", OP1 (X8_S8_S8_S8) | OP_DST)
+ PTR_REF (double, F64);
+
+ VM_DEFINE_OP (241, f32_set, "f32-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (float, F64);
+ VM_DEFINE_OP (242, f64_set, "f64-set!", OP1 (X8_S8_S8_S8))
+ PTR_SET (double, F64);
+
VM_DEFINE_OP (243, unused_243, NULL, NOP)
VM_DEFINE_OP (244, unused_244, NULL, NOP)
VM_DEFINE_OP (245, unused_245, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index dceab60..30d6ef6 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -272,6 +272,38 @@
(($ $primcall 'bv-f64-ref #f (bv idx val))
(emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
+
+ (($ $primcall 'u8-ref ann (obj ptr idx))
+ (emit-u8-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 's8-ref ann (obj ptr idx))
+ (emit-s8-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'u16-ref ann (obj ptr idx))
+ (emit-u16-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 's16-ref ann (obj ptr idx))
+ (emit-s16-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'u32-ref ann (obj ptr idx val))
+ (emit-u32-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 's32-ref ann (obj ptr idx val))
+ (emit-s32-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'u64-ref ann (obj ptr idx val))
+ (emit-u64-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 's64-ref ann (obj ptr idx val))
+ (emit-s64-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'f32-ref ann (obj ptr idx val))
+ (emit-f32-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'f64-ref ann (obj ptr idx val))
+ (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))
@@ -340,6 +372,7 @@
(emit-pop-dynamic-state asm))
(($ $primcall 'wind #f (winder unwinder))
(emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
+
(($ $primcall 'bv-u8-set! #f (bv idx val))
(emit-bv-u8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
@@ -370,6 +403,38 @@
(($ $primcall 'bv-f64-set! #f (bv idx val))
(emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
+
+ (($ $primcall 'u8-set! ann (obj ptr idx val))
+ (emit-u8-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 's8-set! ann (obj ptr idx val))
+ (emit-s8-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'u16-set! ann (obj ptr idx val))
+ (emit-u16-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 's16-set! #f (obj ptr idx val))
+ (emit-s16-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'u32-set! #f (obj ptr idx val))
+ (emit-u32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 's32-set! #f (obj ptr idx val))
+ (emit-s32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'u64-set! #f (obj ptr idx val))
+ (emit-u64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 's64-set! #f (obj ptr idx val))
+ (emit-s64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'f32-set! #f (obj ptr idx val))
+ (emit-f32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'f64-set! #f (obj ptr idx val))
+ (emit-f64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+
(($ $primcall 'unwind #f ())
(emit-unwind asm))
(($ $primcall 'fluid-set! #f (fluid value))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index b3344ff..488a806 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -456,6 +456,30 @@ the LABELS that are clobbered by the effects of LABEL."
((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
+;; Pointers.
+(define-primitive-effects* param
+ ((u8-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((s8-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((u16-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((s16-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((u32-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((s32-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((u64-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((s64-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((f32-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+ ((f64-ref obj bv n) (&read-object (annotation->memory-kind
param)))
+
+ ((u8-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((s8-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((u16-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((s16-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((u32-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((s32-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((u64-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((s64-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((f32-set! obj bv n x) (&write-object (annotation->memory-kind
param)))
+ ((f64-set! obj bv n x) (&write-object (annotation->memory-kind
param))))
+
;; Closures.
(define-primitive-effects* param
((free-ref closure) (&read-field &closure param))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index bb6ed53..3183f25 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -747,6 +747,7 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-add representations var
(intmap-ref representations arg)))
(($ $primcall (or 'scm->f64 'load-f64
+ 'f32-ref 'f64-ref
'bv-f32-ref 'bv-f64-ref
'fadd 'fsub 'fmul 'fdiv))
(intmap-add representations var 'f64))
@@ -757,12 +758,14 @@ are comparable with eqv?. A tmp slot may be used."
'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
'uadd/immediate 'usub/immediate 'umul/immediate
'ursh/immediate 'ulsh/immediate
+ 'u8-ref 'u16-ref 'u32-ref 'u64-ref
'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref
'word-ref 'word-ref/immediate))
(intmap-add representations var 'u64))
(($ $primcall (or 'untag-fixnum
'scm->s64 'load-s64 'u64->s64
'srsh 'srsh/immediate
+ 's8-ref 's16-ref 's32-ref 's64-ref
'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref))
(intmap-add representations var 's64))
(($ $primcall (or 'gc-pointer-ref/immediate))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 88b2b42..a498c20 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1015,6 +1015,28 @@ minimum, and maximum."
;;;
+;;; Pointers
+;;;
+
+(define-syntax-rule (define-pointer-ref-inferrer ref type lo hi)
+ (define-type-inferrer (ref obj bv idx result)
+ (define! result type lo hi)))
+(define-pointer-ref-inferrer u8-ref &u64 0 #xff)
+(define-pointer-ref-inferrer u16-ref &u64 0 #xffff)
+(define-pointer-ref-inferrer u32-ref &u64 0 #xffffffff)
+(define-pointer-ref-inferrer u64-ref &u64 0 &u64-max)
+
+(define-pointer-ref-inferrer s8-ref &s64 (- #x80) #x7f)
+(define-pointer-ref-inferrer s16-ref &s64 (- #x8000) #x7fff)
+(define-pointer-ref-inferrer s32-ref &s64 (- #x80000000) #x7fffffff)
+(define-pointer-ref-inferrer s64-ref &s64 &s64-min &s64-max)
+
+(define-pointer-ref-inferrer f32-ref &f64 -inf.0 +inf.0)
+(define-pointer-ref-inferrer f64-ref &f64 -inf.0 +inf.0)
+
+
+
+;;;
;;; Numbers.
;;;
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 0eb96cd..0e724d5 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -158,6 +158,27 @@
emit-gc-pointer-ref/immediate
emit-gc-pointer-set!/immediate
+ emit-u8-ref
+ emit-s8-ref
+ emit-u16-ref
+ emit-s16-ref
+ emit-u32-ref
+ emit-s32-ref
+ emit-u64-ref
+ emit-s64-ref
+ emit-f32-ref
+ emit-f64-ref
+ emit-u8-set!
+ emit-s8-set!
+ emit-u16-set!
+ emit-s16-set!
+ emit-u32-set!
+ emit-s32-set!
+ emit-u64-set!
+ emit-s64-set!
+ emit-f32-set!
+ emit-f64-set!
+
emit-call
emit-call-label
emit-tail-call
- [Guile-commits] 01/13: Instruction explosion for struct-vtable, (continued)
- [Guile-commits] 01/13: Instruction explosion for struct-vtable, Andy Wingo, 2018/01/16
- [Guile-commits] 12/13: Remove optimizer and backend support for bv-u8-ref et al, Andy Wingo, 2018/01/16
- [Guile-commits] 02/13: Add support for raw gc-managed pointer locals, Andy Wingo, 2018/01/16
- [Guile-commits] 10/13: Add assume-u64 and assume-s64 dataflow restrictions, Andy Wingo, 2018/01/16
- [Guile-commits] 06/13: Custom bv-u8-ref lowering procedure, Andy Wingo, 2018/01/16
- [Guile-commits] 09/13: Instruction explosion for bytevector setters, Andy Wingo, 2018/01/16
- [Guile-commits] 07/13: Instruction explosion for integer bytevector ref procedures, Andy Wingo, 2018/01/16
- [Guile-commits] 03/13: Add optimizer and backend support for gc-pointer-ref, Andy Wingo, 2018/01/16
- [Guile-commits] 13/13: Remove bytevector instructions from the VM., Andy Wingo, 2018/01/16
- [Guile-commits] 08/13: Add f32-ref, f64-ref lowering procs, Andy Wingo, 2018/01/16
- [Guile-commits] 04/13: Add raw u8-ref, etc instructions,
Andy Wingo <=
- [Guile-commits] 05/13: Rename gc-pointer-ref to pointer-ref, Andy Wingo, 2018/01/16