fix bytecode compiler safefor-space, tigher bytecode validation
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
This commit is contained in:
parent
06fe68b834
commit
7ad1ddab64
|
@ -3107,6 +3107,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)
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -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;
|
||||
|
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "5.3.4.5"
|
||||
#define MZSCHEME_VERSION "5.3.4.6"
|
||||
|
||||
#define MZSCHEME_VERSION_X 5
|
||||
#define MZSCHEME_VERSION_Y 3
|
||||
#define MZSCHEME_VERSION_Z 4
|
||||
#define MZSCHEME_VERSION_W 5
|
||||
#define MZSCHEME_VERSION_W 6
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue
Block a user