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

make compiler slightly smarter about 0-value letrec-values bindings

Browse Source 
which corresponds to code generated from experession that are
 mixed with internal definitions
This commit is contained in:
Matthew Flatt 2010-07-07 12:39:23 -06:00
parent 54216b5ced
commit 519d1ef8d1
2 changed files with 102 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/scribblings/guide/performance.scrbl
View File

@ -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.
@; ----------------------------------------------------------------------

139
src/racket/src/syntax.c
View File

@ -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;