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

optimizer: fix interaction of escaping expressions and wcm

Browse Source 
The optimizer can detect that some expressions will escape through
an error, and it can discard surrounding code in that case. It should
not change the tailness of a `with-continuation-mark` form by
liftng it out of a nested position, however. Doing so can eliminate
stack frames that should be visible via errotrace, for example.
This change fixes the optimizer to wrap an extra `(begin ... (void))`
around an expression if it's lifted out of a nested context and
might have a `with-continuation-mark` form in tail position.
This commit is contained in:
Matthew Flatt 2016-12-09 08:58:40 -07:00
parent 7812c604f4
commit 9c1b870769
2 changed files with 163 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -4774,6 +4774,48 @@
(set! f 0))
#f)
;; Error simplifications must not break `with-continuation-mark`:
(let ([f (lambda ()
(with-continuation-mark
'contrast-dye 1
(begin
(with-continuation-mark
'contrast-dye 2
(+ 1 #f))
(void))))])
(set! f f)
(test '(2 1)
'contrast-dye
(with-handlers ([exn:fail? (lambda (exn)
(continuation-mark-set->list (exn-continuation-marks exn)
'contrast-dye))])
(f))))
(let ([check-escape-position
(lambda (nontail-wrap)
(test-comp `(lambda ()
(with-continuation-mark
'contrast-dye 1
,(nontail-wrap `(with-continuation-mark
'contrast-dye 2
(+ 1 #f)))))
`(lambda ()
(with-continuation-mark
'contrast-dye 1
(begin
(with-continuation-mark
'contrast-dye 2
(+ 1 #f))
(void))))))])
(check-escape-position (lambda (e)
`(+ 1 ,e)))
(check-escape-position (lambda (e)
`(let ([x ,e])
x)))
(check-escape-position (lambda (e)
`(if ,e 1 2)))
(check-escape-position (lambda (e)
`(begin0 ,e 1))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test that the `if` is not confused by the
;; predicates that recognize #f.

143
racket/src/racket/src/optimize.c
View File

@ -693,6 +693,97 @@ static Scheme_Object *ensure_single_value(Scheme_Object *e)
return (Scheme_Object *)app2;
}
static int escapes_or_noncm_function(Scheme_Object *rator)
{
if (SCHEME_PRIMP(rator)) {
int opt;
opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
if (opt >= SCHEME_PRIM_OPT_NONCM)
return 1;
if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_ALWAYS_ESCAPES)
return 1;
}
return 0;
}
/* Check whether `e` definitely has no `with-continuation-mark` form
in tail position. The conservative answer is 0. */
static int definitely_no_wcm_in_tail(Scheme_Object *e, int fuel)
{
int definitely_not_wcm = 0;
while (fuel) {
switch (SCHEME_TYPE(e)) {
case scheme_branch_type:
if (definitely_no_wcm_in_tail(((Scheme_Branch_Rec *)e)->tbranch, fuel-1)
&& definitely_no_wcm_in_tail(((Scheme_Branch_Rec *)e)->fbranch, fuel-1))
definitely_not_wcm = 1;
fuel = 0;
break;
case scheme_application_type:
if (escapes_or_noncm_function(((Scheme_App_Rec *)e)->args[0]))
definitely_not_wcm = 1;
fuel = 0;
break;
case scheme_application2_type:
if (escapes_or_noncm_function(((Scheme_App2_Rec *)e)->rator))
definitely_not_wcm = 1;
fuel = 0;
break;
case scheme_application3_type:
if (escapes_or_noncm_function(((Scheme_App3_Rec *)e)->rator))
definitely_not_wcm = 1;
fuel = 0;
break;
case scheme_ir_let_header_type:
e = ((Scheme_IR_Let_Header *)e)->body;
fuel--;
break;
case scheme_ir_let_value_type:
e = ((Scheme_IR_Let_Value *)e)->body;
fuel--;
break;
case scheme_sequence_type:
{
Scheme_Sequence *seq;
seq = (Scheme_Sequence *)e;
e = seq->array[seq->count-1];
fuel--;
}
break;
default:
if (SCHEME_TYPE(e) > _scheme_ir_values_types_)
definitely_not_wcm = 1;
fuel = 0;
break;
}
}
return definitely_not_wcm;
}
static Scheme_Object *escaping_as_non_tail(Scheme_Object *expr)
/* The expression `expr` escapes, and dscarding surrounding
expressions would lift `expr` out of a nested position. That's ok
unless `expr` has a `with-continuation-mark` form in tail position,
in which case the shift out of a nested position is observable.
Add a wrapping `(begin ... <void>)` if necessary to avoid that. */
{
Scheme_Sequence *seq;
if (!definitely_no_wcm_in_tail(expr, 5)) {
seq = scheme_malloc_sequence(2);
seq->so.type = scheme_sequence_type;
seq->count = 2;
seq->array[0] = expr;
seq->array[1] = scheme_void;
return (Scheme_Object *)seq;
} else
return expr;
}
static Scheme_Object *do_make_discarding_sequence(Scheme_Object *e1, Scheme_Object *e2,
Optimize_Info *info,
int ignored, int rev)
@ -3585,7 +3676,7 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
l = scheme_make_pair(e, l);
}
}
return scheme_make_sequence_compilation(l, 1, 0);
return escaping_as_non_tail(scheme_make_sequence_compilation(l, 1, 0));
}
if (!i) {
@ -4080,7 +4171,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
app->rator = le;
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return app->rator;
return escaping_as_non_tail(app->rator);
}
{
@ -4106,7 +4197,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
optimize_info_seq_done(info, &info_seq);
if (info->escapes) {
info->size += 1;
return make_discarding_first_sequence(app->rator, app->rand, info);
return escaping_as_non_tail(make_discarding_first_sequence(app->rator, app->rand, info));
}
if (rator_apply_escapes) {
@ -4479,7 +4570,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
app->rator = le;
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return app->rator;
return escaping_as_non_tail(app->rator);
}
{
@ -4506,7 +4597,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
app->rand1 = le;
if (info->escapes) {
info->size += 1;
return make_discarding_first_sequence(app->rator, app->rand1, info);
return escaping_as_non_tail(make_discarding_first_sequence(app->rator, app->rand1, info));
}
/* 2nd arg */
@ -4524,10 +4615,11 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
optimize_info_seq_done(info, &info_seq);
if (info->escapes) {
info->size += 1;
return make_discarding_first_sequence(app->rator,
make_discarding_first_sequence(app->rand1, app->rand2,
info),
info);
le = make_discarding_first_sequence(app->rator,
make_discarding_first_sequence(app->rand1, app->rand2,
info),
info);
return escaping_as_non_tail(le);
}
/* Check for (apply ... (list ...)) after some optimizations: */
@ -5116,8 +5208,12 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i
info->preserves_marks = preserves_marks;
info->single_result = single_result;
if (drop + 1 == s->count)
return s->array[drop];
if (drop + 1 == s->count) {
le = s->array[drop];
if (info->escapes)
le = escaping_as_non_tail(le);
return le;
}
if (drop) {
Scheme_Sequence *s2;
@ -5603,7 +5699,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return t;
return escaping_as_non_tail(t);
}
/* Try to lift out `let`s and `begin`s around a test: */
@ -5874,7 +5970,7 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return k;
return escaping_as_non_tail(k);
}
optimize_info_seq_step(info, &info_seq);
@ -5884,7 +5980,7 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
info->size += 1;
return make_discarding_first_sequence(k, v, info);
return escaping_as_non_tail(make_discarding_first_sequence(k, v, info));
}
/* The presence of a key can be detected by other expressions,
@ -5966,7 +6062,7 @@ set_optimize(Scheme_Object *data, Optimize_Info *info, int context)
val = scheme_optimize_expr(val, info, OPT_CONTEXT_SINGLED);
if (info->escapes)
return val;
return escaping_as_non_tail(val);
info->preserves_marks = 1;
info->single_result = 1;
@ -6089,7 +6185,7 @@ apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context)
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return f;
return escaping_as_non_tail(f);
}
optimize_info_seq_step(info, &info_seq);
@ -6099,7 +6195,7 @@ apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context)
if (info->escapes) {
info->size += 1;
return make_discarding_first_sequence(f, e, info);
return escaping_as_non_tail(make_discarding_first_sequence(f, e, info));
}
info->size += 1;
@ -6146,14 +6242,14 @@ with_immed_mark_optimize(Scheme_Object *data, Optimize_Info *info, int context)
optimize_info_seq_step(info, &info_seq);
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return key;
return escaping_as_non_tail(key);
}
val = scheme_optimize_expr(wcm->val, info, OPT_CONTEXT_SINGLED);
optimize_info_seq_step(info, &info_seq);
if (info->escapes) {
optimize_info_seq_done(info, &info_seq);
return make_discarding_first_sequence(key, val, info);
return escaping_as_non_tail(make_discarding_first_sequence(key, val, info));
}
optimize_info_seq_done(info, &info_seq);
@ -6324,7 +6420,7 @@ static Scheme_Object *begin0_optimize(Scheme_Object *obj, Optimize_Info *info, i
if ((count - drop) == 1) {
/* If it's only one expression we can drop the begin0 */
return s->array[i];
return escaping_as_non_tail(s->array[i]);
}
s2 = scheme_malloc_sequence(count - drop);
@ -7933,9 +8029,12 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in
body = make_discarding_sequence(pre_body->value, body, info);
} else {
/* Special case for (let ([x E]) x) and (let ([x <error>]) #f) */
found_escapes = 0; /* Perhaps the error is moved to the body. */
body = pre_body->value;
body = ensure_single_value(body);
if (found_escapes) {
found_escapes = 0; /* Perhaps the error is moved to the body. */
body = escaping_as_non_tail(body);
}
}
if (head->num_clauses == 1)
@ -7979,7 +8078,7 @@ static Scheme_Object *optimize_lets(Scheme_Object *form, Optimize_Info *info, in
seq->array[1] = (Scheme_Object *)head;
else if (found_escapes) {
/* don't need the body, because some RHS escapes */
new_body = rhs;
new_body = escaping_as_non_tail(rhs);
} else
seq->array[1] = head->body;