From 519d1ef8d1951f4988a3f0e3467d13d824c2fa32 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Jul 2010 12:39:23 -0600 Subject: [PATCH] make compiler slightly smarter about 0-value letrec-values bindings which corresponds to code generated from experession that are mixed with internal definitions --- collects/scribblings/guide/performance.scrbl | 9 +- src/racket/src/syntax.c | 139 +++++++++++++------ 2 files changed, 102 insertions(+), 46 deletions(-) diff --git a/collects/scribblings/guide/performance.scrbl b/collects/scribblings/guide/performance.scrbl index b2b60badbf..396a46b3c5 100644 --- a/collects/scribblings/guide/performance.scrbl +++ b/collects/scribblings/guide/performance.scrbl @@ -228,10 +228,11 @@ In the first case, the compiler likely does not know that available. This caveat about @racket[letrec] also applies to definitions of -functions and constants within modules. A definition sequence in a -module body is analogous to a sequence of @racket[letrec] bindings, -and non-constant expressions in a module body can interfere with the -optimization of references to later bindings. +functions and constants as internal definitions or in modules. A +definition sequence in a module body is analogous to a sequence of +@racket[letrec] bindings, and non-constant expressions in a module +body can interfere with the optimization of references to later +bindings. @; ---------------------------------------------------------------------- diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 725daba10d..20b318532d 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -3707,6 +3707,23 @@ static int get_convert_arg_count(Scheme_Object *lift) return 0; } +static Scheme_Object *drop_zero_value_return(Scheme_Object *expr) +{ + if (SAME_TYPE(SCHEME_TYPE(expr), scheme_sequence_type)) { + if (((Scheme_Sequence *)expr)->count == 2) { + if (SAME_TYPE(SCHEME_TYPE(((Scheme_Sequence *)expr)->array[1]), scheme_application_type)) { + if (((Scheme_App_Rec *)((Scheme_Sequence *)expr)->array[1])->num_args == 0) { + if (SAME_OBJ(scheme_values_func, ((Scheme_App_Rec *)((Scheme_Sequence *)expr)->array[1])->args[0])) { + return ((Scheme_Sequence *)expr)->array[0]; + } + } + } + } + } + + return NULL; +} + Scheme_Object * scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) { @@ -3714,7 +3731,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) Scheme_Let_Header *head = (Scheme_Let_Header *)form; Scheme_Compiled_Let_Value *clv, *pre_body; Scheme_Let_Value *lv, *last = NULL; - Scheme_Object *first = NULL, *body, *last_body = NULL; + Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL; Scheme_Letrec *letrec; mzshort *skips, skips_fast[5]; char *flonums, flonums_fast[5]; @@ -4215,49 +4232,83 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) int j; Scheme_Object *one_lifted; - expr = scheme_resolve_expr(clv->value, val_linfo); - - lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); - if (last) - last->body = (Scheme_Object *)lv; - else if (last_body) - SCHEME_CDR(last_body) = (Scheme_Object *)lv; + if (!clv->count) + expr = drop_zero_value_return(clv->value); else - first = (Scheme_Object *)lv; - last = lv; - last_body = NULL; - - lv->iso.so.type = scheme_let_value_type; - lv->value = expr; - if (clv->count) { - int li; - li = scheme_resolve_info_lookup(linfo, clv->position, NULL, NULL, 0); - lv->position = li; - } else - lv->position = 0; - lv->count = clv->count; - SCHEME_LET_AUTOBOX(lv) = recbox; + expr = NULL; - for (j = lv->count; j--; ) { - if (!recbox - && (scheme_resolve_info_flags(linfo, opos + j, &one_lifted) & SCHEME_INFO_BOXED)) { - GC_CAN_IGNORE Scheme_Object *pos; - pos = scheme_make_integer(lv->position + j); - if (SCHEME_LET_FLAGS(head) & (SCHEME_LET_STAR | SCHEME_LET_RECURSIVE)) { - /* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */ - Scheme_Object *boxenv, *pr; - pr = scheme_make_pair(pos, scheme_false); - boxenv = scheme_make_syntax_resolved(BOXENV_EXPD, pr); - if (last) - last->body = boxenv; - else - SCHEME_CDR(last_body) = boxenv; - last = NULL; - last_body = pr; - } else { - /* For regular let, delay the boxing until all RHSs are - evaluated. */ - boxes = scheme_make_pair(pos, boxes); + if (expr) { + /* changing a [() (begin expr (values))] clause, + which can be generated by internal-definition expansion, + into a `begin' */ + expr = scheme_resolve_expr(expr, val_linfo); + expr = scheme_make_sequence_compilation(scheme_make_pair(expr, + scheme_make_pair(scheme_false, + scheme_null)), + 0); + + if (last) + last->body = expr; + else if (last_body) + SCHEME_CDR(last_body) = expr; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = expr; + else + first = expr; + last = NULL; + last_body = NULL; + last_seq = expr; + } else { + expr = scheme_resolve_expr(clv->value, val_linfo); + + lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); + if (last) + last->body = (Scheme_Object *)lv; + else if (last_body) + SCHEME_CDR(last_body) = (Scheme_Object *)lv; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)lv; + else + first = (Scheme_Object *)lv; + last = lv; + last_body = NULL; + last_seq = NULL; + + lv->iso.so.type = scheme_let_value_type; + lv->value = expr; + if (clv->count) { + int li; + li = scheme_resolve_info_lookup(linfo, clv->position, NULL, NULL, 0); + lv->position = li; + } else + lv->position = 0; + lv->count = clv->count; + SCHEME_LET_AUTOBOX(lv) = recbox; + + for (j = lv->count; j--; ) { + if (!recbox + && (scheme_resolve_info_flags(linfo, opos + j, &one_lifted) & SCHEME_INFO_BOXED)) { + GC_CAN_IGNORE Scheme_Object *pos; + pos = scheme_make_integer(lv->position + j); + if (SCHEME_LET_FLAGS(head) & (SCHEME_LET_STAR | SCHEME_LET_RECURSIVE)) { + /* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */ + Scheme_Object *boxenv, *pr; + pr = scheme_make_pair(pos, scheme_false); + boxenv = scheme_make_syntax_resolved(BOXENV_EXPD, pr); + if (last) + last->body = boxenv; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = boxenv; + else + SCHEME_CDR(last_body) = boxenv; + last = NULL; + last_body = pr; + last_seq = NULL; + } else { + /* For regular let, delay the boxing until all RHSs are + evaluated. */ + boxes = scheme_make_pair(pos, boxes); + } } } } @@ -4283,12 +4334,16 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) last->body = (Scheme_Object *)letrec; else if (last_body) SCHEME_CDR(last_body) = (Scheme_Object *)letrec; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)letrec; else first = (Scheme_Object *)letrec; } else if (last) last->body = body; else if (last_body) SCHEME_CDR(last_body) = body; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)body; else first = body;