bytecode optimizer improvement

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

View File

@ -1570,6 +1570,41 @@
[b (unsafe-fx+ x x)]) [b (unsafe-fx+ x x)])
(list a b))))) (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 ;; check omit & reorder possibilities for unsafe
;; operations on mutable values: ;; operations on mutable values:
(let () (let ()

View File

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