mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-23 03:54:12 +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

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