[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 07/13: Instruction explosion for integer bytevector ref
From: |
Andy Wingo |
Subject: |
[Guile-commits] 07/13: Instruction explosion for integer bytevector ref procedures |
Date: |
Tue, 16 Jan 2018 10:46:30 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 0270d235bdbf6bc3b52cf3a9c9a8ce9fde7d14c5
Author: Andy Wingo <address@hidden>
Date: Mon Jan 15 20:25:53 2018 +0100
Instruction explosion for integer bytevector ref procedures
* module/language/cps/compile-bytecode.scm (compile-function): Fix
emitters for u16-ref et al.
* module/language/tree-il/compile-cps.scm (bytevector-ref-converter):
(define-bytevector-ref-converter, define-bytevector-ref-converters):
New helpers. Use to define lowerers for bv-s32-ref et al.
---
module/language/cps/compile-bytecode.scm | 12 ++---
module/language/tree-il/compile-cps.scm | 76 ++++++++++++++++++++++++--------
2 files changed, 63 insertions(+), 25 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index a1b11ea..c2d48f9 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -285,22 +285,22 @@
(($ $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))
+ (($ $primcall 'u32-ref ann (obj ptr idx))
(emit-u32-ref asm (from-sp dst) (from-sp (slot ptr))
(from-sp (slot idx))))
- (($ $primcall 's32-ref ann (obj ptr idx val))
+ (($ $primcall 's32-ref ann (obj ptr idx))
(emit-s32-ref asm (from-sp dst) (from-sp (slot ptr))
(from-sp (slot idx))))
- (($ $primcall 'u64-ref ann (obj ptr idx val))
+ (($ $primcall 'u64-ref ann (obj ptr idx))
(emit-u64-ref asm (from-sp dst) (from-sp (slot ptr))
(from-sp (slot idx))))
- (($ $primcall 's64-ref ann (obj ptr idx val))
+ (($ $primcall 's64-ref ann (obj ptr idx))
(emit-s64-ref asm (from-sp dst) (from-sp (slot ptr))
(from-sp (slot idx))))
- (($ $primcall 'f32-ref ann (obj ptr idx val))
+ (($ $primcall 'f32-ref ann (obj ptr idx))
(emit-f32-ref asm (from-sp dst) (from-sp (slot ptr))
(from-sp (slot idx))))
- (($ $primcall 'f64-ref ann (obj ptr idx val))
+ (($ $primcall 'f64-ref ann (obj ptr idx))
(emit-f64-ref asm (from-sp dst) (from-sp (slot ptr))
(from-sp (slot idx))))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 9a19ed3..7e0ef91 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -716,22 +716,61 @@
($primcall 'word-ref/immediate '(bytevector . 1) (bv)))))
($ (ensure-bytevector klen src op pred bv))))
-(define-primcall-converter bv-u8-ref
+(define (bytevector-ref-converter scheme-name ptr-op width signed?)
+ (define tag
+ (if (< (ash 1 (* width 8)) (target-most-positive-fixnum))
+ (if signed?
+ (lambda (cps k src val)
+ (with-cps cps
+ (build-term
+ ($continue k src ($primcall 'tag-fixnum #f (val))))))
+ (lambda (cps k src val)
+ (with-cps cps
+ (letv s)
+ (letk kcvt
+ ($kargs ('s) (s)
+ ($continue k src ($primcall 'tag-fixnum #f (s)))))
+ (build-term
+ ($continue kcvt src ($primcall 'u64->s64 #f (val)))))))
+ (if signed?
+ (lambda (cps k src val)
+ (with-cps cps
+ (build-term
+ ($continue k src ($primcall 's64->scm #f (val))))))
+ (lambda (cps k src val)
+ (with-cps cps
+ (build-term
+ ($continue k src ($primcall 'u64->scm #f (val)))))))))
(lambda (cps k src op param bv idx)
(prepare-bytevector-access
- cps src 'bytevector-u8-ref 'bytevector? bv idx 1
+ cps src scheme-name 'bytevector? bv idx width
(lambda (cps ptr uidx)
(with-cps cps
- (letv u8 s8)
- (letk ktag
- ($kargs ('s8) (s8)
- ($continue k src ($primcall 'tag-fixnum #f (s8)))))
- (letk kcvt
- ($kargs ('u8) (u8)
- ($continue ktag src ($primcall 'u64->s64 #f (u8)))))
+ (letv val)
+ (let$ body (tag k src val))
+ (letk ktag ($kargs ('val) (val) ,body))
(build-term
- ($continue kcvt src
- ($primcall 'u8-ref 'bytevector (bv ptr uidx)))))))))
+ ($continue ktag src
+ ($primcall ptr-op 'bytevector (bv ptr uidx)))))))))
+
+(define-syntax-rule (define-bytevector-ref-converter
+ cps-name scheme-name op width signed?)
+ (define-primcall-converter cps-name
+ (bytevector-ref-converter 'scheme-name 'op width signed?)))
+(define-syntax-rule (define-bytevector-ref-converters (cvt ...) ...)
+ (begin
+ (define-bytevector-ref-converter cvt ...)
+ ...))
+
+(define-bytevector-ref-converters
+ (bv-u8-ref bytevector-u8-ref u8-ref 1 #f)
+ (bv-u16-ref bytevector-u16-native-ref u16-ref 2 #f)
+ (bv-u32-ref bytevector-u32-native-ref u32-ref 4 #f)
+ (bv-u64-ref bytevector-u64-native-ref u64-ref 8 #f)
+ (bv-s8-ref bytevector-s8-ref s8-ref 1 #t)
+ (bv-s16-ref bytevector-s16-native-ref s16-ref 2 #t)
+ (bv-s32-ref bytevector-s32-native-ref s32-ref 4 #t)
+ (bv-s64-ref bytevector-s64-native-ref s64-ref 8 #t))
(define-primcall-converters
(char->integer scm >u64)
@@ -748,14 +787,13 @@
(bv-f64-ref scm u64 >f64) (bv-f64-set! scm u64 f64)
(bv-u8-set! scm u64 u64)
-
- (bv-u16-ref scm u64 >u64) (bv-u16-set! scm u64 u64)
- (bv-u32-ref scm u64 >u64) (bv-u32-set! scm u64 u64)
- (bv-u64-ref scm u64 >u64) (bv-u64-set! scm u64 u64)
- (bv-s8-ref scm u64 >s64) (bv-s8-set! scm u64 s64)
- (bv-s16-ref scm u64 >s64) (bv-s16-set! scm u64 s64)
- (bv-s32-ref scm u64 >s64) (bv-s32-set! scm u64 s64)
- (bv-s64-ref scm u64 >s64) (bv-s64-set! scm u64 s64)
+ (bv-u16-set! scm u64 u64)
+ (bv-u32-set! scm u64 u64)
+ (bv-u64-set! scm u64 u64)
+ (bv-s8-set! scm u64 s64)
+ (bv-s16-set! scm u64 s64)
+ (bv-s32-set! scm u64 s64)
+ (bv-s64-set! scm u64 s64)
(rsh scm u64 >scm)
(lsh scm u64 >scm))
- [Guile-commits] branch master updated (02e52a4 -> 310c34e), Andy Wingo, 2018/01/16
- [Guile-commits] 11/13: Instruction explosion for bv-length, Andy Wingo, 2018/01/16
- [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 <=
- [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, 2018/01/16
- [Guile-commits] 05/13: Rename gc-pointer-ref to pointer-ref, Andy Wingo, 2018/01/16