From a6ec6a7e30bed0bec50c4412eae8558df8c151e3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 11 Aug 2010 08:57:15 -0600 Subject: [PATCH] change bytecode optimizer's representation of `let' - 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" --- src/racket/src/env.c | 14 ++-- src/racket/src/eval.c | 14 ++-- src/racket/src/schpriv.h | 52 +++++++++++---- src/racket/src/syntax.c | 135 ++++++++++++++++++++++++++++----------- 4 files changed, 155 insertions(+), 60 deletions(-) diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 6c25075933..65b43a106c 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -3513,7 +3513,7 @@ Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_ while (1) { if (pos < info->new_frame) break; - pos -= info->new_frame; + pos -= info->new_frame; delta += info->original_frame; info = info->next; } @@ -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,7 +3669,9 @@ 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 propagate-call side. Chaining there also means that we @@ -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) { diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 8f1e476763..5dac45fabd 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -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,7 +4544,8 @@ 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; head2->count = head->count; @@ -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; diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 014e23c79f..c8f7e5d7e1 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -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 diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 1f388f88d0..786d3d356d 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -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]) { @@ -4153,6 +4200,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) linfo = scheme_resolve_info_extend(info, head->count - num_skips, head->count, head->count); 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 @@ -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;