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))))))
(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))

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

@ -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)))])

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

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

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

114
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,
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) <omittable> <omittable>) */
@ -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 <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)) {
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)) {

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

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

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

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

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

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

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

363
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;
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);
}
/**********************************************************************/