diff options
author | Andy Wingo <wingo@pobox.com> | 2015-11-21 11:50:15 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-12-01 15:42:24 +0100 |
commit | a08b3d40f8d1093b96ca4fc8aa440fd71bd0f20e (patch) | |
tree | f9a643f52b93fca63b8cddf98ea4641d79dccc9f /module | |
parent | 8bf77f7192dd319cf5391639310abb35b9e627d7 (diff) | |
download | guile-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.scm | 4 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 6 | ||||
-rw-r--r-- | module/language/cps/specialize-primcalls.scm | 4 | ||||
-rw-r--r-- | module/language/cps/types.scm | 57 | ||||
-rw-r--r-- | module/language/cps/utils.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 33 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 5 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 2 |
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))) |