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

change bytecode optimizer's representation of `let'

Browse Source 
- represent RHSes as before allocating stack positions
   for bindings, instead of after, which makes certain
   transformations simpler; this does not effect the
   final bytecode form that's is saved in a ".zo"
This commit is contained in:
Matthew Flatt 2010-08-11 08:57:15 -06:00
parent 2f9431552e
commit a6ec6a7e30
4 changed files with 155 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/racket/src/env.c
View File

@ -3626,6 +3626,8 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
n = SCHEME_VEC_ELS(p)[1];
if (SCHEME_INT_VAL(n) == pos) {
n = SCHEME_VEC_ELS(p)[2];
if (info->flags & SCHEME_POST_BIND_FRAME)
delta += info->new_frame;
if (SCHEME_RPAIRP(n)) {
/* This was a letrec-bound identifier that may or may not be ready,
but which wasn't replaced with more information. */
@ -3644,9 +3646,8 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_unclosed_procedure_type)) {
if (!closure_offset)
break;
else {
*closure_offset = delta;
}
else
*closure_offset = delta;
} else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) {
/* Ok */
} else if (closure_offset) {
@ -3668,6 +3669,8 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
pos = SCHEME_LOCAL_POS(n);
if (info->flags & SCHEME_LAMBDA_FRAME)
j--; /* because it will get re-added on recur */
else if (info->flags & SCHEME_POST_BIND_FRAME)
info = info->next; /* bindings are relative to next frame */
/* Marks local as used; we don't expect to get back
a value, because chaining would normally happen on the
@ -3677,6 +3680,7 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
if (!*single_use)
single_use = NULL;
}
n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL, 0, context, potential_size);
if (!n) {

12
src/racket/src/eval.c
View File

@ -2671,7 +2671,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
if (nested_count) {
sub_info = scheme_optimize_info_add_frame(info, nested_count, nested_count, 0);
sub_info->vclock++;
/* We could propagate bound values in sub_info , but relevant inlining
/* We could propagate bound values in sub_info, but relevant inlining
and propagatation has probably already happened when the rator was
optimized. */
} else
@ -3316,8 +3316,7 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r
lv->iso.so.type = scheme_compiled_let_value_type;
lv->count = 1;
lv->position = 0;
new_rand = scheme_optimize_shift(rand, 1, 0);
lv->value = new_rand;
lv->value = rand;
flags = (int *)scheme_malloc_atomic(sizeof(int));
flags[0] = (SCHEME_WAS_USED | (1 << SCHEME_USE_COUNT_SHIFT));
@ -4545,6 +4544,7 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I
Scheme_Object *body;
Scheme_Compiled_Let_Value *lv, *lv2, *prev = NULL;
int i, *flags, sz;
int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
head2 = MALLOC_ONE_TAGGED(Scheme_Let_Header);
head2->iso.so.type = scheme_compiled_let_void_type;
@ -4568,7 +4568,8 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I
lv2->position = lv->position;
lv2->flags = flags;
expr = scheme_optimize_clone(dup_ok, lv->value, info, delta, closure_depth + head->count);
expr = scheme_optimize_clone(dup_ok, lv->value, info, delta,
closure_depth + (post_bind ? 0 : head->count));
if (!expr) return NULL;
lv2->value = expr;
@ -4747,13 +4748,14 @@ Scheme_Object *scheme_optimize_shift(Scheme_Object *expr, int delta, int after_d
Scheme_Object *body;
Scheme_Compiled_Let_Value *lv = NULL;
int i;
int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
/* Build let-value change: */
body = head->body;
for (i = head->num_clauses; i--; ) {
lv = (Scheme_Compiled_Let_Value *)body;
expr = scheme_optimize_shift(lv->value, delta, after_depth + head->count);
expr = scheme_optimize_shift(lv->value, delta, after_depth + (post_bind ? 0 : head->count));
lv->value = expr;
body = lv->body;

52
src/racket/src/schpriv.h
View File

@ -1073,6 +1073,46 @@ typedef struct {
struct Resolve_Prefix *prefix;
} Scheme_Compilation_Top;
/* A `let', `let*', or `letrec' form is compiled to the intermediate
format (used during the optimization pass) as a Scheme_Let_Header
with a chain of Scheme_Compiled_Let_Value records as its body,
where there's one Scheme_Compiled_Let_Value for each binding
clause. A `let*' is normally expanded to nested `let's before
compilation, but the intermediate format also supposrts `let*',
which is useful mostly for converting a simple enough `letrec' form
into `let*.
The body of the `let...' form is the body of the innermost
Scheme_Compiled_Let_Value record. Obviously, all N bindings of a
`let...' form are pushed onto the virtual stack for the body, but
the situation is more complex for the binding right-hand
sides. There are three cases:
* Plain `let': no bindings are pushed, yet. (This is in contrast
to the convention for the final bytecode format, where space for
the binding is allocated before the right-hand side is
evaluated.)
* `letrec': all bindings are pushed; the first clause is pushed
first, etc.
* `let*' can be like `letrec', but also can have the bindings in
reverse order; that is, all bindings are pushed before any
right-hand side, but the last binding may be pushed first
instead of last.
*/
typedef struct Scheme_Let_Header {
Scheme_Inclhash_Object iso; /* keyex used for recursive */
mzshort count; /* total number of bindings */
mzshort num_clauses; /* number of binding clauses */
Scheme_Object *body;
} Scheme_Let_Header;
#define SCHEME_LET_FLAGS(lh) MZ_OPT_HASH_KEY(&lh->iso)
#define SCHEME_LET_RECURSIVE 0x1
#define SCHEME_LET_STAR 0x2
typedef struct Scheme_Compiled_Let_Value {
Scheme_Inclhash_Object iso; /* keyex used for set-starting */
mzshort count;
@ -1086,17 +1126,6 @@ typedef struct Scheme_Compiled_Let_Value {
#define SCHEME_CLV_NO_GROUP_LATER_USES 0x1
#define SCHEME_CLV_NO_GROUP_USES 0x2
typedef struct Scheme_Let_Header {
Scheme_Inclhash_Object iso; /* keyex used for recursive */
mzshort count;
mzshort num_clauses;
Scheme_Object *body;
} Scheme_Let_Header;
#define SCHEME_LET_FLAGS(lh) MZ_OPT_HASH_KEY(&lh->iso)
#define SCHEME_LET_RECURSIVE 0x1
#define SCHEME_LET_STAR 0x2
typedef struct {
Scheme_Object so;
Scheme_Object *key;
@ -2613,6 +2642,7 @@ int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos);
#define SCHEME_FOR_INTDEF 256
#define SCHEME_CAPTURE_LIFTED 512
#define SCHEME_INTDEF_SHADOW 1024
#define SCHEME_POST_BIND_FRAME 2048
/* Flags used with scheme_static_distance */
#define SCHEME_ELIM_CONST 1

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

@ -3055,12 +3055,13 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
int i, j, pos, is_rec, not_simply_let_star = 0, undiscourage, split_shift, skip_opts = 0;
int size_before_opt, did_set_value;
int remove_last_one = 0, inline_fuel, rev_bind_order;
int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
# define pos_EARLIER(a, b) (rev_bind_order ? ((a) > (b)) : ((a) < (b)))
if (context & OPT_CONTEXT_BOOLEAN) {
/* Special case: (let ([x M]) (if x x N)), where x is not in N,
to (if M #t #f), since we're in a test position. */
to (if M #t N), since we're in a test position. */
if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) {
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type)
@ -3077,16 +3078,28 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
b3->so.type = scheme_branch_type;
b3->test = clv->value;
b3->tbranch = scheme_true;
b3->fbranch = b->fbranch;
if (post_bind) {
/* still need a `let' around N: */
b3->fbranch = (Scheme_Object *)head;
clv->value = scheme_false;
clv->flags[0] = 0; /* variable now unused */
clv->body = b->fbranch;
} else {
b3->fbranch = b->fbranch;
}
sub_info = scheme_optimize_info_add_frame(info, 1, 0, 0);
if (post_bind)
sub_info = info;
else
sub_info = scheme_optimize_info_add_frame(info, 1, 0, 0);
form = scheme_optimize_expr((Scheme_Object *)b3, sub_info, context);
info->single_result = sub_info->single_result;
info->preserves_marks = sub_info->preserves_marks;
scheme_optimize_info_done(sub_info);
if (!post_bind) {
info->single_result = sub_info->single_result;
info->preserves_marks = sub_info->preserves_marks;
scheme_optimize_info_done(sub_info);
}
return form;
}
@ -3102,8 +3115,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
&& (((Scheme_Local *)clv->body)->position == 0)) {
if (worth_lifting(clv->value)) {
if (for_inline) {
/* Just drop the inline-introduced let */
if (post_bind) {
/* Just drop the let */
return scheme_optimize_expr(clv->value, info, context);
} else {
info = scheme_optimize_info_add_frame(info, 1, 0, 0);
@ -3119,6 +3132,29 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE);
#if 0
if (!is_rec) {
/* (let ([x (let ([y M]) N)]) P) => (let ([y M]) (let ([x N]) P)) */
if (head->count == 1) {
clv = (Scheme_Compiled_Let_Value *)head->body; /* ([x ...]) */
if (SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_let_void_type)) {
Scheme_Let_Header *lh = (Scheme_Let_Header *)clv->value; /* (let ([y ...]) ...) */
if (!(SCHEME_LET_FLAGS(lh) & SCHEME_LET_RECURSIVE)
&& (lh->count == 1)) {
value = ((Scheme_Compiled_Let_Value *)lh->body)->body; /* = N */
((Scheme_Compiled_Let_Value *)lh->body)->body = (Scheme_Object *)head;
clv->value = value;
head = lh;
form = (Scheme_Obejct *)head;
orig_info = info;
info = scheme_optimize_info_add_frame(info, 1, 0, 0);
}
}
}
}
#endif
split_shift = 0;
if (is_rec) {
/* Check whether we should break a prefix out into its own
@ -3163,10 +3199,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
}
}
body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 0);
if (for_inline) {
rhs_info = scheme_optimize_info_add_frame(info, 0, head->count, 0);
body_info->inline_fuel >>= 1;
body_info = scheme_optimize_info_add_frame(info, head->count, head->count,
post_bind ? SCHEME_POST_BIND_FRAME : 0);
if (post_bind) {
rhs_info = scheme_optimize_info_add_frame(info, 0, 0, 0);
if (for_inline)
body_info->inline_fuel >>= 1;
} else if (split_shift)
rhs_info = scheme_optimize_info_add_frame(body_info, split_shift, 0, 0);
else
@ -3416,9 +3454,10 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
value = NULL;
else {
/* Convert value back to a pre-optimized local coordinates.
This must be done with respect to body_info, not
rhs_info, because we attach the value to body_info: */
value = scheme_optimize_reverse(body_info, vpos, 1);
Unless post_bind, this must be done with respect to
body_info, not rhs_info, because we attach the value to
body_info: */
value = scheme_optimize_reverse(post_bind ? rhs_info : body_info, vpos, 1);
/* Double-check that the value is ready, because we might be
nested in the RHS of a `letrec': */
@ -3449,7 +3488,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
if (cnt == 1) {
/* used only once; we may be able to shift the expression to the use
site, instead of binding to a temporary */
last_once_used = scheme_make_once_used(value, pos, body_info->vclock, last_once_used);
last_once_used = scheme_make_once_used(value, pos, rhs_info->vclock, last_once_used);
if (!first_once_used) first_once_used = last_once_used;
scheme_optimize_propagate(body_info, pos, (Scheme_Object *)last_once_used, 1);
}
@ -3604,7 +3643,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
body = pre_body->body;
}
if (for_inline) {
if (post_bind) {
body_info->size = rhs_info->size;
body_info->vclock = rhs_info->vclock;
}
@ -3715,6 +3754,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
value = body;
extract_depth = head->count;
rhs_info = body_info;
post_bind = 0;
}
}
}
@ -3724,7 +3764,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
value = scheme_optimize_clone(1, value, rhs_info, 0, 0);
if (value) {
sub_info = scheme_optimize_info_add_frame(info, extract_depth, 0, 0);
sub_info = scheme_optimize_info_add_frame(info, post_bind ? 0 : extract_depth, 0, 0);
sub_info->inline_fuel = 0;
value = scheme_optimize_expr(value, sub_info, context);
info->single_result = sub_info->single_result;
@ -3830,7 +3870,7 @@ static Scheme_Object *drop_zero_value_return(Scheme_Object *expr)
Scheme_Object *
scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
{
Resolve_Info *linfo, *val_linfo;
Resolve_Info *linfo, *val_linfo = NULL;
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body;
Scheme_Let_Value *lv, *last = NULL;
@ -3844,6 +3884,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
int max_let_depth = 0;
int resolve_phase, num_skips;
Scheme_Object **lifted_recs;
int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR));
/* Find body: */
body = head->body;
@ -3966,20 +4007,26 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
/* First `i+1' bindings now exist "at runtime", except those skipped. */
/* The mapping is complicated because we now push in the order of
the variables, but it may have been compiled using the inverse order. */
frame_size = i + 1 - skip_count;
linfo = scheme_resolve_info_extend(info, frame_size, head->count, i + 1);
for (j = i, k = 0; j >= 0; j--) {
if (lifts_frame_size != frame_size) {
/* We need to shift coordinates for any lifted[j] that is a
converted procedure. */
frame_size = i + 1 - skip_count;
if (lifts_frame_size != frame_size) {
/* We need to shift coordinates for any lifted[j] that is a
converted procedure. */
for (j = i, k = 0; j >= 0; j--) {
shift_lift(lifted[j], frame_size, lifts_frame_size);
}
n = (rev_bind_order ? (head->count - j - 1) : j);
if (skips[j])
scheme_resolve_info_add_mapping(linfo, n, -1, flonums[j], lifted[j]);
else
scheme_resolve_info_add_mapping(linfo, n, k++, flonums[j], lifted[j]);
}
}
if (post_bind) {
linfo = scheme_resolve_info_extend(info, frame_size, 0, 0);
} else {
linfo = scheme_resolve_info_extend(info, frame_size, head->count, i + 1);
for (j = i, k = 0; j >= 0; j--) {
n = (rev_bind_order ? (head->count - j - 1) : j);
if (skips[j])
scheme_resolve_info_add_mapping(linfo, n, -1, flonums[j], lifted[j]);
else
scheme_resolve_info_add_mapping(linfo, n, k++, flonums[j], lifted[j]);
}
}
lifts_frame_size = frame_size;
if (skips[i]) {
@ -4154,6 +4201,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
lifted_recs = NULL;
}
if (post_bind)
val_linfo = scheme_resolve_info_extend(info, head->count - num_skips, 0, 0);
else
val_linfo = linfo;
/* Build mapping of compile-time indices to run-time indices, shuffling
letrecs to fall together in the shallowest part. Also determine
and initialize lifts for recursive procedures. Generating lift information
@ -4231,7 +4283,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
old_lift = lifted_recs[rpos];
old_convert_count = get_convert_arg_count(old_lift);
lift = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 1,
lift = scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 1,
(resolve_phase ? NULL : old_lift));
if (is_closed_reference(lift)
@ -4275,7 +4327,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
Scheme_Object *lift;
lift = lifted_recs[rpos];
if (is_closed_reference(lift)) {
(void)scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 0, lift);
(void)scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lift);
/* lift is the final result; this result might be
referenced in the body of closures already, or in
not-yet-closed functions. If no one uses the result
@ -4283,7 +4335,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
GCed. */
clv->value = NULL; /* inidicates that there's nothing more to do with the expr */
} else {
lift = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 2, NULL);
lift = scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 2, NULL);
/* need to resolve one more time for the body of the lifted function */
}
scheme_resolve_info_adjust_mapping(linfo, opos, rpos, 0, lift);
@ -4298,7 +4350,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
}
extra_alloc = 0;
val_linfo = linfo;
if (num_rec_procs) {
if (!lifted_recs) {
@ -4498,6 +4549,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
if (info->max_let_depth < linfo->max_let_depth + head->count - num_skips + extra_alloc)
info->max_let_depth = linfo->max_let_depth + head->count - num_skips + extra_alloc;
if (val_linfo)
if (info->max_let_depth < val_linfo->max_let_depth + head->count - num_skips + extra_alloc)
info->max_let_depth = val_linfo->max_let_depth + head->count - num_skips + extra_alloc;
return first;
}
@ -4509,13 +4563,14 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
{
Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname;
int num_clauses, num_bindings, i, j, k, m, pre_k;
Scheme_Comp_Env *frame, *env;
Scheme_Comp_Env *frame, *env, *rhs_env;
Scheme_Compile_Info *recs;
Scheme_Object *first = NULL;
Scheme_Compiled_Let_Value *last = NULL, *lv;
DupCheckRecord r;
int rec_env_already = rec[drec].env_already;
int rev_bind_order = recursive;
int post_bind = !recursive && !star;
i = scheme_stx_proper_list_length(form);
if (i < 3)
@ -4593,6 +4648,10 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
frame_already = frame;
}
env = frame;
if (post_bind)
rhs_env = scheme_no_defines(origenv);
else
rhs_env = env;
recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1));
@ -4691,7 +4750,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
rhs = SCHEME_STX_CDR(binding);
rhs = SCHEME_STX_CAR(rhs);
rhs = scheme_add_env_renames(rhs, env, origenv);
ce = scheme_compile_expr(rhs, env, recs, i);
ce = scheme_compile_expr(rhs, rhs_env, recs, i);
lv->value = ce;
} else {
Scheme_Object *rhs;