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

Untag values and indexes for all bytevector instructions

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-11-21 11:50:15 +01:00
parent 8bf77f7192
commit a08b3d40f8
11 changed files with 151 additions and 235 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/language/bytecode.scm
View file

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

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

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

4
module/language/cps/specialize-primcalls.scm
View file

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

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

@ -757,45 +757,6 @@ minimum, and maximum."
(max (&min bv) 0) (min (&max bv) *max-size-t*)))
(define-syntax-rule (define-bytevector-accessors 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 &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*)
@ -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)

2
module/language/cps/utils.scm
View file

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

33
module/language/tree-il/compile-cps.scm
View file

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

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

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

2
module/system/vm/disassembler.scm
View file

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