From 4b9dfabcb38efe1cd6eb8800e1a13f907df014a8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Apr 2013 18:45:47 -0600 Subject: [PATCH] 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 (cherry picked from commit 7ad1ddab64afbb58f02d8d1b28b55c05d015aea0) Conflicts: src/racket/src/cstartup.inc src/racket/src/schvers.h --- collects/tests/racket/optimize.rktl | 17 +++++++++ src/racket/src/resolve.c | 4 +++ src/racket/src/sfs.c | 56 ++++++++++++++++++++++------- src/racket/src/validate.c | 15 +++++--- 4 files changed, 74 insertions(+), 18 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 68a4d11ff3..828e82c41d 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -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) diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c index 58d38e3a05..0ac13be2d2 100644 --- a/src/racket/src/resolve.c +++ b/src/racket/src/resolve.c @@ -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; diff --git a/src/racket/src/sfs.c b/src/racket/src/sfs.c index 2ae594c3a6..154c02f104 100644 --- a/src/racket/src/sfs.c +++ b/src/racket/src/sfs.c @@ -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, diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index 07d897fc72..efd6cc50a8 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -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; }