summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-11-19 22:13:57 +0100
committerAndy Wingo <wingo@pobox.com>2015-12-01 11:30:54 +0100
commit87cc8b0f97d231b056ffac0870db708bf996ddf9 (patch)
tree989e1401a3ab3fb235d778680fee82df68a58468 /module
parent8464cc576c0fb9cf70a51450795338996cc785ce (diff)
downloadguile-87cc8b0f97d231b056ffac0870db708bf996ddf9.tar.gz
bv-f{32,64}-{ref,set!} take unboxed u64 index
* module/language/tree-il/compile-cps.scm (convert): bv-f32-ref, bv-f32-set!, bv-f64-ref, and bv-f64-set! take the index as an untagged u64 value. * module/language/cps/types.scm (define-bytevector-uaccessors): New helper, used while migrating bytevectors to take unboxed indexes. Adapt f32/f64 accessors to use this definition helper. * libguile/vm-engine.c (BV_FLOAT_REF, BV_FLOAT_SET): The index is unboxed.
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/types.scm24
-rw-r--r--module/language/tree-il/compile-cps.scm27
2 files changed, 41 insertions, 10 deletions
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index b99d0f4ab..857a3724d 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -756,8 +756,28 @@ minimum, and maximum."
&exact-integer 8 #x0000000000000000 #xffffFFFFffffFFFF)
(define-bytevector-accessors bv-s64-ref bv-s64-set!
&exact-integer 8 (- #x8000000000000000) #x7fffFFFFffffFFFF)
-(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)
+
+(define-syntax-rule (define-bytevector-uaccessors ref set type size min max)
+ (begin
+ (define-type-checker (ref bv idx)
+ (and (check-type bv &bytevector 0 +inf.0)
+ (check-type idx &u64 0 +inf.0)
+ (< (&max idx) (- (&min bv) size))))
+ (define-type-inferrer (ref bv idx result)
+ (restrict! bv &bytevector (+ (&min idx) size) +inf.0)
+ (restrict! idx &u64 0 (- (&max bv) size))
+ (define! result type min max))
+ (define-type-checker (set bv idx val)
+ (and (check-type bv &bytevector 0 +inf.0)
+ (check-type idx &u64 0 +inf.0)
+ (check-type val type min max)
+ (< (&max idx) (- (&min bv) size))))
+ (define-type-inferrer (set! bv idx val)
+ (restrict! bv &bytevector (+ (&min idx) size) +inf.0)
+ (restrict! idx &exact-integer 0 (- (&max bv) size))
+ (restrict! val type min max))))
+(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)
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 7b220b5a9..2bde7c5d3 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -585,21 +585,32 @@
kbox))
(else
(adapt-arity cps k src out))))
- (define (unbox-arg cps arg have-arg)
+ (define (unbox-arg cps arg unbox-op have-arg)
(with-cps cps
- (letv f64)
- (let$ body (have-arg f64))
- (letk kunboxed ($kargs ('f64) (f64) ,body))
+ (letv unboxed)
+ (let$ body (have-arg unboxed))
+ (letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(build-term
- ($continue kunboxed src ($primcall 'scm->f64 (arg))))))
+ ($continue kunboxed src ($primcall unbox-op (arg))))))
(define (unbox-args cps args have-args)
(case instruction
+ ((bv-f32-ref bv-f64-ref)
+ (match args
+ ((bv idx)
+ (unbox-arg
+ cps idx 'scm->u64
+ (lambda (cps idx)
+ (have-args cps (list bv idx)))))))
((bv-f32-set! bv-f64-set!)
(match args
((bv idx val)
- (unbox-arg cps val
- (lambda (cps val)
- (have-args cps (list bv idx val)))))))
+ (unbox-arg
+ cps idx 'scm->u64
+ (lambda (cps idx)
+ (unbox-arg
+ cps val 'scm->f64
+ (lambda (cps val)
+ (have-args cps (list bv idx val)))))))))
(else (have-args cps args))))
(convert-args cps args
(lambda (cps args)