diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/trans-array.cc | 54 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 35 |
2 files changed, 65 insertions, 24 deletions
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index fffa6db..6b759d1 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -3478,6 +3478,29 @@ substitute_subexpr_in_expr (tree target, tree replacement, tree expr) } +/* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra + code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear + REF. */ + +static void +save_ref (tree &code, tree &ref, vec<tree> &replacement_roots) +{ + stmtblock_t tmp_block; + gfc_init_block (&tmp_block); + tree var = gfc_evaluate_now (ref, &tmp_block); + gfc_add_expr_to_block (&tmp_block, code); + code = gfc_finish_block (&tmp_block); + + unsigned i; + tree repl_root; + FOR_EACH_VEC_ELT (replacement_roots, i, repl_root) + substitute_subexpr_in_expr (ref, var, repl_root); + + replacement_roots.safe_push (ref); + ref = NULL_TREE; +} + + /* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before that, try to factor subexpressions of VALUE to variables, adding extra code to BLOCK. @@ -3492,11 +3515,8 @@ set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block) /* As the reference is processed from outer to inner, variable definitions will be generated in reversed order, so can't be put directly in BLOCK. We use TMP_BLOCK instead. */ - stmtblock_t tmp_block; tree accumulated_code = NULL_TREE; - gfc_init_block (&tmp_block); - /* The current candidate to factoring. */ tree saveable_ref = NULL_TREE; @@ -3526,8 +3546,18 @@ set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block) if (!maybe_reallocatable) { + if (saveable_ref != NULL_TREE && saveable_ref != data_ref) + { + /* A reference worth saving has been seen, and now the pointer + to the current reference is also worth saving. If the + previous reference to save wasn't the current one, do save + it now. Otherwise drop it as we prefer saving the + pointer. */ + save_ref (accumulated_code, saveable_ref, replacement_roots); + } + /* Don't evaluate the pointer to a variable yet; do it only if the - variable would be significantly more simple than the reference + variable would be significantly more simple than the reference it replaces. That is if the reference contains anything different from NOPs, COMPONENTs and DECLs. */ saveable_ref = next_ref; @@ -3552,20 +3582,8 @@ set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block) } if (saveable_ref != NULL_TREE) - { - /* We have seen a reference worth saving. Do it now. */ - tree var = gfc_evaluate_now (saveable_ref, &tmp_block); - gfc_add_expr_to_block (&tmp_block, accumulated_code); - accumulated_code = gfc_finish_block (&tmp_block); - - unsigned i; - tree repl_root; - FOR_EACH_VEC_ELT (replacement_roots, i, repl_root) - substitute_subexpr_in_expr (saveable_ref, var, repl_root); - - replacement_roots.safe_push (saveable_ref); - saveable_ref = NULL_TREE; - } + /* We have seen a reference worth saving. Do it now. */ + save_ref (accumulated_code, saveable_ref, replacement_roots); if (TREE_CODE (data_ref) != ARRAY_REF) break; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 7c76215..0db7ba3 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -714,6 +714,8 @@ gfc_get_class_from_expr (tree expr) { tree tmp; tree type; + bool array_descr_found = false; + bool comp_after_descr_found = false; for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0)) { @@ -725,6 +727,8 @@ gfc_get_class_from_expr (tree expr) { if (GFC_CLASS_TYPE_P (type)) return tmp; + if (GFC_DESCRIPTOR_TYPE_P (type)) + array_descr_found = true; if (type != TYPE_CANONICAL (type)) type = TYPE_CANONICAL (type); else @@ -732,6 +736,23 @@ gfc_get_class_from_expr (tree expr) } if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL) break; + + /* Avoid walking up the reference chain too far. For class arrays, the + array descriptor is a direct component (through a pointer) of the class + container. So there is exactly one COMPONENT_REF between a class + container and its child array descriptor. After seeing an array + descriptor, we can give up on the second COMPONENT_REF we see, if no + class container was found until that point. */ + if (array_descr_found) + { + if (comp_after_descr_found) + { + if (TREE_CODE (tmp) == COMPONENT_REF) + return NULL_TREE; + } + else if (TREE_CODE (tmp) == COMPONENT_REF) + comp_after_descr_found = true; + } } if (POINTER_TYPE_P (TREE_TYPE (tmp))) @@ -12871,9 +12892,16 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); + gfc_fix_class_refs (expr1); + + realloc_flag = flag_realloc_lhs + && gfc_is_reallocatable_lhs (expr1) + && expr2->rank + && !is_runtime_conformable (expr1, expr2); + /* Walk the lhs. */ lss = gfc_walk_expr (expr1); - if (gfc_is_reallocatable_lhs (expr1)) + if (realloc_flag) { lss->no_bounds_check = 1; lss->is_alloc_lhs = 1; @@ -12924,11 +12952,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, assoc_assign = is_assoc_assign (expr1, expr2); - realloc_flag = flag_realloc_lhs - && gfc_is_reallocatable_lhs (expr1) - && expr2->rank - && !is_runtime_conformable (expr1, expr2); - /* Only analyze the expressions for coarray properties, when in coarray-lib mode. Avoid false-positive uninitialized diagnostics with initializing the codimension flag unconditionally. */ |