summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-11-21 11:50:15 +0100
committerAndy Wingo <wingo@pobox.com>2015-12-01 15:42:24 +0100
commita08b3d40f8d1093b96ca4fc8aa440fd71bd0f20e (patch)
treef9a643f52b93fca63b8cddf98ea4641d79dccc9f /module
parent8bf77f7192dd319cf5391639310abb35b9e627d7 (diff)
downloadguile-a08b3d40f8d1093b96ca4fc8aa440fd71bd0f20e.tar.gz
Untag values and indexes for all bytevector instructions
* libguile/vm-engine.c (bv-s8-ref, bv-s16-ref, bv-s32-ref, bv-s64-ref): Unbox index and return unboxed S32 value. (bv-s8-set!, bv-s16-set!, bv-s32-set!, bv-s64-set!): Unbox index and take unboxed S32 value. (bv-u8-ref, bv-u16-ref, bv-u32-ref, bv-u64-ref) (bv-s8-set!, bv-s16-set!, bv-s32-set!, bv-s64-set!): Likewise, but with unsigned values. (bv-f32-ref, bv-f32-set!, bv-f64-ref, bv-f64-set!): Use memcpy to access the value so we don't have to think about alignment. GCC will inline this to a single instruction on architectures that support unaligned access. * libguile/vm.c (vm_error_out_of_range_uint64) (vm_error_out_of_range_int64): New helpers. * module/language/cps/slot-allocation.scm (compute-var-representations): All bytevector ref operations produce untagged values. * module/language/cps/types.scm (define-bytevector-accessors): Update for bytevector untagged indices and values. * module/language/cps/utils.scm (compute-constant-values): Fix s64 case. * module/language/tree-il/compile-cps.scm (convert): Box results of all bytevector accesses, and unbox incoming indices and values.
Diffstat (limited to 'module')
-rw-r--r--module/language/bytecode.scm4
-rw-r--r--module/language/cps/slot-allocation.scm6
-rw-r--r--module/language/cps/specialize-primcalls.scm4
-rw-r--r--module/language/cps/types.scm57
-rw-r--r--module/language/cps/utils.scm2
-rw-r--r--module/language/tree-il/compile-cps.scm33
-rw-r--r--module/system/vm/assembler.scm5
-rw-r--r--module/system/vm/disassembler.scm2
8 files changed, 64 insertions, 49 deletions
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm
index fb7ef7348..c140b4bb3 100644
--- a/module/language/bytecode.scm
+++ b/module/language/bytecode.scm
@@ -51,8 +51,8 @@
(case word
((C32) 1)
((I32) 1)
- ((A32 AU32 AF32) 1)
- ((B32 BF32 BU32) 0)
+ ((A32 AU32 AS32 AF32) 1)
+ ((B32 BF32 BS32 BU32) 0)
((N32) 1)
((R32) 1)
((L32) 1)
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 4123446fd..c378bd1f5 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -802,9 +802,11 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-add representations var 'f64))
(($ $primcall (or 'scm->u64 'load-u64 'bv-length
'uadd 'usub 'umul
- 'uadd/immediate 'usub/immediate 'umul/immediate))
+ 'uadd/immediate 'usub/immediate 'umul/immediate
+ 'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref))
(intmap-add representations var 'u64))
- (($ $primcall (or 'scm->s64 'load-s64))
+ (($ $primcall (or 'scm->s64 'load-s64
+ 'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref))
(intmap-add representations var 's64))
(_
(intmap-add representations var 'scm))))
diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm
index 9a66917ba..59c3055c3 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -39,6 +39,10 @@
(define (u64? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val) (<= 0 val #xffffFFFFffffFFFF))))
+ (define (s64? var)
+ (let ((val (intmap-ref constants var (lambda (_) #f))))
+ (and (exact-integer? val)
+ (<= (- #x8000000000000000) val #x7fffFFFFffffFFFF))))
(define (f64? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (number? val) (inexact? val) (real? val))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 72e4dd2aa..a5ea1bf72 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -760,45 +760,6 @@ minimum, and maximum."
(begin
(define-type-checker (ref bv idx)
(and (check-type bv &bytevector 0 *max-size-t*)
- (check-type idx &exact-integer 0 *max-size-t*)
- (< (&max idx) (- (&min bv) size))))
- (define-type-inferrer (ref bv idx result)
- (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*)
- (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size))
- (define! result type lo hi))
- (define-type-checker (set bv idx val)
- (and (check-type bv &bytevector 0 *max-size-t*)
- (check-type idx &exact-integer 0 *max-size-t*)
- (check-type val type lo hi)
- (< (&max idx) (- (&min bv) size))))
- (define-type-inferrer (set! bv idx val)
- (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*)
- (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size))
- (restrict! val type lo hi))))
-
-(define-syntax-rule (define-short-bytevector-accessors ref set size signed?)
- (define-bytevector-accessors ref set &exact-integer size
- (if signed? (- (ash 1 (1- (* size 8)))) 0)
- (1- (ash 1 (if signed? (1- (* size 8)) (* size 8))))))
-
-(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f)
-(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t)
-(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f)
-(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t)
-
-(define-bytevector-accessors bv-u32-ref bv-u32-set!
- &exact-integer 4 #x00000000 #xffffFFFF)
-(define-bytevector-accessors bv-s32-ref bv-s32-set!
- &exact-integer 4 (- #x80000000) #x7fffFFFF)
-(define-bytevector-accessors bv-u64-ref bv-u64-set!
- &exact-integer 8 0 &u64-max)
-(define-bytevector-accessors bv-s64-ref bv-s64-set!
- &exact-integer 8 &s64-min &s64-max)
-
-(define-syntax-rule (define-bytevector-uaccessors ref set type size lo hi)
- (begin
- (define-type-checker (ref bv idx)
- (and (check-type bv &bytevector 0 *max-size-t*)
(check-type idx &u64 0 *max-size-t*)
(< (&max idx) (- (&min bv) size))))
(define-type-inferrer (ref bv idx result)
@@ -814,8 +775,22 @@ minimum, and maximum."
(restrict! bv &bytevector (+ (&min idx) size) *max-size-t*)
(restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size))
(restrict! val type lo hi))))
-(define-bytevector-uaccessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0)
-(define-bytevector-uaccessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0)
+
+(define-bytevector-accessors bv-u8-ref bv-u8-set! &u64 1 0 #xff)
+(define-bytevector-accessors bv-s8-ref bv-s8-set! &s64 1 (- #x80) #x7f)
+
+(define-bytevector-accessors bv-u16-ref bv-u16-set! &u64 2 0 #xffff)
+(define-bytevector-accessors bv-s16-ref bv-s16-set! &s64 2 (- #x8000) #x7fff)
+
+(define-bytevector-accessors bv-u32-ref bv-u32-set! &u64 4 0 #xffffffff)
+(define-bytevector-accessors bv-s32-ref bv-s32-set! &s64 4
+ (- #x80000000) #x7fffffff)
+
+(define-bytevector-accessors bv-u64-ref bv-u64-set! &u64 8 0 &u64-max)
+(define-bytevector-accessors bv-s64-ref bv-s64-set! &s64 8 &s64-min &s64-max)
+
+(define-bytevector-accessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0)
+(define-bytevector-accessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index e528ca338..750fd17b1 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -223,7 +223,7 @@ disjoint, an error will be signalled."
(($ $primcall 'scm->s64 (val))
(let ((s64 (intmap-ref out val (lambda (_) #f))))
(if (and s64 (number? s64) (exact-integer? s64)
- (<= (- #x8000000000000000) u64 #x7fffFFFFffffFFFF))
+ (<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
(intmap-add! out var s64)
out)))
(_ out)))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 2bde7c5d3..c1f976ae0 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -576,13 +576,20 @@
(letk kbox ($kargs ('f64) (f64)
($continue k src ($primcall 'f64->scm (f64)))))
kbox))
- ((bv-length)
+ ((bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref)
(with-cps cps
(letv u64)
(let$ k (adapt-arity k src out))
(letk kbox ($kargs ('u64) (u64)
($continue k src ($primcall 'u64->scm (u64)))))
kbox))
+ ((bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref)
+ (with-cps cps
+ (letv s64)
+ (let$ k (adapt-arity k src out))
+ (letk kbox ($kargs ('s64) (s64)
+ ($continue k src ($primcall 's64->scm (s64)))))
+ kbox))
(else
(adapt-arity cps k src out))))
(define (unbox-arg cps arg unbox-op have-arg)
@@ -594,7 +601,9 @@
($continue kunboxed src ($primcall unbox-op (arg))))))
(define (unbox-args cps args have-args)
(case instruction
- ((bv-f32-ref bv-f64-ref)
+ ((bv-f32-ref bv-f64-ref
+ bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref
+ bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref)
(match args
((bv idx)
(unbox-arg
@@ -611,6 +620,26 @@
cps val 'scm->f64
(lambda (cps val)
(have-args cps (list bv idx val)))))))))
+ ((bv-s8-set! bv-s16-set! bv-s32-set! bv-s64-set!)
+ (match args
+ ((bv idx val)
+ (unbox-arg
+ cps idx 'scm->u64
+ (lambda (cps idx)
+ (unbox-arg
+ cps val 'scm->s64
+ (lambda (cps val)
+ (have-args cps (list bv idx val)))))))))
+ ((bv-u8-set! bv-u16-set! bv-u32-set! bv-u64-set!)
+ (match args
+ ((bv idx val)
+ (unbox-arg
+ cps idx 'scm->u64
+ (lambda (cps idx)
+ (unbox-arg
+ cps val 'scm->u64
+ (lambda (cps val)
+ (have-args cps (list bv idx val)))))))))
(else (have-args cps args))))
(convert-args cps args
(lambda (cps args)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 59b194d16..0e4bbf06c 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -582,8 +582,13 @@ later by the linker."
((AU32 u64)
(emit asm (ash u64 -32))
(emit asm (logand u64 (1- (ash 1 32)))))
+ ((AS32 s64)
+ (let ((u64 (u64vector-ref (s64vector s64) 0)))
+ (emit asm (ash u64 -32))
+ (emit asm (logand u64 (1- (ash 1 32))))))
((B32))
((BU32))
+ ((BS32))
((BF32))
((N32 label)
(record-far-label-reference asm label)
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 794caa759..6c21ad609 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -108,7 +108,7 @@
(define (parse-tail-word word type)
(with-syntax ((word word))
(case type
- ((C32 I32 A32 B32 AU32 BU32 AF32 BF32)
+ ((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32)
#'(word))
((N32 R32 L32 LO32)
#'((unpack-s32 word)))