mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Add raw u8-ref, etc instructions

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2018-01-14 12:59:02 +01:00
parent d355b42a3e
commit 13cafca168
6 changed files with 209 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

94
libguile/vm-engine.c
View file

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

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

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

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

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

3
module/language/cps/slot-allocation.scm
View file

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

22
module/language/cps/types.scm
View file

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

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

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