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

Improve the bytecode optimizer's ability to simplify `letrec's

Browse Source 
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.)
This commit is contained in:
Matthew Flatt 2010-07-08 12:48:33 -06:00
parent 56077a1386
commit 0eeb18f4d8
10 changed files with 448 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/tests/racket/optimize.rktl
View File

@ -919,6 +919,51 @@
'(letrec ((even (lambda (x) (if (zero? x) #t (even (sub1 x)))))) '(letrec ((even (lambda (x) (if (zero? x) #t (even (sub1 x))))))
(even 10000)))) (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) (test-comp '(procedure? add1)
#t) #t)
(test-comp '(procedure? (lambda (x) x)) (test-comp '(procedure? (lambda (x) x))

3
collects/tests/racket/syntax.rktl
View File

@ -418,6 +418,9 @@
(test 'twox 'let*-values (let*-values ([() (values)][() (values)]) 'twox)) (test 'twox 'let*-values (let*-values ([() (values)][() (values)]) 'twox))
(test 'threex 'letrec-values (letrec-values ([() (values)][() (values)]) 'threex)) (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) (test '(10 11) 'letrec-values (letrec-values ([(names kps)
(letrec ([oloop 10]) (letrec ([oloop 10])
(values oloop (add1 oloop)))]) (values oloop (add1 oloop)))])

11
doc/release-notes/racket/HISTORY.txt
View File

@ -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 Version 5.0.0.5
Added flreal-part, flimag-part, make-flrectangular, and unsafe Added flreal-part, flimag-part, make-flrectangular, and unsafe
variants variants

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

@ -166,6 +166,7 @@ typedef struct Compile_Data {
int *sealed; /* NULL => already sealed */ int *sealed; /* NULL => already sealed */
int *use; int *use;
Scheme_Object *lifts; Scheme_Object *lifts;
int min_use, any_use;
} Compile_Data; } Compile_Data;
typedef struct Scheme_Full_Comp_Env { 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++) { for (i = 0; i < c; i++) {
use[i] = 0; use[i] = 0;
} }
data->min_use = c;
} }
Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, 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); u |= (cnt << SCHEME_USE_COUNT_SHIFT);
COMPILE_DATA(frame)->use[i] = u; 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); 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; 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 *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
{ {
int *v, i; int *v, i;
@ -3259,6 +3280,9 @@ static void register_stat_dist(Optimize_Info *info, int i, int j)
} }
} }
if (i >= info->new_frame)
scheme_signal_error("internal error: bad stat-dist index");
if (info->sd_depths[i] <= j) { if (info->sd_depths[i] <= j) {
char *naya, *a; char *naya, *a;
int k; int k;
@ -4046,8 +4070,12 @@ static int resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_O
*_lifted = lifted; *_lifted = lifted;
return 0; return 0;
} else } else {
return info->new_pos[i] + offset; pos = info->new_pos[i];
if (pos < 0)
scheme_signal_error("internal error: skipped binding is used");
return pos + offset;
}
} }
} }

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

@ -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, 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 /* Checks whether the bytecode `o' returns `vals' values with no
side-effects and without pushing and using continuation marks. side-effects and without pushing and using continuation marks.
-1 for vals means that any return count is ok. -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_) if ((vtype > _scheme_compiled_values_types_)
|| ((vtype == scheme_local_type) || ((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) || ((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_unclosed_procedure_type)
|| (vtype == scheme_compiled_unclosed_procedure_type) || (vtype == scheme_compiled_unclosed_procedure_type)
|| (vtype == scheme_case_lambda_sequence_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)) { if ((vtype == scheme_branch_type)) {
Scheme_Branch_Rec *b; Scheme_Branch_Rec *b;
b = (Scheme_Branch_Rec *)o; b = (Scheme_Branch_Rec *)o;
return (scheme_omittable_expr(b->test, 1, 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) && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, warn_info, deeper_than)
&& scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info)); && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info, deeper_than));
} }
#if 0 #if 0
@ -826,15 +828,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
a let_value_type! */ a let_value_type! */
if ((vtype == scheme_let_value_type)) { if ((vtype == scheme_let_value_type)) {
Scheme_Let_Value *lv = (Scheme_Let_Value *)o; Scheme_Let_Value *lv = (Scheme_Let_Value *)o;
return (scheme_omittable_expr(lv->value, lv->count, 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)); && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, warn_info, deeper_than));
} }
#endif #endif
if ((vtype == scheme_let_one_type)) { if ((vtype == scheme_let_one_type)) {
Scheme_Let_One *lo = (Scheme_Let_One *)o; Scheme_Let_One *lo = (Scheme_Let_One *)o;
return (scheme_omittable_expr(lo->value, 1, 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)); && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, warn_info, deeper_than + 1));
} }
if ((vtype == scheme_let_void_type)) { 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; Scheme_Let_Value *lv2 = (Scheme_Let_Value *)lv->body;
if ((lv2->count == 1) if ((lv2->count == 1)
&& (lv2->position == 0) && (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; o = lv2->body;
else deeper_than += 1;
} else
o = lv->body; o = lv->body;
} else } else
o = lv->body; o = lv->body;
deeper_than += lv->count;
goto try_again; 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 ((lh->count == 1) && (lh->num_clauses == 1)) {
if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) {
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; 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; o = lv->body;
deeper_than++;
goto try_again; goto try_again;
} }
} }
@ -888,7 +894,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
&& SCHEME_INTP(app->args[4]) && SCHEME_INTP(app->args[4])
&& (SCHEME_INT_VAL(app->args[4]) >= 0) && (SCHEME_INT_VAL(app->args[4]) >= 0)
&& ((app->num_args < 5) && ((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) && ((app->num_args < 6)
|| SCHEME_NULLP(app->args[6])) || SCHEME_NULLP(app->args[6]))
&& ((app->num_args < 7) && ((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)) { if ((app->num_args == vals) || (vals < 0)) {
int i; int i;
for (i = app->num_args; 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 0;
} }
return 1; return 1;
@ -925,7 +933,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
if ((vals == 1) || (vals < 0)) { if ((vals == 1) || (vals < 0)) {
int i; int i;
for (i = app->num_args; 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 0;
} }
return 1; 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)) { || SAME_OBJ(scheme_box_proc, app->rator)) {
note_match(1, vals, warn_info); note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) { 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; 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)) { && (1 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) {
note_match(1, vals, warn_info); note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) { 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; return 1;
} }
} }
@ -979,8 +990,10 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
if (SAME_OBJ(scheme_values_func, app->rator)) { if (SAME_OBJ(scheme_values_func, app->rator)) {
note_match(2, vals, warn_info); note_match(2, vals, warn_info);
if ((vals == 2) || (vals < 0)) { if ((vals == 2) || (vals < 0)) {
if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info,
&& scheme_omittable_expr(app->rand2, 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; return 1;
} }
} }
@ -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)) { || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) {
note_match(1, vals, warn_info); note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) { if ((vals == 1) || (vals < 0)) {
if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info,
&& scheme_omittable_expr(app->rand2, 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; 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)) { && (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) {
note_match(1, vals, warn_info); note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) { if ((vals == 1) || (vals < 0)) {
if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info,
&& scheme_omittable_expr(app->rand2, 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; return 1;
} }
} }
@ -1677,7 +1694,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
total++; total++;
} else if (opt } else if (opt
&& (((opt > 0) && !last) || ((opt < 0) && !first)) && (((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. */ /* A value that is not the result. We'll drop it. */
total++; total++;
} else { } 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 /* can't optimize away a begin0 at read time; it's too late, since the
return is combined with EXPD_BEGIN0 */ return is combined with EXPD_BEGIN0 */
addconst = 1; 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 /* We can't optimize (begin0 expr cont) to expr because
exp is not in tail position in the original (so we'd mess exp is not in tail position in the original (so we'd mess
up continuation marks). */ up continuation marks). */
@ -1737,7 +1754,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
} else if (opt } else if (opt
&& (((opt > 0) && (k < total)) && (((opt > 0) && (k < total))
|| ((opt < 0) && k)) || ((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. */ /* Value not the result. Do nothing. */
} else } else
o->array[i++] = v; o->array[i++] = v;
@ -1762,7 +1779,7 @@ static Scheme_Object *look_for_letv_change(Scheme_Sequence *s)
v = s->array[i]; v = s->array[i];
if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) { if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) {
Scheme_Let_Value *lv = (Scheme_Let_Value *)v; 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 esize = s->count - (i + 1);
int nsize = i + 1; int nsize = i + 1;
Scheme_Object *nv, *ev; 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++) { for (i = 0; i < expected; i++) {
lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); 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->count = 1;
lv->position = i; lv->position = i;
@ -3294,7 +3311,7 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r
head->num_clauses = 1; head->num_clauses = 1;
lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); 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->count = 1;
lv->position = 0; lv->position = 0;
new_rand = scheme_optimize_shift(rand, 1, 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) if ((SAME_OBJ(scheme_values_func, app->rator)
|| SAME_OBJ(scheme_list_star_proc, 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))) { || single_valued_noncm_expression(app->rand, 5))) {
info->preserves_marks = 1; info->preserves_marks = 1;
info->single_result = 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 (SAME_OBJ(scheme_list_proc, app2->rator)) {
if (IS_NAMED_PRIM(app->rator, "car")) { if (IS_NAMED_PRIM(app->rator, "car")) {
/* (car (list X)) */ /* (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)) { || single_valued_noncm_expression(app2->rand, 5)) {
alt = app2->rand; alt = app2->rand;
} }
} else if (IS_NAMED_PRIM(app->rator, "cdr")) { } else if (IS_NAMED_PRIM(app->rator, "cdr")) {
/* (cdr (list X)) */ /* (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; 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_proc, app3->rator)
|| SAME_OBJ(scheme_list_star_proc, app3->rator)) { || SAME_OBJ(scheme_list_star_proc, app3->rator)) {
/* (car ({cons|list|cdr} X Y)) */ /* (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)) || 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; alt = app3->rand1;
} }
} }
} else if (IS_NAMED_PRIM(app->rator, "cdr")) { } else if (IS_NAMED_PRIM(app->rator, "cdr")) {
/* (car (cons X Y)) */ /* (car (cons X Y)) */
if (SAME_OBJ(scheme_cons_proc, app3->rator)) { 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)) || 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; alt = app3->rand2;
} }
} }
} else if (IS_NAMED_PRIM(app->rator, "cadr")) { } else if (IS_NAMED_PRIM(app->rator, "cadr")) {
if (SAME_OBJ(scheme_list_proc, app3->rator)) { if (SAME_OBJ(scheme_list_proc, app3->rator)) {
/* (cadr (list X Y)) */ /* (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)) || 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; 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 /* Inlining and constant propagation can expose
omittable expressions. */ omittable expressions. */
if ((i + 1 != count) if ((i + 1 != count)
&& scheme_omittable_expr(le, -1, -1, 0, NULL)) { && scheme_omittable_expr(le, -1, -1, 0, NULL, -1)) {
drop++; drop++;
info->size = prev_size; info->size = prev_size;
s->array[i] = NULL; s->array[i] = NULL;
@ -4216,7 +4233,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
} }
/* Try optimize: (if <omitable-expr> v v) => v */ /* Try optimize: (if <omitable-expr> 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)) { && equivalent_exprs(tb, fb)) {
info->size -= 2; /* could be more precise */ info->size -= 2; /* could be more precise */
return tb; 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)); b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context));
if (scheme_omittable_expr(k, 1, 20, 0, info) if (scheme_omittable_expr(k, 1, 20, 0, info, -1)
&& scheme_omittable_expr(v, 1, 20, 0, info) && scheme_omittable_expr(v, 1, 20, 0, info, -1)
&& scheme_omittable_expr(b, -1, 20, 0, info)) && scheme_omittable_expr(b, -1, 20, 0, info, -1))
return b; return b;
/* info->single_result is already set */ /* 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); memcpy(flags, lv->flags, sz);
lv2 = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); 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->count = lv->count;
lv2->position = lv->position; lv2->position = lv->position;
lv2->flags = flags; 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, it might not because (1) it was introduced late by inlining,
or (2) the rhs expression doesn't always produce a single or (2) the rhs expression doesn't always produce a single
value. */ value. */
if (scheme_omittable_expr(rhs, 1, -1, 1, NULL)) { if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) {
rhs = scheme_false; rhs = scheme_false;
} else if ((ip < info->max_calls[pos]) } else if ((ip < info->max_calls[pos])
&& SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) {

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

@ -5538,7 +5538,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
e = SCHEME_CDR(e); e = SCHEME_CDR(e);
n = scheme_list_length(vars); 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 (n == 1) {
if (scheme_compiled_propagate_ok(e, info)) if (scheme_compiled_propagate_ok(e, info))
@ -5615,7 +5615,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
} }
} }
} else { } 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) if (i_m + 1 == cnt)
cont = 0; 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++) { for (i_m = 0; i_m < cnt; i_m++) {
/* Optimize this expression: */ /* Optimize this expression: */
e = SCHEME_VEC_ELS(m->body)[i_m]; 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++; 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++) { for (i_m = 0; i_m < cnt; i_m++) {
/* Optimize this expression: */ /* Optimize this expression: */
e = SCHEME_VEC_ELS(m->body)[i_m]; 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; 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; Scheme_Object *prev = NULL, *next;
for (p = first; !SCHEME_NULLP(p); p = next) { for (p = first; !SCHEME_NULLP(p); p = next) {
next = SCHEME_CDR(p); 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) if (prev)
SCHEME_CDR(prev) = next; SCHEME_CDR(prev) = next;
else else

2
src/racket/src/port.c
View File

@ -7436,7 +7436,7 @@ static void unused_process_group(void *_sp, void *ignored)
# else # else
void **unused_group; void **unused_group;
unused_group = malloc(sizeof(void *) * 2); unused_group = malloc(sizeof(void *) * 2);
unused_group[0] = (void *)sp->pid; unused_group[0] = (void *)(long)sp->pid;
unused_group[1] = unused_groups; unused_group[1] = unused_groups;
need_to_check_children = 1; need_to_check_children = 1;
# endif # endif

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

@ -1055,7 +1055,7 @@ typedef struct {
} Scheme_Compilation_Top; } Scheme_Compilation_Top;
typedef struct Scheme_Compiled_Let_Value { typedef struct Scheme_Compiled_Let_Value {
Scheme_Object so; Scheme_Inclhash_Object iso; /* keyex used for set-starting */
mzshort count; mzshort count;
mzshort position; mzshort position;
int *flags; int *flags;
@ -1063,6 +1063,10 @@ typedef struct Scheme_Compiled_Let_Value {
Scheme_Object *body; Scheme_Object *body;
} Scheme_Compiled_Let_Value; } 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 { typedef struct Scheme_Let_Header {
Scheme_Inclhash_Object iso; /* keyex used for recursive */ Scheme_Inclhash_Object iso; /* keyex used for recursive */
mzshort count; 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) #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_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 */ /* flags reported by scheme_env_get_flags */
#define SCHEME_WAS_USED 0x1 #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_used_ever(Scheme_Comp_Env *env, int which);
int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, 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); int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which);

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.0.0.8" #define MZSCHEME_VERSION "5.0.0.9"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 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_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -2880,7 +2880,7 @@ int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info)
Scheme_Let_Header *lh = (Scheme_Let_Header *)value; Scheme_Let_Header *lh = (Scheme_Let_Header *)value;
if (lh->num_clauses == 1) { if (lh->num_clauses == 1) {
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; 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; value = lv->body;
info = NULL; info = NULL;
} else } else
@ -2921,12 +2921,16 @@ static int is_values_apply(Scheme_Object *e)
return 0; 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)) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e; Scheme_App_Rec *app = (Scheme_App_Rec *)e;
int i; int i;
for (i = 0; i < app->num_args; i++) { for (i = 0; i < app->num_args; i++) {
if (rev_bind_order)
naya->value = app->args[app->num_args - i];
else
naya->value = app->args[i + 1]; naya->value = app->args[i + 1];
naya = (Scheme_Compiled_Let_Value *)naya->body; naya = (Scheme_Compiled_Let_Value *)naya->body;
} }
@ -2935,9 +2939,9 @@ static void unpack_values_application(Scheme_Object *e, Scheme_Compiled_Let_Valu
naya->value = app->rand; naya->value = app->rand;
} else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) { } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; 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 = (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; clv = retry_start;
while (clones) { while (clones) {
value = retry_start->value; value = clv->value;
if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) { if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) {
data = (Scheme_Closure_Data *)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_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body;
Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start; Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start;
Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL; 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 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) { if (context & OPT_CONTEXT_BOOLEAN) {
/* Special case: (let ([x M]) (if x x N)), where x is not in N, /* 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); body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 0);
if (for_inline) { if (for_inline) {
rhs_info = scheme_optimize_info_add_frame(info, 0, head->count, 0); rhs_info = scheme_optimize_info_add_frame(info, 0, head->count, 0);
body_info->inline_fuel >>= 1; 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; rhs_info = body_info;
is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE);
body = head->body; body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) { for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body; pre_body = (Scheme_Compiled_Let_Value *)body;
pos = pre_body->position;
for (j = pre_body->count; j--; ) { for (j = pre_body->count; j--; ) {
if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) { if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) {
scheme_optimize_mutated(body_info, pos + j); 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); scheme_optimize_propagate(body_info, pos+j, rp_last, 0);
} }
} }
pos += pre_body->count;
body = pre_body->body; 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. */ at the expense of later inlining. */
body = head->body; body = head->body;
pre_body = NULL; pre_body = NULL;
pos = 0;
for (i = head->num_clauses; i--; ) { for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body; pre_body = (Scheme_Compiled_Let_Value *)body;
pos = pre_body->position;
if ((pre_body->count == 1) if ((pre_body->count == 1)
&& SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(pre_body->value)) && 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); scheme_optimize_propagate(body_info, pos, scheme_estimate_closure_size(pre_body->value), 0);
} }
pos += pre_body->count;
body = pre_body->body; body = pre_body->body;
} }
rhs_info->use_psize = 1; 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; prev_body = NULL;
body = head->body; body = head->body;
pre_body = NULL; pre_body = NULL;
retry_start = NULL; retry_start = NULL;
ready_pairs_start = NULL; ready_pairs_start = NULL;
did_set_value = 0; did_set_value = 0;
pos = 0;
for (i = head->num_clauses; i--; ) { for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body; pre_body = (Scheme_Compiled_Let_Value *)body;
pos = pre_body->position;
size_before_opt = body_info->size; 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; undiscourage = 0;
} }
if (!skip_opts) {
value = scheme_optimize_expr(pre_body->value, rhs_info, 0); value = scheme_optimize_expr(pre_body->value, rhs_info, 0);
pre_body->value = value; pre_body->value = value;
} else {
value = pre_body->value;
--skip_opts;
}
if (undiscourage) { if (undiscourage) {
rhs_info->inline_fuel = inline_fuel; 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) { if (is_rec && !not_simply_let_star) {
/* Keep track of whether we can simplify to let*: */ /* Keep track of whether we can simplify to let*: */
if (might_invoke_call_cc(value) 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; 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. */ to (let-values ([id e] ...) body) for simple e. */
if ((pre_body->count != 1) if ((pre_body->count != 1)
&& is_values_apply(value) && 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) { if (!pre_body->count && !i) {
/* We want to drop the clause entirely, but doing it /* We want to drop the clause entirely, but doing it
here messes up the loop for letrec. So wait and here messes up the loop for letrec. So wait and
@ -3238,11 +3318,18 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
Scheme_Compiled_Let_Value *naya; Scheme_Compiled_Let_Value *naya;
Scheme_Object *rest = pre_body->body; Scheme_Object *rest = pre_body->body;
int *new_flags; int *new_flags;
int cnt = pre_body->count; int cnt;
while (cnt--) { /* 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 = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
naya->so.type = scheme_compiled_let_value_type; naya->iso.so.type = scheme_compiled_let_value_type;
naya->body = rest; naya->body = rest;
naya->count = 1; naya->count = 1;
naya->position = pre_body->position + cnt; naya->position = pre_body->position + cnt;
@ -3250,10 +3337,21 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
new_flags[0] = pre_body->flags[cnt]; new_flags[0] = pre_body->flags[cnt];
naya->flags = new_flags; naya->flags = new_flags;
rest = (Scheme_Object *)naya; 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; naya = (Scheme_Compiled_Let_Value *)rest;
unpack_values_application(value, naya); unpack_values_application(value, naya, rev_bind_order);
if (prev_body) if (prev_body)
prev_body->body = (Scheme_Object *)naya; prev_body->body = (Scheme_Object *)naya;
else 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); head->num_clauses += (pre_body->count - 1);
i += (pre_body->count - 1); i += (pre_body->count - 1);
if (pre_body->count) { 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; pre_body = naya;
body = (Scheme_Object *)naya; body = (Scheme_Object *)naya;
value = pre_body->value; 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. */ that's not available yet, or that's mutable. */
int vpos; int vpos;
vpos = SCHEME_LOCAL_POS(value); vpos = SCHEME_LOCAL_POS(value);
if ((vpos < head->count) && (vpos >= pos)) if ((vpos < head->count) && !pos_EARLIER(vpos, pos))
value = NULL; value = NULL;
else { else {
/* Convert value back to a pre-optimized local coordinates. /* 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; SCHEME_CAR(rp_last) = scheme_false;
} }
/* Set-flags loop: */ /* 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, (void)set_code_flags(retry_start, pre_body, clones,
CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE,
0xFFFF, 0xFFFF,
@ -3402,7 +3503,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
char use_psize; char use_psize;
if ((clv->count == 1) if ((clv->count == 1)
&& body_info->transitive_use && rhs_info->transitive_use
&& !scheme_optimize_is_used(body_info, clv->position)) { && !scheme_optimize_is_used(body_info, clv->position)) {
body_info->transitive_use[clv->position] = NULL; body_info->transitive_use[clv->position] = NULL;
body_info->transitive_use_pos = clv->position + 1; 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: */ /* Drop old size, and remove old inline fuel: */
sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 0, NULL, NULL); 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 /* Setting letrec_not_twice prevents inlinining
of letrec bindings in this RHS. There's a small of letrec bindings in this RHS. There's a small
chance that we miss some optimizations, but we chance that we miss some optimizations, but we
avoid the possibility of N^2 behavior. */ avoid the possibility of N^2 behavior. */
if (!OPT_DISCOURAGE_EARLY_INLINE) if (!OPT_DISCOURAGE_EARLY_INLINE)
body_info->letrec_not_twice++; rhs_info->letrec_not_twice++;
use_psize = body_info->use_psize; use_psize = rhs_info->use_psize;
body_info->use_psize = 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) if (!OPT_DISCOURAGE_EARLY_INLINE)
--body_info->letrec_not_twice; --rhs_info->letrec_not_twice;
body_info->use_psize = use_psize; rhs_info->use_psize = use_psize;
clv->value = value; clv->value = value;
if (!(clv->flags[0] & SCHEME_WAS_SET_BANGED)) { 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 /* Register re-optimized as the value for the binding, but
maybe only if it didn't grow too much: */ maybe only if it didn't grow too much: */
int new_sz; int new_sz;
@ -3501,7 +3602,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
break; break;
} }
pos += pre_body->count;
prev_body = pre_body; prev_body = pre_body;
body = pre_body->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; 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)); body = scheme_optimize_expr(body, body_info, scheme_optimize_tail_context(context));
if (head->num_clauses) if (head->num_clauses)
pre_body->body = body; 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 */ /* Clear used flags where possible */
body = head->body; body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) { for (i = head->num_clauses; i--; ) {
int used = 0, j; 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; first_once_used = first_once_used->next;
} }
pre_body = (Scheme_Compiled_Let_Value *)body;
for (j = pre_body->count; j--; ) { for (j = pre_body->count; j--; ) {
if (scheme_optimize_is_used(body_info, pos+j)) { if (scheme_optimize_is_used(body_info, pos+j)) {
used = 1; used = 1;
@ -3539,7 +3644,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
} }
} }
if (!used if (!used
&& (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info) && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, -1)
|| (first_once_used || (first_once_used
&& (first_once_used->pos == pos) && (first_once_used->pos == pos)
&& first_once_used->used))) { && first_once_used->used))) {
@ -3563,7 +3668,6 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
} }
info->size += 1; info->size += 1;
} }
pos += pre_body->count;
body = pre_body->body; body = pre_body->body;
} }
@ -3573,7 +3677,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
return head->body; 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* */ /* We can simplify letrec to let* */
SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE; SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE;
SCHEME_LET_FLAGS(head) |= SCHEME_LET_STAR; 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 (!value) {
if (head->count == head->num_clauses) { if (head->count == head->num_clauses) {
body = head->body; body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) { for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body; pre_body = (Scheme_Compiled_Let_Value *)body;
if ((pre_body->count != 1) 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) static void shift_lift(Scheme_Object *lifted, int frame_size, int lifted_frame_size)
{ {
int i, cnt; int i, cnt, delta;
Scheme_Object **ca; Scheme_Object **ca;
mzshort *map; 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]); cnt = SCHEME_INT_VAL(ca[0]);
map = (mzshort *)ca[1]; map = (mzshort *)ca[1];
delta = (frame_size - lifted_frame_size);
for (i = 0; i < cnt; i++) { 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) if (is_proc)
is_lift = 0; is_lift = 0;
else if (SCHEME_CLV_FLAGS(clv) & SCHEME_CLV_NO_GROUP_USES)
is_lift = 1;
else else
is_lift = is_liftable(clv->value, head->count, 5, 1); is_lift = is_liftable(clv->value, head->count, 5, 1);
@ -3803,6 +3910,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
} else { } else {
/* Sequence of single-value, non-assigned lets? */ /* Sequence of single-value, non-assigned lets? */
int some_used = 0; int some_used = 0;
clv = (Scheme_Compiled_Let_Value *)head->body; clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
if (clv->count != 1) if (clv->count != 1)
@ -3816,7 +3924,13 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
if (i < 0) { if (i < 0) {
/* Yes - build chain of Scheme_Let_Ones and we're done: */ /* Yes - build chain of Scheme_Let_Ones and we're done: */
int skip_count = 0, frame_size, lifts_frame_size = 0; 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; j = head->num_clauses;
if (j <= 5) { if (j <= 5) {
@ -3853,7 +3967,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
/* First `i+1' bindings now exist "at runtime", except those skipped. */ /* First `i+1' bindings now exist "at runtime", except those skipped. */
/* The mapping is complicated because we now push in the order of /* 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; 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--) { for (j = i, k = 0; j >= 0; j--) {
@ -3862,10 +3976,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
converted procedure. */ converted procedure. */
shift_lift(lifted[j], frame_size, lifts_frame_size); shift_lift(lifted[j], frame_size, lifts_frame_size);
} }
n = (rev_bind_order ? (head->count - j - 1) : j);
if (skips[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 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; 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--; ) { 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]) if (skips[i])
scheme_resolve_info_add_mapping(linfo, i, ((skips[i] < 0) scheme_resolve_info_add_mapping(linfo, n, -1, flonums[i], lifted[i]);
? (k - skips[i] - 1)
: (skips[i] - 1 + frame_size)),
flonums[i], lifted[i]);
else 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); 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 and the RHSes are omittable? This can happen with auto-generated
code. */ code. */
int total = 0, j; int total = 0, j;
clv = (Scheme_Compiled_Let_Value *)head->body; clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
total += clv->count; total += clv->count;
@ -4001,7 +4116,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
} }
if (j >= 0) if (j >= 0)
break; 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; break;
} }
if (i < 0) { if (i < 0) {
@ -4047,14 +4162,15 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
requires an iteration. */ requires an iteration. */
clv = (Scheme_Compiled_Let_Value *)head->body; clv = (Scheme_Compiled_Let_Value *)head->body;
pos = ((resolve_phase < 2) ? 0 : num_rec_procs); 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) { for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
int j; int j;
opos = clv->position;
if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skipped */ /* skipped */
scheme_resolve_info_add_mapping(linfo, opos, 0, 0, NULL); scheme_resolve_info_add_mapping(linfo, opos, 0, 0, NULL);
opos++;
} else { } else {
for (j = 0; j < clv->count; j++) { for (j = 0; j < clv->count; j++) {
int p, skip; int p, skip;
@ -4103,9 +4219,10 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
int converted; int converted;
do { do {
clv = (Scheme_Compiled_Let_Value *)head->body; clv = (Scheme_Compiled_Let_Value *)head->body;
rpos = 0; opos = 0; rpos = 0;
converted = 0; converted = 0;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { 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)) { if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skipped */ /* skipped */
} else if ((clv->count == 1) } else if ((clv->count == 1)
@ -4133,7 +4250,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
} }
rpos++; rpos++;
} }
opos += clv->count;
} }
} while (converted); } while (converted);
@ -4152,8 +4268,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
actual lift offsets before resolving procedure bodies. actual lift offsets before resolving procedure bodies.
Also, we need to fix up the stub closures. */ Also, we need to fix up the stub closures. */
clv = (Scheme_Compiled_Let_Value *)head->body; 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) { 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)) { if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skipped */ /* skipped */
} else if ((clv->count == 1) && scheme_is_compiled_procedure(clv->value, 0, 0)) { } 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; lifted_recs[rpos] = lift;
rpos++; rpos++;
} }
opos += clv->count;
} }
break; /* don't need to iterate */ break; /* don't need to iterate */
@ -4204,8 +4320,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
/* Resolve values: */ /* Resolve values: */
boxes = scheme_null; boxes = scheme_null;
clv = (Scheme_Compiled_Let_Value *)head->body; 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) { 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)) { if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) {
/* skipped */ /* skipped */
} else { } else {
@ -4238,7 +4355,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
expr = NULL; expr = NULL;
if (expr) { if (expr) {
/* changing a [() (begin expr (values))] clause, /* Change a `[() (begin expr (values))]' clause,
which can be generated by internal-definition expansion, which can be generated by internal-definition expansion,
into a `begin' */ into a `begin' */
expr = scheme_resolve_expr(expr, val_linfo); 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: */ /* Resolve body: */
@ -4348,16 +4464,39 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
first = body; first = body;
if (head->count + extra_alloc - num_skips) { if (head->count + extra_alloc - num_skips) {
int cnt;
cnt = head->count + extra_alloc - num_skips;
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; Scheme_Let_Void *lvd;
lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void); lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void);
lvd->iso.so.type = scheme_let_void_type; lvd->iso.so.type = scheme_let_void_type;
lvd->body = first; lvd->body = first;
lvd->count = head->count + extra_alloc - num_skips; lvd->count = cnt;
SCHEME_LET_AUTOBOX(lvd) = recbox; SCHEME_LET_AUTOBOX(lvd) = recbox;
first = (Scheme_Object *)lvd; first = (Scheme_Object *)lvd;
} }
}
if (info->max_let_depth < linfo->max_let_depth + head->count - num_skips + extra_alloc) 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; 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; Scheme_Compiled_Let_Value *last = NULL, *lv;
DupCheckRecord r; DupCheckRecord r;
int rec_env_already = rec[drec].env_already; int rec_env_already = rec[drec].env_already;
int rev_bind_order = (1 && recursive); /* REMOVEME */
i = scheme_stx_proper_list_length(form); i = scheme_stx_proper_list_length(form);
if (i < 3) 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); 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)) if (!SCHEME_STX_PAIRP(bindings))
scheme_wrong_syntax(NULL, bindings, form, NULL); scheme_wrong_syntax(NULL, bindings, form, NULL);
binding = SCHEME_STX_CAR(bindings); 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); 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; pre_k = k;
name = SCHEME_STX_CAR(binding); 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 = 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) if (!last)
first = (Scheme_Object *)lv; first = (Scheme_Object *)lv;
else else
@ -4548,6 +4709,9 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
} }
bindings = SCHEME_STX_CDR(bindings); bindings = SCHEME_STX_CDR(bindings);
if (rev_bind_order)
k = pre_k;
} }
if (!star && !recursive) { 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); rhs = scheme_add_env_renames(rhs, env, origenv);
ce = scheme_compile_expr(rhs, env, recs, i); ce = scheme_compile_expr(rhs, env, recs, i);
lv->value = ce; 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); 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 */ /* short cut */
a = _scheme_eval_linked_expr_multi(a); a = _scheme_eval_linked_expr_multi(a);
} else { } else {
@ -6306,9 +6480,23 @@ do_letrec_syntaxes(const char *where,
cnt = (i ? var_cnt : stx_cnt); cnt = (i ? var_cnt : stx_cnt);
if (cnt > 0) { if (cnt > 0) {
/* Add new syntax/variable names to the environment: */ /* Add new syntax/variable names to the environment: */
if (i) {
/* values in reverse order across clauses, in order within a clause */
j = var_cnt;
} else
j = 0; j = 0;
for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *l; 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); a = SCHEME_STX_CAR(v);
for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { 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 } else
scheme_set_local_syntax(j++, a, NULL, stx_env); 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), MZCONFIG_EXPAND_OBSERVE),
newenv); newenv);
scheme_finish_primitive_module(newenv); scheme_finish_primitive_module(newenv);
} }
/**********************************************************************/ /**********************************************************************/