From 13cafca1681ce830796c453add297a240e7c44b5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 14 Jan 2018 12:59:02 +0100 Subject: [PATCH] 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 5206b96b0..5f856c488 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 dceab600e..30d6ef644 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 b3344ff7a..488a8062f 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 bb6ed53bb..3183f2594 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 88b2b4268..a498c201d 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1012,6 +1012,28 @@ minimum, and maximum." (define-bytevector-accessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) + + +;;; +;;; 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) + ;;; diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 0eb96cdf9..0e724d50e 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