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

fix bytecode compiler safefor-space, tigher bytecode validation

Browse Source 
The safe-for-space pass could add clearing operations on "typed"
stack positions, which are known to contain a fixnum, flonum, or
extflonum. Non-clearing references, however, were not annotated to
indicate that clearing references were present, since clearing is
not expected on typed positions.

Along the lines of not expecting clearing, the bytecode validator's
encoding of the stack doesn't accomodate both "has a type" and "claims
never to be cleared", so it couldn't detect the bytecode compiler
bug. (Also, this problem didn't show up in the HOSC paper's model of
the validator, because the model pre-dates type tracking.)

Fix the bytecode compiler's space-safety pass so that it never inserts
clearing operations for typed stack positions. Then, the validator can
simply reject any attempt to clear a typed position.

Also, annotate applications generated by lifting as safe-for-space
tail calls.

Merge to v5.3.4
(cherry picked from commit 7ad1ddab64)

Conflicts:
	src/racket/src/cstartup.inc
	src/racket/src/schvers.h
This commit is contained in:
Matthew Flatt 2013-04-26 18:45:47 -06:00 committed by Ryan Culpepper
parent 621abb6031
commit 4b9dfabcb3
4 changed files with 74 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3081,6 +3081,23 @@
(test 2 (f b (lambda () 2))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure an already-in-place loop argument
;; isn't cleared for space safety:
(test '((1 2 3 4 5 6)
(- 4 6 8 10 12)
(- - 9 12 15 18)
(- - - 16 20 24)
(- - - - 25 30)
(- - - - - 36))
values
(for/list ([y (in-range 1 7)])
;; `y' is the already in place argument for the
;; following loop:
(for/list ([x (in-range 1 7)])
(if (<= y x) (* x y) '-))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

4
src/racket/src/resolve.c
View File

@ -201,6 +201,7 @@ static Scheme_Object *resolve_application(Scheme_Object *o, Resolve_Info *orig_i
n += m;
app = app2;
already_resolved_arg_count = m + 1 + rdelta;
SCHEME_APPN_FLAGS(app) |= APPN_FLAG_SFS_TAIL;
}
}
@ -285,6 +286,7 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_
}
app2->args[0] = rator;
app2->args[m+1] = app->rand;
SCHEME_APPN_FLAGS(app2) |= APPN_FLAG_SFS_TAIL;
return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta);
} else {
Scheme_App3_Rec *app2;
@ -299,6 +301,7 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_
loc = SCHEME_VEC_ELS(loc)[0];
app2->rand1 = loc;
app2->rand2 = app->rand;
SCHEME_APPN_FLAGS(app2) |= APPN_FLAG_SFS_TAIL;
return resolve_application3((Scheme_Object *)app2, orig_info, 2 + rdelta);
}
}
@ -404,6 +407,7 @@ static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_
app2->args[0] = rator;
app2->args[m+1] = app->rand1;
app2->args[m+2] = app->rand2;
SCHEME_APPN_FLAGS(app2) |= APPN_FLAG_SFS_TAIL;
return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta);
} else {
app->rator = rator;

56
src/racket/src/sfs.c
View File

@ -35,6 +35,8 @@
static void register_traversers(void);
#endif
#define FAR_VALUE_FOR_MAX_USED 0x3FFFFFFe
void scheme_init_sfs()
{
#ifdef MZ_PRECISE_GC
@ -172,6 +174,11 @@ void scheme_sfs_used(SFS_Info *info, int pos)
scheme_signal_error("internal error: misuse of toplevel pointer");
SFS_LOG(printf("touch %d %d\n", pos, info->ip));
if (info->max_used[pos] >= FAR_VALUE_FOR_MAX_USED) {
info->max_used[pos] = (FAR_VALUE_FOR_MAX_USED + 1);
return;
}
if ((info->min_touch == -1)
|| (pos < info->min_touch))
@ -230,17 +237,16 @@ static void sfs_note_app(SFS_Info *info, Scheme_Object *rator, int flags)
} else {
int tail_ok = (flags & APPN_FLAG_SFS_TAIL);
if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) {
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) {
if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) {
/* No point in clearing out any of the closure before the
tail call. */
int i;
for (i = info->selflen; i--; ) {
if ((info->selfstart + i) != info->tlpos)
scheme_sfs_used(info, (info->selfstart - info->stackpos) + i);
}
tail_ok = 1;
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)
&& (SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) {
/* No point in clearing out any of the closure before the
tail call. */
int i;
for (i = info->selflen; i--; ) {
if ((info->selfstart + i) != info->tlpos)
scheme_sfs_used(info, (info->selfstart - info->stackpos) + i);
}
tail_ok = 1;
}
}
if (!tail_ok)
@ -498,7 +504,7 @@ static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip,
n = info->max_used[i + t_min_t];
SFS_LOG(printf("%d %s %d %d -> %d/%d\n", info->pass, (delta ? "else" : "then"), ip,
i + t_min_t, n, info->max_calls[i+ t_min_t]));
if (n > ip) {
if ((n > ip) && (n < FAR_VALUE_FOR_MAX_USED)) {
SCHEME_VEC_ELS(t_vec)[i] = scheme_make_integer(n);
info->max_used[i + t_min_t] = ip;
} else {
@ -641,6 +647,10 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
save_mnt = info->max_nontail;
if (!info->pass) {
if (SCHEME_LET_ONE_TYPE(lo)) {
/* never clear a typed slot */
info->max_used[pos] = FAR_VALUE_FOR_MAX_USED;
}
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
@ -659,7 +669,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
@ -671,7 +681,8 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
} else {
info->max_nontail = save_mnt;
if (info->max_used[pos] <= ip) {
if ((info->max_used[pos] <= ip)
|| (info->max_used[pos] == FAR_VALUE_FOR_MAX_USED)) {
/* No one is using it, so don't actually push the value at run time
(but keep the check that the result is single-valued).
The optimizer normally would have converted away the binding, but
@ -1080,6 +1091,25 @@ static Scheme_Object *sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_
}
}
/* Never clear typed arguments or typed closure elements: */
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
int delta, size, ct, j, pos;
mzshort *map;
delta = data->closure_size;
size = data->closure_size + data->num_params;
map = data->closure_map;
for (j = 0; j < size; j++) {
ct = scheme_boxmap_get(map, j, delta);
if (ct > CLOS_TYPE_TYPE_OFFSET) {
if (j < data->num_params)
pos = info->stackpos + delta + j;
else
pos = info->stackpos + (j - data->num_params);
info->max_used[pos] = FAR_VALUE_FOR_MAX_USED;
}
}
}
code = scheme_sfs(data->code, info, data->max_let_depth);
/* If any arguments go unused, and if there's a non-tail,

15
src/racket/src/validate.c
View File

@ -1457,7 +1457,9 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
}
if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_CLEAR_ON_READ) {
if ((stack[p] == VALID_VAL_NOCLEAR) || (stack[p] == VALID_BOX_NOCLEAR))
if ((stack[p] == VALID_VAL_NOCLEAR)
|| (stack[p] == VALID_BOX_NOCLEAR)
|| (stack[p] >= VALID_TYPED))
scheme_ill_formed_code(port);
if (p >= letlimit)
clearing_stack_push(vc, p, stack[p]);
@ -2003,12 +2005,15 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
NULL, 0, 0, vc, 0, 0, procs, 1, NULL);
}
} else if (need_local_type) {
if (!SCHEME_FLOATP(expr)
if (SCHEME_DBLP(expr) && (need_local_type == SCHEME_LOCAL_TYPE_FLONUM))
need_local_type = 0;
#ifdef MZ_LONG_DOUBLE
&& !SCHEME_LONG_DBLP(expr)
if (SCHEME_LONG_DBLP(expr) && (need_local_type == SCHEME_LOCAL_TYPE_EXTFLONUM))
need_local_type = 0;
#endif
)
no_typed(need_local_type, port);
if (SCHEME_INTP(expr) && (need_local_type == SCHEME_LOCAL_TYPE_FIXNUM))
need_local_type = 0;
no_typed(need_local_type, port);
}
break;
}