suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

performance tweaks for `for/{fx,fl,extfl}vector'

Browse Source 
Also, provide a better error message when the body produces a
non-{fix,flo,extflo}num.
This commit is contained in:
Matthew Flatt 2013-04-10 17:22:58 -06:00
parent 37c55967b0
commit d4fa2766c2
9 changed files with 72 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/data/bit-vector.rkt
View File

@ -138,6 +138,7 @@
(define-vector-wraps "bit-vector"
"boolean?" boolean?
bit-vector? bit-vector-length bit-vector-ref bit-vector-set! make-bit-vector
unsafe-bit-vector-ref bit-vector-set! bit-vector-length
in-bit-vector*

1
collects/racket/extflonum.rkt
View File

@ -11,6 +11,7 @@
extflvector-copy)
(define-vector-wraps "extflvector"
"extflonum?" extflonum?
extflvector? extflvector-length extflvector-ref extflvector-set! make-extflvector
unsafe-extflvector-ref unsafe-extflvector-set! unsafe-extflvector-length
in-extflvector*

1
collects/racket/fixnum.rkt
View File

@ -20,6 +20,7 @@
in-fxvector for/fxvector for*/fxvector)
(define-vector-wraps "fxvector"
"fixnum?" fixnum?
fxvector? fxvector-length fxvector-ref fxvector-set! make-fxvector
unsafe-fxvector-ref unsafe-fxvector-set! unsafe-fxvector-length
in-fxvector*

1
collects/racket/flonum.rkt
View File

@ -19,6 +19,7 @@
in-flvector for/flvector for*/flvector)
(define-vector-wraps "flvector"
"flonum?" flonum?
flvector? flvector-length flvector-ref flvector-set! make-flvector
unsafe-flvector-ref unsafe-flvector-set! unsafe-flvector-length
in-flvector*

8
collects/racket/private/for.rkt
View File

@ -1497,10 +1497,10 @@
[i 0])
(for-clause ...)
middle-body ...
(let ([new-vec (if (eq? i (unsafe-vector-length vec))
(let ([new-vec (if (eq? i (unsafe-vector*-length vec))
(grow-vector vec)
vec)])
(unsafe-vector-set! new-vec i (let () last-body ...))
(unsafe-vector*-set! new-vec i (let () last-body ...))
(values new-vec (unsafe-fx+ i 1))))])
(shrink-vector vec i))))]
[(_ #:length length-expr #:fill fill-expr (for-clause ...) body ...)
@ -1546,8 +1546,8 @@
([i 0])
(limited-for-clause ...)
middle-body ...
(vector-set! v i (let () last-body ...))
(add1 i)))
(unsafe-vector*-set! v i (let () last-body ...))
(unsafe-fx+ 1 i)))
v))))]
[(_ #:length length-expr (for-clause ...) body ...)
(for_/vector #'(fv #:length length-expr #:fill 0 (for-clause ...) body ...)

16
collects/racket/private/vector-wraps.rkt
View File

@ -9,6 +9,7 @@
(define-syntax-rule (define-vector-wraps
fXvector-str
fX?-str fX?
fXvector? fXvector-length fXvector-ref fXvector-set! make-fXvector
unsafe-fXvector-ref unsafe-fXvector-set! unsafe-fXvector-length
in-fXvector*
@ -50,6 +51,9 @@
(unsafe-fXvector-copy! new-vec 0 vec 0 i)
new-vec)
(define (not-an-fX who v)
(raise-argument-error who fX?-str v))
(define-for-syntax (for_/fXvector stx orig-stx for_/fXvector-stx for_/fold/derived-stx wrap-all?)
(syntax-case stx ()
[(for*/fXvector (for-clause ...) body ...)
@ -67,7 +71,10 @@
(let ([new-vec (if (eq? i (unsafe-fXvector-length vec))
(grow-fXvector vec)
vec)])
(fXvector-set! new-vec i (let () last-body ...))
(let ([elem (let () last-body ...)])
(if (fX? elem)
(unsafe-fXvector-set! new-vec i elem)
(not-an-fX 'for*/fXvector elem)))
(values new-vec (unsafe-fx+ i 1))))])
(shrink-fXvector vec i))))]
[(for*/fXvector #:length length-expr #:fill fill-expr (for-clause ...) body ...)
@ -114,8 +121,11 @@
([i 0])
(limited-for-clause ...)
middle-body ...
(fXvector-set! v i (let () last-body ...))
(add1 i)))
(let ([elem (let () last-body ...)])
(if (fX? elem)
(unsafe-fXvector-set! v i elem)
(not-an-fX 'for*/vector elem)))
(unsafe-fx+ 1 i)))
v)))))]
[(_ #:length length-expr (for-clause ...) body ...)
(for_/fXvector #'(fv #:length length-expr #:fill fXzero (for-clause ...) body ...)

26
collects/tests/racket/optimize.rktl
View File

@ -1788,6 +1788,32 @@
(+ p (unsafe-fx- p 1) (- p p) t))
'ok))))
;; eliminate unneeded tests:
(test-comp '(lambda (n)
(let ([p (fl+ n n)])
(if (flonum? p)
(fl+ p p)
'bad)))
'(lambda (n)
(let ([p (fl+ n n)])
(fl+ p p))))
(test-comp '(lambda (n)
(let ([p (fx+ n n)])
(if (fixnum? p)
(fx+ p p)
'bad)))
'(lambda (n)
(let ([p (fx+ n n)])
(fx+ p p))))
(test-comp '(lambda (n)
(let ([p (extfl+ n n)])
(if (extflonum? p)
(extfl+ p p)
'bad)))
'(lambda (n)
(let ([p (extfl+ n n)])
(extfl+ p p))))
;; simple cross-module inlining
(test-comp `(module m racket/base
(require racket/bool)

3
src/racket/src/number.c
View File

@ -815,7 +815,8 @@ void scheme_init_flfxnum_number(Scheme_Env *env)
flags = SCHEME_PRIM_IS_UNARY_INLINED;
else
flags = SCHEME_PRIM_SOMETIMES_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
| SCHEME_PRIM_PRODUCES_FLONUM);
scheme_add_global_constant("->fl", p, env);
p = scheme_make_folding_prim(fl_to_integer, "fl->exact-integer", 1, 1, 1);

23
src/racket/src/optimize.c
View File

@ -2361,6 +2361,29 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
info->single_result = -info->single_result;
}
/* Check for things like (flonum? x) on an `x' known to have a flonum value. */
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)
&& SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)) {
int pos = SCHEME_LOCAL_POS(app->rand);
if (!optimize_is_mutated(info, pos)) {
int t;
t = optimize_is_local_type_valued(info, pos);
if (t == SCHEME_LOCAL_TYPE_FLONUM) {
if (IS_NAMED_PRIM(app->rator, "flonum?"))
return scheme_true;
} else if (t == SCHEME_LOCAL_TYPE_FIXNUM) {
if (IS_NAMED_PRIM(app->rator, "fixnum?"))
return scheme_true;
} else if (t == SCHEME_LOCAL_TYPE_EXTFLONUM) {
if (IS_NAMED_PRIM(app->rator, "extflonum?"))
return scheme_true;
}
}
}
/* Check for things like (cXr (cons X Y)): */
if (SCHEME_PRIMP(app->rator)
&& (SCHEME_PRIM_PROC_OPT_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) {