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

bytecode optimizer improvement

Browse Source 
Generalize splitting of `(let-values ([(x ...) (values e ...)]) ....)'
to `(let ([x e] ...) ....)' for any `e', since it's always equivalent.
Right?

(The old requirements on the `e's seem to be needed only for
`letrec-values' splitting and maybe mutable variables.)
This commit is contained in:
Matthew Flatt 2012-08-16 15:47:20 -06:00
parent a1e855a035
commit 3150b31eb7
2 changed files with 58 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1570,6 +1570,41 @@
[b (unsafe-fx+ x x)])
(list a b)))))
(test-comp `(module m racket/base
(define (f x)
(let-values ([(a b) (values x (+ x x))])
(list a b))))
`(module m racket/base
(define (f x)
(let ([a x]
[b (+ x x)])
(list a b)))))
(test-comp `(module m racket/base
(define (f x)
(let*-values ([(a b) (values x (+ x x))])
(list a b))))
`(module m racket/base
(define (f x)
(let* ([a x]
[b (+ x x)])
(list a b)))))
(test-comp `(module m racket/base
(define (f x)
(let*-values ([(a b) (values x (+ x x))])
(set! a 5)
(/ a b))))
`(module m racket/base
(define (f x)
;; Not equivalent if a continuation capture
;; during `+' somehow exposes the shared `a'?
(let* ([a x]
[b (+ x x)])
(set! a 5)
(/ a b))))
#f)
;; check omit & reorder possibilities for unsafe
;; operations on mutable values:
(let ()

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

@ -3324,15 +3324,16 @@ Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e)
return ni;
}
static int is_values_apply(Scheme_Object *e)
static int is_values_apply(Scheme_Object *e, int n)
{
if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e;
if (n != app->num_args) return 0;
return SAME_OBJ(scheme_values_func, app->args[0]);
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) {
} else if ((n == 1) && SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)e;
return SAME_OBJ(scheme_values_func, app->rator);
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) {
} else if ((n == 2) && SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)e;
return SAME_OBJ(scheme_values_func, app->rator);
}
@ -3340,6 +3341,18 @@ static int is_values_apply(Scheme_Object *e)
return 0;
}
static int no_mutable_bindings(Scheme_Compiled_Let_Value *pre_body)
{
int i;
for (i = pre_body->count; i--; ) {
if (pre_body->flags[i] & SCHEME_WAS_SET_BANGED)
return 0;
}
return 1;
}
static void unpack_values_application(Scheme_Object *e, Scheme_Compiled_Let_Value *naya,
int rev_bind_order)
{
@ -3847,12 +3860,13 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
/* Change (let-values ([(id ...) (values e ...)]) body)
to (let-values ([id e] ...) body) for simple e. */
if ((pre_body->count != 1)
&& is_values_apply(value)
&& scheme_omittable_expr(value, pre_body->count, -1, 0, info,
(is_rec
? (pre_body->position + pre_body->count)
: -1),
0)) {
&& is_values_apply(value, pre_body->count)
&& ((!is_rec && no_mutable_bindings(pre_body))
|| scheme_omittable_expr(value, pre_body->count, -1, 0, info,
(is_rec
? (pre_body->position + pre_body->count)
: -1),
0))) {
if (!pre_body->count && !i) {
/* We want to drop the clause entirely, but doing it
here messes up the loop for letrec. So wait and