From 0eeb18f4d8dc724a99b6d6a8affe02a1cba59113 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 8 Jul 2010 12:48:33 -0600 Subject: [PATCH] Improve the bytecode optimizer's ability to simplify `letrec's to smaller `letrec' groups or even `let*'. The goal of the change is to avoid performance surprises when using internal definitions, especially when mixing experessions with definitions. It's a somewhat scary change. Besides the new transformation, the optimizer pass's coordinate system for `letrec' (and sometimes `let*') bindings changed. No standard benchmarks were harmed during the making of this optimization. (None were improved, either.) --- collects/tests/racket/optimize.rktl | 45 ++++ collects/tests/racket/syntax.rktl | 3 + doc/release-notes/racket/HISTORY.txt | 11 + src/racket/src/env.c | 34 ++- src/racket/src/eval.c | 114 +++++---- src/racket/src/module.c | 10 +- src/racket/src/port.c | 2 +- src/racket/src/schpriv.h | 10 +- src/racket/src/schvers.h | 4 +- src/racket/src/syntax.c | 363 ++++++++++++++++++++------- 10 files changed, 448 insertions(+), 148 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 331077c376..2949efa7e8 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -919,6 +919,51 @@ '(letrec ((even (lambda (x) (if (zero? x) #t (even (sub1 x)))))) (even 10000)))) +(test-comp '(lambda (a) + (define (x) (x)) + (displayln a) + (define (y) (y)) + (list (x) (y))) + '(lambda (a) + (letrec ([x (lambda () (x))]) + (displayln a) + (letrec ([y (lambda () (y))]) + (list (x) (y)))))) + +(test-comp '(lambda (a) + (define (x) (x)) + (define (y) (y)) + (list x y)) + '(lambda (a) + (letrec ([x (lambda () (x))]) + (letrec ([y (lambda () (y))]) + (list x y))))) + +(test-comp '(lambda (a) + (define (x) (x)) + (displayln x) + (define (y) (y)) + (list x y)) + '(lambda (a) + (letrec ([x (lambda () (x))]) + (displayln x) + (letrec ([y (lambda () (y))]) + (list x y))))) + +(parameterize ([compile-context-preservation-enabled + ;; Avoid different amounts of unrolling + #t]) + (test-comp '(lambda (a) + (define (x) (y)) + (define h (+ a a)) + (define (y) (x)) + (list (x) (y) h)) + '(lambda (a) + (define h (+ a a)) + (letrec ([x (lambda () (y))] + [y (lambda () (x))]) + (list (x) (y) h))))) + (test-comp '(procedure? add1) #t) (test-comp '(procedure? (lambda (x) x)) diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index 77f216b411..a843b3c34b 100644 --- a/collects/tests/racket/syntax.rktl +++ b/collects/tests/racket/syntax.rktl @@ -418,6 +418,9 @@ (test 'twox 'let*-values (let*-values ([() (values)][() (values)]) 'twox)) (test 'threex 'letrec-values (letrec-values ([() (values)][() (values)]) 'threex)) +(letrec ([undef undef]) + (test (list 1 undef undef) 'no-split-letrec (letrec-values ([(a b c) (values 1 a b)]) (list a b c)))) + (test '(10 11) 'letrec-values (letrec-values ([(names kps) (letrec ([oloop 10]) (values oloop (add1 oloop)))]) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 65dcbe64c2..2d16da1b94 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,14 @@ +Version 5.0.0.8 +Changed internal-definition handling to allow expressions mixed + with definitions + +Version 5.0.0.7 +Added support for subprocesses as new process groups + +Version 5.0.0.6 +Added support for best-effort termination of subprocess by a + custodian + Version 5.0.0.5 Added flreal-part, flimag-part, make-flrectangular, and unsafe variants diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 43eb445b52..b1c0a8d29b 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -166,6 +166,7 @@ typedef struct Compile_Data { int *sealed; /* NULL => already sealed */ int *use; Scheme_Object *lifts; + int min_use, any_use; } Compile_Data; typedef struct Scheme_Full_Comp_Env { @@ -1500,6 +1501,8 @@ static void init_compile_data(Scheme_Comp_Env *env) for (i = 0; i < c; i++) { use[i] = 0; } + + data->min_use = c; } Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, @@ -2015,6 +2018,9 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame, u |= (cnt << SCHEME_USE_COUNT_SHIFT); COMPILE_DATA(frame)->use[i] = u; + if (i < COMPILE_DATA(frame)->min_use) + COMPILE_DATA(frame)->min_use = i; + COMPILE_DATA(frame)->any_use = 1; return (Scheme_Local *)scheme_make_local(scheme_local_type, p + i, 0); } @@ -3140,6 +3146,21 @@ Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o) return NULL; } +int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame) +{ + int any_use; + + any_use = COMPILE_DATA(frame)->any_use; + COMPILE_DATA(frame)->any_use = 0; + + return any_use; +} + +int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos) +{ + return COMPILE_DATA(frame)->min_use < pos; +} + int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count) { int *v, i; @@ -3258,7 +3279,10 @@ static void register_stat_dist(Optimize_Info *info, int i, int j) info->sd_depths[k] = 0; } } - + + if (i >= info->new_frame) + scheme_signal_error("internal error: bad stat-dist index"); + if (info->sd_depths[i] <= j) { char *naya, *a; int k; @@ -4046,8 +4070,12 @@ static int resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_O *_lifted = lifted; return 0; - } else - return info->new_pos[i] + offset; + } else { + pos = info->new_pos[i]; + if (pos < 0) + scheme_signal_error("internal error: skipped binding is used"); + return pos + offset; + } } } diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 8053e8deff..7c1809df08 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -750,7 +750,7 @@ static void note_match(int actual, int expected, Optimize_Info *warn_info) } int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, - Optimize_Info *warn_info) + Optimize_Info *warn_info, int deeper_than) /* Checks whether the bytecode `o' returns `vals' values with no side-effects and without pushing and using continuation marks. -1 for vals means that any return count is ok. @@ -768,9 +768,11 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((vtype > _scheme_compiled_values_types_) || ((vtype == scheme_local_type) - && !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ)) + && !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ) + && (SCHEME_LOCAL_POS(o) > deeper_than)) || ((vtype == scheme_local_unbox_type) - && !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ)) + && !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ) + && (SCHEME_LOCAL_POS(o) > deeper_than)) || (vtype == scheme_unclosed_procedure_type) || (vtype == scheme_compiled_unclosed_procedure_type) || (vtype == scheme_case_lambda_sequence_type) @@ -816,9 +818,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((vtype == scheme_branch_type)) { Scheme_Branch_Rec *b; b = (Scheme_Branch_Rec *)o; - return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, warn_info) - && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, warn_info) - && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info)); + return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, warn_info, deeper_than) + && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, warn_info, deeper_than) + && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info, deeper_than)); } #if 0 @@ -826,15 +828,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, a let_value_type! */ if ((vtype == scheme_let_value_type)) { Scheme_Let_Value *lv = (Scheme_Let_Value *)o; - return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, warn_info) - && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, warn_info)); + return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, warn_info, deeper_than) + && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, warn_info, deeper_than)); } #endif if ((vtype == scheme_let_one_type)) { Scheme_Let_One *lo = (Scheme_Let_One *)o; - return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, warn_info) - && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, warn_info)); + return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1) + && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, warn_info, deeper_than + 1)); } if ((vtype == scheme_let_void_type)) { @@ -844,12 +846,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, Scheme_Let_Value *lv2 = (Scheme_Let_Value *)lv->body; if ((lv2->count == 1) && (lv2->position == 0) - && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, warn_info)) + && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, warn_info, + deeper_than + 1 + lv->count)) { o = lv2->body; - else + deeper_than += 1; + } else o = lv->body; } else o = lv->body; + deeper_than += lv->count; goto try_again; } @@ -859,8 +864,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((lh->count == 1) && (lh->num_clauses == 1)) { if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, warn_info)) { + if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1)) { o = lv->body; + deeper_than++; goto try_again; } } @@ -880,7 +886,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { note_match(5, vals, warn_info); if ((vals == 5) || (vals < 0)) { - /* Look for (make-struct-type sym #f non-neg-int non-neg-int [omitable null]) */ + /* Look for (make-struct-type sym #f non-neg-int non-neg-int [omitable null]) */ if (SCHEME_SYMBOLP(app->args[1]) && SCHEME_FALSEP(app->args[2]) && SCHEME_INTP(app->args[3]) @@ -888,7 +894,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, && SCHEME_INTP(app->args[4]) && (SCHEME_INT_VAL(app->args[4]) >= 0) && ((app->num_args < 5) - || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info)) + || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? app->num_args : 0))) && ((app->num_args < 6) || SCHEME_NULLP(app->args[6])) && ((app->num_args < 7) @@ -909,7 +916,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((app->num_args == vals) || (vals < 0)) { int i; for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info)) + if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? app->num_args : 0))) return 0; } return 1; @@ -925,7 +933,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((vals == 1) || (vals < 0)) { int i; for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info)) + if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? app->num_args : 0))) return 0; } return 1; @@ -956,7 +965,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, || SAME_OBJ(scheme_box_proc, app->rator)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info)) + if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 1 : 0))) return 1; } } @@ -966,7 +976,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, && (1 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info)) + if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 1 : 0))) return 1; } } @@ -979,9 +990,11 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if (SAME_OBJ(scheme_values_func, app->rator)) { note_match(2, vals, warn_info); if ((vals == 2) || (vals < 0)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info)) - return 1; + if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0)) + && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0))) + return 1; } } /* ({void,cons,list,list*,vector,vector-immutable) ) */ @@ -994,8 +1007,10 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info)) + if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0)) + && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0))) return 1; } } @@ -1005,8 +1020,10 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, && (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info)) + if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0)) + && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0))) return 1; } } @@ -1677,7 +1694,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) total++; } else if (opt && (((opt > 0) && !last) || ((opt < 0) && !first)) - && scheme_omittable_expr(v, -1, -1, 0, NULL)) { + && scheme_omittable_expr(v, -1, -1, 0, NULL, -1)) { /* A value that is not the result. We'll drop it. */ total++; } else { @@ -1705,7 +1722,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) /* can't optimize away a begin0 at read time; it's too late, since the return is combined with EXPD_BEGIN0 */ addconst = 1; - } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL)) { + } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, -1)) { /* We can't optimize (begin0 expr cont) to expr because exp is not in tail position in the original (so we'd mess up continuation marks). */ @@ -1737,7 +1754,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) } else if (opt && (((opt > 0) && (k < total)) || ((opt < 0) && k)) - && scheme_omittable_expr(v, -1, -1, 0, NULL)) { + && scheme_omittable_expr(v, -1, -1, 0, NULL, -1)) { /* Value not the result. Do nothing. */ } else o->array[i++] = v; @@ -1762,7 +1779,7 @@ static Scheme_Object *look_for_letv_change(Scheme_Sequence *s) v = s->array[i]; if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) { Scheme_Let_Value *lv = (Scheme_Let_Value *)v; - if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL)) { + if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL, -1)) { int esize = s->count - (i + 1); int nsize = i + 1; Scheme_Object *nv, *ev; @@ -2489,7 +2506,7 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, for (i = 0; i < expected; i++) { lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - lv->so.type = scheme_compiled_let_value_type; + lv->iso.so.type = scheme_compiled_let_value_type; lv->count = 1; lv->position = i; @@ -3294,7 +3311,7 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r head->num_clauses = 1; lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - lv->so.type = scheme_compiled_let_value_type; + lv->iso.so.type = scheme_compiled_let_value_type; lv->count = 1; lv->position = 0; new_rand = scheme_optimize_shift(rand, 1, 0); @@ -3631,7 +3648,7 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz if ((SAME_OBJ(scheme_values_func, app->rator) || SAME_OBJ(scheme_list_star_proc, app->rator)) - && (scheme_omittable_expr(app->rand, 1, -1, 0, info) + && (scheme_omittable_expr(app->rand, 1, -1, 0, info, -1) || single_valued_noncm_expression(app->rand, 5))) { info->preserves_marks = 1; info->single_result = 1; @@ -3673,13 +3690,13 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz if (SAME_OBJ(scheme_list_proc, app2->rator)) { if (IS_NAMED_PRIM(app->rator, "car")) { /* (car (list X)) */ - if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL) + if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1) || single_valued_noncm_expression(app2->rand, 5)) { alt = app2->rand; } } else if (IS_NAMED_PRIM(app->rator, "cdr")) { /* (cdr (list X)) */ - if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL)) + if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1)) alt = scheme_null; } } @@ -3690,27 +3707,27 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz || SAME_OBJ(scheme_list_proc, app3->rator) || SAME_OBJ(scheme_list_star_proc, app3->rator)) { /* (car ({cons|list|cdr} X Y)) */ - if ((scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL) + if ((scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1) || single_valued_noncm_expression(app3->rand1, 5)) - && scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL)) { + && scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1)) { alt = app3->rand1; } } } else if (IS_NAMED_PRIM(app->rator, "cdr")) { /* (car (cons X Y)) */ if (SAME_OBJ(scheme_cons_proc, app3->rator)) { - if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL) + if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1) || single_valued_noncm_expression(app3->rand2, 5)) - && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL)) { + && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1)) { alt = app3->rand2; } } } else if (IS_NAMED_PRIM(app->rator, "cadr")) { if (SAME_OBJ(scheme_list_proc, app3->rator)) { /* (cadr (list X Y)) */ - if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL) + if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1) || single_valued_noncm_expression(app3->rand2, 5)) - && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL)) { + && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1)) { alt = app3->rand2; } } @@ -4055,7 +4072,7 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i /* Inlining and constant propagation can expose omittable expressions. */ if ((i + 1 != count) - && scheme_omittable_expr(le, -1, -1, 0, NULL)) { + && scheme_omittable_expr(le, -1, -1, 0, NULL, -1)) { drop++; info->size = prev_size; s->array[i] = NULL; @@ -4216,7 +4233,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int } /* Try optimize: (if v v) => v */ - if (scheme_omittable_expr(t, 1, 20, 0, NULL) + if (scheme_omittable_expr(t, 1, 20, 0, NULL, -1) && equivalent_exprs(tb, fb)) { info->size -= 2; /* could be more precise */ return tb; @@ -4265,9 +4282,9 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); - if (scheme_omittable_expr(k, 1, 20, 0, info) - && scheme_omittable_expr(v, 1, 20, 0, info) - && scheme_omittable_expr(b, -1, 20, 0, info)) + if (scheme_omittable_expr(k, 1, 20, 0, info, -1) + && scheme_omittable_expr(v, 1, 20, 0, info, -1) + && scheme_omittable_expr(b, -1, 20, 0, info, -1)) return b; /* info->single_result is already set */ @@ -4543,7 +4560,8 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I memcpy(flags, lv->flags, sz); lv2 = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - lv2->so.type = scheme_compiled_let_value_type; + SCHEME_CLV_FLAGS(lv2) |= (SCHEME_CLV_FLAGS(lv) & 0x1); + lv2->iso.so.type = scheme_compiled_let_value_type; lv2->count = lv->count; lv2->position = lv->position; lv2->flags = flags; @@ -5397,7 +5415,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) it might not because (1) it was introduced late by inlining, or (2) the rhs expression doesn't always produce a single value. */ - if (scheme_omittable_expr(rhs, 1, -1, 1, NULL)) { + if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) { rhs = scheme_false; } else if ((ip < info->max_calls[pos]) && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 9a138cd39a..577eacda46 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -5538,7 +5538,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) e = SCHEME_CDR(e); n = scheme_list_length(vars); - cont = scheme_omittable_expr(e, n, -1, 0, info); + cont = scheme_omittable_expr(e, n, -1, 0, info, -1); if (n == 1) { if (scheme_compiled_propagate_ok(e, info)) @@ -5615,7 +5615,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } } } else { - cont = scheme_omittable_expr(e, -1, -1, 0, NULL); + cont = scheme_omittable_expr(e, -1, -1, 0, NULL, -1); } if (i_m + 1 == cnt) cont = 0; @@ -5744,7 +5744,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ e = SCHEME_VEC_ELS(m->body)[i_m]; - if (scheme_omittable_expr(e, -1, -1, 0, NULL)) { + if (scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { can_omit++; } } @@ -5755,7 +5755,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ e = SCHEME_VEC_ELS(m->body)[i_m]; - if (!scheme_omittable_expr(e, -1, -1, 0, NULL)) { + if (!scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { SCHEME_VEC_ELS(vec)[j++] = e; } } @@ -7181,7 +7181,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *prev = NULL, *next; for (p = first; !SCHEME_NULLP(p); p = next) { next = SCHEME_CDR(p); - if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL)) { + if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, -1)) { if (prev) SCHEME_CDR(prev) = next; else diff --git a/src/racket/src/port.c b/src/racket/src/port.c index fff41c2306..96e24e9bea 100644 --- a/src/racket/src/port.c +++ b/src/racket/src/port.c @@ -7436,7 +7436,7 @@ static void unused_process_group(void *_sp, void *ignored) # else void **unused_group; unused_group = malloc(sizeof(void *) * 2); - unused_group[0] = (void *)sp->pid; + unused_group[0] = (void *)(long)sp->pid; unused_group[1] = unused_groups; need_to_check_children = 1; # endif diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 33387b1aa8..c005b032c5 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -1055,7 +1055,7 @@ typedef struct { } Scheme_Compilation_Top; typedef struct Scheme_Compiled_Let_Value { - Scheme_Object so; + Scheme_Inclhash_Object iso; /* keyex used for set-starting */ mzshort count; mzshort position; int *flags; @@ -1063,6 +1063,10 @@ typedef struct Scheme_Compiled_Let_Value { Scheme_Object *body; } Scheme_Compiled_Let_Value; +#define SCHEME_CLV_FLAGS(clv) MZ_OPT_HASH_KEY(&(clv)->iso) +#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; @@ -2554,6 +2558,8 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Inf #define SCHEME_SYNTAX_EXP(obj) SCHEME_PTR2_VAL(obj) int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count); +int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame); +int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos); /* flags reported by scheme_env_get_flags */ #define SCHEME_WAS_USED 0x1 @@ -2641,7 +2647,7 @@ int scheme_used_app_only(Scheme_Comp_Env *env, int which); int scheme_used_ever(Scheme_Comp_Env *env, int which); int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, - Optimize_Info *warn_info); + Optimize_Info *warn_info, int deeper_than); int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which); diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index ae0ce5b777..20a4d1513c 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.0.0.8" +#define MZSCHEME_VERSION "5.0.0.9" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 8 +#define MZSCHEME_VERSION_W 9 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 20b318532d..bddf157376 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -2880,7 +2880,7 @@ int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info) Scheme_Let_Header *lh = (Scheme_Let_Header *)value; if (lh->num_clauses == 1) { Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL)) { + if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL, -1)) { value = lv->body; info = NULL; } else @@ -2921,13 +2921,17 @@ static int is_values_apply(Scheme_Object *e) return 0; } -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) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { Scheme_App_Rec *app = (Scheme_App_Rec *)e; int i; for (i = 0; i < app->num_args; i++) { - naya->value = app->args[i + 1]; + if (rev_bind_order) + naya->value = app->args[app->num_args - i]; + else + naya->value = app->args[i + 1]; naya = (Scheme_Compiled_Let_Value *)naya->body; } } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) { @@ -2935,9 +2939,9 @@ static void unpack_values_application(Scheme_Object *e, Scheme_Compiled_Let_Valu naya->value = app->rand; } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) { Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; - naya->value = app->rand1; + naya->value = (rev_bind_order ? app->rand2 : app->rand1); naya = (Scheme_Compiled_Let_Value *)naya->body; - naya->value = app->rand2; + naya->value = (rev_bind_order ? app->rand1 : app->rand2); } } @@ -2988,8 +2992,7 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start, clv = retry_start; while (clones) { - value = retry_start->value; - + value = clv->value; if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) { data = (Scheme_Closure_Data *)value; @@ -3049,9 +3052,11 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body; Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start; Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL; - int i, j, pos, is_rec, not_simply_let_star = 0, undiscourage; + 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; + int remove_last_one = 0, inline_fuel, rev_bind_order; + +# 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, @@ -3112,19 +3117,65 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i } } + is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE); + + split_shift = 0; + if (1 && is_rec) { /* REMOVEME */ + /* Check whether we should break a prefix out into its own + letrec set. */ + body = head->body; + j = 0; + for (i = 0; i < head->num_clauses - 1; i++) { + pre_body = (Scheme_Compiled_Let_Value *)body; + if (SCHEME_CLV_FLAGS(pre_body) & SCHEME_CLV_NO_GROUP_LATER_USES) { + /* yes --- break group here */ + Scheme_Let_Header *h2; + + j += pre_body->count; + i++; + + h2 = MALLOC_ONE_TAGGED(Scheme_Let_Header); + h2->iso.so.type = scheme_compiled_let_void_type; + h2->count = head->count - j; + h2->num_clauses = head->num_clauses - i; + h2->body = pre_body->body; + SCHEME_LET_FLAGS(h2) = SCHEME_LET_RECURSIVE; + + head->count = j; + head->num_clauses = i; + + pre_body->body = (Scheme_Object *)h2; + + split_shift = h2->count; + + body = head->body; + for (j = 0; j < i; j++) { + pre_body = (Scheme_Compiled_Let_Value *)body; + pre_body->position -= split_shift; + body = pre_body->body; + } + + break; + } else { + j += pre_body->count; + body = pre_body->body; + } + } + } + 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; - } else + } else if (split_shift) + rhs_info = scheme_optimize_info_add_frame(body_info, split_shift, 0, 0); + else rhs_info = body_info; - is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE); - body = head->body; - pos = 0; for (i = head->num_clauses; i--; ) { pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; for (j = pre_body->count; j--; ) { if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) { scheme_optimize_mutated(body_info, pos + j); @@ -3140,7 +3191,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i scheme_optimize_propagate(body_info, pos+j, rp_last, 0); } } - pos += pre_body->count; body = pre_body->body; } @@ -3151,9 +3201,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i at the expense of later inlining. */ body = head->body; pre_body = NULL; - pos = 0; for (i = head->num_clauses; i--; ) { pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; if ((pre_body->count == 1) && SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(pre_body->value)) @@ -3161,22 +3211,44 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i scheme_optimize_propagate(body_info, pos, scheme_estimate_closure_size(pre_body->value), 0); } - pos += pre_body->count; body = pre_body->body; } rhs_info->use_psize = 1; } } + rev_bind_order = 0; + if (1) { /* REMOVEME */ + if (is_rec) + rev_bind_order = 1; + else if (head->num_clauses > 1) { + int pos; + body = head->body; + pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; + body = pre_body->body; + for (i = head->num_clauses - 1; i--; ) { + pre_body = (Scheme_Compiled_Let_Value *)body; + if (pre_body->position < pos) { + rev_bind_order = 1; + break; + } else if (pre_body->position > pos) { + break; + } + body = pre_body->body; + } + } + } + prev_body = NULL; body = head->body; pre_body = NULL; retry_start = NULL; ready_pairs_start = NULL; did_set_value = 0; - pos = 0; for (i = head->num_clauses; i--; ) { pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; size_before_opt = body_info->size; @@ -3207,8 +3279,13 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i undiscourage = 0; } - value = scheme_optimize_expr(pre_body->value, rhs_info, 0); - pre_body->value = value; + if (!skip_opts) { + value = scheme_optimize_expr(pre_body->value, rhs_info, 0); + pre_body->value = value; + } else { + value = pre_body->value; + --skip_opts; + } if (undiscourage) { rhs_info->inline_fuel = inline_fuel; @@ -3220,7 +3297,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i if (is_rec && !not_simply_let_star) { /* Keep track of whether we can simplify to let*: */ if (might_invoke_call_cc(value) - || scheme_optimize_any_uses(rhs_info, pos, head->count)) + || scheme_optimize_any_uses(body_info, 0, pos+pre_body->count)) not_simply_let_star = 1; } @@ -3228,7 +3305,10 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i to (let-values ([id e] ...) body) for simple e. */ if ((pre_body->count != 1) && is_values_apply(value) - && scheme_omittable_expr(value, pre_body->count, -1, 0, info)) { + && scheme_omittable_expr(value, pre_body->count, -1, 0, info, + (is_rec + ? (pre_body->position + pre_body->count) + : -1))) { if (!pre_body->count && !i) { /* We want to drop the clause entirely, but doing it here messes up the loop for letrec. So wait and @@ -3238,22 +3318,40 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i Scheme_Compiled_Let_Value *naya; Scheme_Object *rest = pre_body->body; int *new_flags; - int cnt = pre_body->count; + int cnt; - while (cnt--) { - naya = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - naya->so.type = scheme_compiled_let_value_type; - naya->body = rest; - naya->count = 1; - naya->position = pre_body->position + cnt; - new_flags = (int *)scheme_malloc_atomic(sizeof(int)); - new_flags[0] = pre_body->flags[cnt]; - naya->flags = new_flags; - rest = (Scheme_Object *)naya; + /* This conversion may reorder the expressions. */ + if (pre_body->count) { + if (rev_bind_order) + cnt = 0; + else + cnt = pre_body->count - 1; + + while (1) { + naya = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); + naya->iso.so.type = scheme_compiled_let_value_type; + naya->body = rest; + naya->count = 1; + naya->position = pre_body->position + cnt; + new_flags = (int *)scheme_malloc_atomic(sizeof(int)); + new_flags[0] = pre_body->flags[cnt]; + naya->flags = new_flags; + rest = (Scheme_Object *)naya; + + if (rev_bind_order) { + cnt++; + if (cnt >= pre_body->count) + break; + } else { + if (!cnt) + break; + cnt--; + } + } } naya = (Scheme_Compiled_Let_Value *)rest; - unpack_values_application(value, naya); + unpack_values_application(value, naya, rev_bind_order); if (prev_body) prev_body->body = (Scheme_Object *)naya; else @@ -3261,6 +3359,9 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i head->num_clauses += (pre_body->count - 1); i += (pre_body->count - 1); if (pre_body->count) { + /* We're backing up. Since the RHSs have been optimized + already, don re-optimize. */ + skip_opts = pre_body->count - 1; pre_body = naya; body = (Scheme_Object *)naya; value = pre_body->value; @@ -3313,7 +3414,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i that's not available yet, or that's mutable. */ int vpos; vpos = SCHEME_LOCAL_POS(value); - if ((vpos < head->count) && (vpos >= pos)) + if ((vpos < head->count) && !pos_EARLIER(vpos, pos)) value = NULL; else { /* Convert value back to a pre-optimized local coordinates. @@ -3381,7 +3482,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i SCHEME_CAR(rp_last) = scheme_false; } /* Set-flags loop: */ - clones = make_clones(retry_start, pre_body, body_info); + clones = make_clones(retry_start, pre_body, rhs_info); (void)set_code_flags(retry_start, pre_body, clones, CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, 0xFFFF, @@ -3402,7 +3503,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i char use_psize; if ((clv->count == 1) - && body_info->transitive_use + && rhs_info->transitive_use && !scheme_optimize_is_used(body_info, clv->position)) { body_info->transitive_use[clv->position] = NULL; body_info->transitive_use_pos = clv->position + 1; @@ -3413,27 +3514,27 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i /* Drop old size, and remove old inline fuel: */ sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 0, NULL, NULL); - body_info->size -= (sz + 1); + rhs_info->size -= (sz + 1); /* Setting letrec_not_twice prevents inlinining of letrec bindings in this RHS. There's a small chance that we miss some optimizations, but we avoid the possibility of N^2 behavior. */ if (!OPT_DISCOURAGE_EARLY_INLINE) - body_info->letrec_not_twice++; - use_psize = body_info->use_psize; - body_info->use_psize = info->use_psize; + rhs_info->letrec_not_twice++; + use_psize = rhs_info->use_psize; + rhs_info->use_psize = info->use_psize; - value = scheme_optimize_expr(self_value, body_info, 0); + value = scheme_optimize_expr(self_value, rhs_info, 0); if (!OPT_DISCOURAGE_EARLY_INLINE) - --body_info->letrec_not_twice; - body_info->use_psize = use_psize; + --rhs_info->letrec_not_twice; + rhs_info->use_psize = use_psize; clv->value = value; if (!(clv->flags[0] & SCHEME_WAS_SET_BANGED)) { - if (scheme_compiled_propagate_ok(value, body_info)) { + if (scheme_compiled_propagate_ok(value, rhs_info)) { /* Register re-optimized as the value for the binding, but maybe only if it didn't grow too much: */ int new_sz; @@ -3501,7 +3602,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i break; } - pos += pre_body->count; prev_body = pre_body; body = pre_body->body; } @@ -3511,6 +3611,10 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i body_info->vclock = rhs_info->vclock; } + if (split_shift) { + scheme_optimize_info_done(rhs_info); + } + body = scheme_optimize_expr(body, body_info, scheme_optimize_tail_context(context)); if (head->num_clauses) pre_body->body = body; @@ -3523,15 +3627,16 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i /* Clear used flags where possible */ body = head->body; - pos = 0; for (i = head->num_clauses; i--; ) { int used = 0, j; - while (first_once_used && (first_once_used->pos < pos)) { + pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; + + while (first_once_used && pos_EARLIER(first_once_used->pos, pos)) { first_once_used = first_once_used->next; } - pre_body = (Scheme_Compiled_Let_Value *)body; for (j = pre_body->count; j--; ) { if (scheme_optimize_is_used(body_info, pos+j)) { used = 1; @@ -3539,8 +3644,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i } } if (!used - && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info) - || (first_once_used + && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, -1) + || (first_once_used && (first_once_used->pos == pos) && first_once_used->used))) { for (j = pre_body->count; j--; ) { @@ -3563,7 +3668,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i } info->size += 1; } - pos += pre_body->count; body = pre_body->body; } @@ -3573,7 +3677,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i return head->body; } - if (is_rec && !not_simply_let_star) { + if (1 && is_rec && !not_simply_let_star) { /* REMOVEME */ /* We can simplify letrec to let* */ SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE; SCHEME_LET_FLAGS(head) |= SCHEME_LET_STAR; @@ -3600,7 +3704,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i if (!value) { if (head->count == head->num_clauses) { body = head->body; - pos = 0; for (i = head->num_clauses; i--; ) { pre_body = (Scheme_Compiled_Let_Value *)body; if ((pre_body->count != 1) @@ -3679,7 +3782,7 @@ static Scheme_Object *scheme_resolve_generate_stub_closure() static void shift_lift(Scheme_Object *lifted, int frame_size, int lifted_frame_size) { - int i, cnt; + int i, cnt, delta; Scheme_Object **ca; mzshort *map; @@ -3690,8 +3793,10 @@ static void shift_lift(Scheme_Object *lifted, int frame_size, int lifted_frame_s cnt = SCHEME_INT_VAL(ca[0]); map = (mzshort *)ca[1]; + delta = (frame_size - lifted_frame_size); + for (i = 0; i < cnt; i++) { - map[i] += (frame_size - lifted_frame_size); + map[i] += delta; } } @@ -3768,6 +3873,8 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) if (is_proc) is_lift = 0; + else if (SCHEME_CLV_FLAGS(clv) & SCHEME_CLV_NO_GROUP_USES) + is_lift = 1; else is_lift = is_liftable(clv->value, head->count, 5, 1); @@ -3803,6 +3910,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) } else { /* Sequence of single-value, non-assigned lets? */ int some_used = 0; + clv = (Scheme_Compiled_Let_Value *)head->body; for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { if (clv->count != 1) @@ -3816,7 +3924,13 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) if (i < 0) { /* Yes - build chain of Scheme_Let_Ones and we're done: */ int skip_count = 0, frame_size, lifts_frame_size = 0; - int j, k; + int j, k, n, rev_bind_order = 0; + + if (head->num_clauses > 1) { + clv = (Scheme_Compiled_Let_Value *)head->body; + if (clv->position > ((Scheme_Compiled_Let_Value *)clv->body)->position) + rev_bind_order = 1; + } j = head->num_clauses; if (j <= 5) { @@ -3853,19 +3967,20 @@ 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 was compiled using the inverse order. */ + 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); + 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. */ 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, j, 0, flonums[j], lifted[j]); + scheme_resolve_info_add_mapping(linfo, n, -1, flonums[j], lifted[j]); else - scheme_resolve_info_add_mapping(linfo, j, k++, flonums[j], lifted[j]); + scheme_resolve_info_add_mapping(linfo, n, k++, flonums[j], lifted[j]); } lifts_frame_size = frame_size; @@ -3929,13 +4044,12 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) } for (k = 0, i = head->count; i--; ) { + n = (rev_bind_order ? (head->count - i - 1) : i); + if ((skips[i] != 0) && (skips[i] != 1)) scheme_signal_error("trashed\n"); if (skips[i]) - scheme_resolve_info_add_mapping(linfo, i, ((skips[i] < 0) - ? (k - skips[i] - 1) - : (skips[i] - 1 + frame_size)), - flonums[i], lifted[i]); + scheme_resolve_info_add_mapping(linfo, n, -1, flonums[i], lifted[i]); else - scheme_resolve_info_add_mapping(linfo, i, k++, flonums[i], lifted[i]); + scheme_resolve_info_add_mapping(linfo, n, k++, flonums[i], lifted[i]); } body = scheme_resolve_expr(body, linfo); @@ -3992,6 +4106,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) and the RHSes are omittable? This can happen with auto-generated code. */ int total = 0, j; + clv = (Scheme_Compiled_Let_Value *)head->body; for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { total += clv->count; @@ -4001,7 +4116,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) } if (j >= 0) break; - if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL)) + if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL, -1)) break; } if (i < 0) { @@ -4047,14 +4162,15 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) requires an iteration. */ clv = (Scheme_Compiled_Let_Value *)head->body; pos = ((resolve_phase < 2) ? 0 : num_rec_procs); - rpos = 0; opos = 0; + rpos = 0; for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { int j; + opos = clv->position; + if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { /* skipped */ scheme_resolve_info_add_mapping(linfo, opos, 0, 0, NULL); - opos++; } else { for (j = 0; j < clv->count; j++) { int p, skip; @@ -4103,9 +4219,10 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) int converted; do { clv = (Scheme_Compiled_Let_Value *)head->body; - rpos = 0; opos = 0; + rpos = 0; converted = 0; for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + opos = clv->position; if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { /* skipped */ } else if ((clv->count == 1) @@ -4133,7 +4250,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) } rpos++; } - opos += clv->count; } } while (converted); @@ -4152,8 +4268,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) actual lift offsets before resolving procedure bodies. Also, we need to fix up the stub closures. */ clv = (Scheme_Compiled_Let_Value *)head->body; - rpos = 0; opos = 0; + rpos = 0; for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + opos = clv->position; if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { /* skipped */ } else if ((clv->count == 1) && scheme_is_compiled_procedure(clv->value, 0, 0)) { @@ -4175,7 +4292,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) lifted_recs[rpos] = lift; rpos++; } - opos += clv->count; } break; /* don't need to iterate */ @@ -4204,8 +4320,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) /* Resolve values: */ boxes = scheme_null; clv = (Scheme_Compiled_Let_Value *)head->body; - rpos = 0; opos = 0; + rpos = 0; for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + opos = clv->position; if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { /* skipped */ } else { @@ -4238,7 +4355,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) expr = NULL; if (expr) { - /* changing a [() (begin expr (values))] clause, + /* Change a `[() (begin expr (values))]' clause, which can be generated by internal-definition expansion, into a `begin' */ expr = scheme_resolve_expr(expr, val_linfo); @@ -4314,7 +4431,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) } } } - opos += clv->count; } /* Resolve body: */ @@ -4348,15 +4464,38 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) first = body; if (head->count + extra_alloc - num_skips) { - Scheme_Let_Void *lvd; + int cnt; - lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void); - lvd->iso.so.type = scheme_let_void_type; - lvd->body = first; - lvd->count = head->count + extra_alloc - num_skips; - SCHEME_LET_AUTOBOX(lvd) = recbox; + cnt = head->count + extra_alloc - num_skips; - first = (Scheme_Object *)lvd; + if (!recbox && (cnt == 1) + && (SAME_TYPE(SCHEME_TYPE(first), scheme_let_value_type)) + && (((Scheme_Let_Value *)first)->count == 1) + && (((Scheme_Let_Value *)first)->position == 0)) { + /* Simplify to let-one after all */ + Scheme_Let_One *lo; + int et; + + lo = MALLOC_ONE_TAGGED(Scheme_Let_One); + lo->iso.so.type = scheme_let_one_type; + lo->value = ((Scheme_Let_Value *)first)->value; + lo->body = ((Scheme_Let_Value *)first)->body; + + et = scheme_get_eval_type(lo->value); + SCHEME_LET_EVAL_TYPE(lo) = et; + + first = (Scheme_Object *)lo; + } else { + Scheme_Let_Void *lvd; + + lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void); + lvd->iso.so.type = scheme_let_void_type; + lvd->body = first; + lvd->count = cnt; + SCHEME_LET_AUTOBOX(lvd) = recbox; + + first = (Scheme_Object *)lvd; + } } if (info->max_let_depth < linfo->max_let_depth + head->count - num_skips + extra_alloc) @@ -4378,6 +4517,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, Scheme_Compiled_Let_Value *last = NULL, *lv; DupCheckRecord r; int rec_env_already = rec[drec].env_already; + int rev_bind_order = (1 && recursive); /* REMOVEME */ i = scheme_stx_proper_list_length(form); if (i < 3) @@ -4468,7 +4608,17 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, scheme_begin_dup_symbol_check(&r, env); } - for (i = 0, k = 0; i < num_clauses; i++) { + /* For `letrec', we bind the first set of identifiers at the deepest + position. That order makes it easier to peel off a prefix into a + separate `letrec'. For `let' and `let*', the first set of + identifiers is at the shallowest position. */ + + if (rev_bind_order) + k = num_bindings; + else + k = 0; + + for (i = 0; i < num_clauses; i++) { if (!SCHEME_STX_PAIRP(bindings)) scheme_wrong_syntax(NULL, bindings, form, NULL); binding = SCHEME_STX_CAR(bindings); @@ -4482,6 +4632,17 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, scheme_wrong_syntax(NULL, binding, form, NULL); } + if (rev_bind_order) { + if (multi) { + name = SCHEME_STX_CAR(binding); + while (!SCHEME_STX_NULLP(name)) { + name = SCHEME_STX_CDR(name); + k--; + } + } else + k--; + } + pre_k = k; name = SCHEME_STX_CAR(binding); @@ -4515,7 +4676,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, } lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - lv->so.type = scheme_compiled_let_value_type; + lv->iso.so.type = scheme_compiled_let_value_type; if (!last) first = (Scheme_Object *)lv; else @@ -4548,6 +4709,9 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, } bindings = SCHEME_STX_CDR(bindings); + + if (rev_bind_order) + k = pre_k; } if (!star && !recursive) { @@ -4564,6 +4728,16 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, rhs = scheme_add_env_renames(rhs, env, origenv); ce = scheme_compile_expr(rhs, env, recs, i); lv->value = ce; + + /* Record the fact that this binding doesn't use any or later + bindings in the same set. The `let' optimizer and resolver + break bindings into smaller sets based on this + information. */ + if (!scheme_env_check_reset_any_use(env) + && !might_invoke_call_cc(ce)) + SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_USES; + else if (!scheme_env_min_use_below(env, lv->position)) + SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_LATER_USES; } } @@ -6010,7 +6184,7 @@ static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_e save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase, rhs_env->genv); - if (scheme_omittable_expr(a, 1, -1, 0, NULL)) { + if (scheme_omittable_expr(a, 1, -1, 0, NULL, -1)) { /* short cut */ a = _scheme_eval_linked_expr_multi(a); } else { @@ -6306,9 +6480,23 @@ do_letrec_syntaxes(const char *where, cnt = (i ? var_cnt : stx_cnt); if (cnt > 0) { /* Add new syntax/variable names to the environment: */ - j = 0; + if (i) { + /* values in reverse order across clauses, in order within a clause */ + j = var_cnt; + } else + j = 0; for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { Scheme_Object *a, *l; + int pre_j; + + if (i) { + a = SCHEME_STX_CAR(v); + for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + j--; + } + pre_j = j; + } else + pre_j = 0; a = SCHEME_STX_CAR(v); for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { @@ -6320,6 +6508,8 @@ do_letrec_syntaxes(const char *where, } else scheme_set_local_syntax(j++, a, NULL, stx_env); } + + if (i) j = pre_j; } } } @@ -6748,7 +6938,6 @@ void scheme_init_expand_observe(Scheme_Env *env) MZCONFIG_EXPAND_OBSERVE), newenv); scheme_finish_primitive_module(newenv); - } /**********************************************************************/