From e49956e3ea85d3e6a2a1d1e3be5edcb9115a537e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 10 Apr 2013 14:49:08 -0600 Subject: [PATCH] fix hole in validator The validator was not as smart as the compiler in determining that a `let' expression could be relied on to produce a constant-shaped function (without side effect or error) in the case that a right-hand side expression is a call to a known structure constructor or predicate. Closes PR 13679 Merge to v5.3.4 --- collects/tests/racket/optimize.rktl | 26 ++++++++++++ src/racket/src/optimize.c | 7 +++- src/racket/src/validate.c | 65 +++++++++++++++++++++-------- 3 files changed, 79 insertions(+), 19 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index b6bb9a37cd..768dbb52e2 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -3044,6 +3044,32 @@ (test 'flonum cadr ts))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The validator should understand that a structure +;; constructor always succeeds: + +(let () + (define (go sub) + (let ([e `(module m racket/base + (provide bar) + (struct foo (x)) + (define empty + (let ((t ,sub)) + (lambda () t))) + (define (bar) + (empty)))] + [o (open-output-bytes)]) + (write (compile e) o) + (parameterize ([current-namespace (make-base-namespace)]) + (eval + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes (get-output-bytes o))))) + ((dynamic-require ''m 'bar))))) + (go '(foo 1)) + (go '(foo? (list 1 2 3))) + ;; No optimization here for this one: + (go '(foo-x (foo 1)))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 79fa952a5a..f96bb95973 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -681,8 +681,11 @@ static int is_constant_super(Scheme_Object *arg, /* This is validate mode; conceptually, this code belongs in define_values_validate() */ v = scheme_hash_get(top_level_table, scheme_make_integer(pos)); - if (v) - return SCHEME_INT_VAL(v) + 1; + if (v) { + int k = SCHEME_INT_VAL(v); + if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) + return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1; + } } } diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index be464419d5..07d897fc72 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -123,7 +123,7 @@ static void noclear_stack_push(struct Validate_Clearing *vc, int pos) } -static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int field_count) +static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int shape) { if (!*_st_ht) { Scheme_Hash_Table *ht; @@ -132,7 +132,7 @@ static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int field_co } scheme_hash_set(*_st_ht, scheme_make_integer(pos), - scheme_make_integer(field_count)); + scheme_make_integer(shape)); } static int phaseless_expr(Scheme_Object *expr) @@ -184,10 +184,8 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, if (mv_flags & SCHEME_MODVAR_CONST) { intptr_t k; tl_state[i] = SCHEME_TOPLEVEL_CONST; - if (scheme_decode_struct_shape(((Module_Variable *)toplevels[i])->shape, &k)) { - if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) - add_struct_mapping(&st_ht, i, k >> STRUCT_PROC_SHAPE_SHIFT); - } + if (scheme_decode_struct_shape(((Module_Variable *)toplevels[i])->shape, &k)) + add_struct_mapping(&st_ht, i, k); } else if (mv_flags & SCHEME_MODVAR_FIXED) tl_state[i] = SCHEME_TOPLEVEL_FIXED; else @@ -418,15 +416,22 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp + (stinfo.uses_super ? 1 : 0), NULL, !!only_var, 0, vc, 0, 0, NULL, - size-1, NULL); + size-1, _st_ht); if (is_struct) { - if (_st_ht && (stinfo.field_count == stinfo.init_field_count)) { - /* record `struct:' binding as constant across invocations, - so that it can be recognized for sub-struct declarations */ - add_struct_mapping(_st_ht, - SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[1]), - stinfo.field_count); + if (_st_ht) { + /* Record `struct:' binding as constant across invocations, + so that it can be recognized for sub-struct declarations, + and so on: */ + for (i = 1; i < size; i++) { + /* For the struct:, we need the init and field counts to be the + same, otherwise anything is fine: */ + if ((i > 1) + || (stinfo.field_count == stinfo.init_field_count)) + add_struct_mapping(_st_ht, + SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[i]), + scheme_get_struct_proc_shape(i-1, &stinfo)); + } } /* In any case, treat the bindings as constant */ result = 2; @@ -1204,6 +1209,32 @@ static int validate_join_const(int result, int expected_results) : 0)); } +static int is_functional_rator(Scheme_Object *rator, int num_args, int expected_results, + Scheme_Hash_Table **_st_ht) +{ + if (_st_ht && *_st_ht && SAME_TYPE(SCHEME_TYPE(rator), scheme_toplevel_type)) { + int flags = (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK); + if (flags == SCHEME_TOPLEVEL_CONST) { + /* could be a struct operation... */ + int pos = SCHEME_TOPLEVEL_POS(rator); + Scheme_Object *v; + v = scheme_hash_get(*_st_ht, scheme_make_integer(pos)); + if (v) { + int k = SCHEME_INT_VAL(v); + if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_CONSTR) { + if (num_args == (k >> STRUCT_PROC_SHAPE_SHIFT)) + return 1; + } else if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_PRED) { + if (num_args == 1) + return 1; + } + } + } + } + + return scheme_is_functional_primitive(rator, num_args, expected_results); +} + #define CAN_RESET_STACK_SLOT 0 #if !CAN_RESET_STACK_SLOT # define WHEN_CAN_RESET_STACK_SLOT(x) 0 @@ -1506,7 +1537,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, check_self_call_valid(app->args[0], port, vc, delta, stack); if (result) { - r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); + r = is_functional_rator(app->args[0], app->num_args, expected_results, _st_ht); result = validate_join(result, r); } } @@ -1538,7 +1569,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, check_self_call_valid(app->rator, port, vc, delta, stack); if (result) { - r = scheme_is_functional_primitive(app->rator, 1, expected_results); + r = is_functional_rator(app->rator, 1, expected_results, _st_ht); result = validate_join(result, r); } } @@ -1576,7 +1607,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, check_self_call_valid(app->rator, port, vc, delta, stack); if (result) { - r = scheme_is_functional_primitive(app->rator, 2, expected_results); + r = is_functional_rator(app->rator, 2, expected_results, _st_ht); result = validate_join(r, result); } } @@ -1829,7 +1860,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, SCHEME_LET_ONE_TYPE(lo), procs, - 1, NULL); + 1, _st_ht); result = validate_join_seq(r, result); #if !CAN_RESET_STACK_SLOT