https://gcc.gnu.org/g:1353289ab9ea814e9990b7aa1462fb032480063b
commit 1353289ab9ea814e9990b7aa1462fb032480063b Author: Mikael Morin <mik...@gcc.gnu.org> Date: Mon Jul 7 11:46:08 2025 +0200 Déplacement variables après réallocation Sauvegarde data Renommage nom fonction. Diff: --- gcc/fortran/gfortran.h | 4 -- gcc/fortran/trans-array.cc | 167 ++++++++++++++++++++++++++------------------- gcc/fortran/trans-expr.cc | 14 ++-- 3 files changed, 102 insertions(+), 83 deletions(-) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6848bd1762d3..69367e638c5b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2028,10 +2028,6 @@ typedef struct gfc_symbol /* Set if this should be passed by value, but is not a VALUE argument according to the Fortran standard. */ unsigned pass_as_value:1; - /* Set if an allocatable array variable has been allocated in the current - scope. Used in the suppression of uninitialized warnings in reallocation - on assignment. */ - unsigned allocated_in_scope:1; /* Set if an external dummy argument is called with different argument lists. This is legal in Fortran, but can cause problems with autogenerated C prototypes for C23. */ diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 7be2d7b11a62..3cd6d90f47e7 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -3420,6 +3420,23 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, } +/* Given an array descriptor expression DESCR and its data pointer DATA, decide + whether to either save the data pointer to a variable and use the variable or + use the data pointer expression directly without any intermediary variable. + */ + +static bool +save_descriptor_data (tree descr, tree data) +{ + return !(DECL_P (data) + || (TREE_CODE (data) == ADDR_EXPR + && DECL_P (TREE_OPERAND (data, 0))) + || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr)) + && TREE_CODE (descr) == COMPONENT_REF + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0))))); +} + + /* Translate expressions for the descriptor and data pointer of a SS. */ /*GCC ARRAYS*/ @@ -3466,17 +3483,14 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) Otherwise we must evaluate it now to avoid breaking dependency analysis by pulling the expressions for elemental array indices inside the loop. */ - if (!(DECL_P (tmp) - || (TREE_CODE (tmp) == ADDR_EXPR - && DECL_P (TREE_OPERAND (tmp, 0))) - || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) - && TREE_CODE (se.expr) == COMPONENT_REF - && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))) + if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs) tmp = gfc_evaluate_now (tmp, block); info->data = tmp; tmp = gfc_conv_array_offset (se.expr); - info->offset = gfc_evaluate_now (tmp, block); + if (!ss->is_alloc_lhs) + tmp = gfc_evaluate_now (tmp, block); + info->offset = tmp; /* Make absolutely sure that the saved_offset is indeed saved so that the variable is still accessible after the loops @@ -4769,13 +4783,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) static void evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, - tree desc, int dim, bool lbound, bool deferred) + tree desc, int dim, bool lbound, bool deferred, bool save_value) { gfc_se se; gfc_expr * input_val = values[dim]; tree *output = &bounds[dim]; - if (input_val) { /* Specified section bound. */ @@ -4801,7 +4814,8 @@ evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, *output = lbound ? gfc_conv_array_lbound (desc, dim) : gfc_conv_array_ubound (desc, dim); } - *output = gfc_evaluate_now (*output, block); + if (save_value) + *output = gfc_evaluate_now (*output, block); } @@ -4834,18 +4848,18 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); desc = info->descriptor; stride = ar->stride[dim]; - + bool save_value = !ss->is_alloc_lhs; /* Calculate the start of the range. For vector subscripts this will be the range of the vector. */ evaluate_bound (block, info->start, ar->start, desc, dim, true, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, save_value); /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end is an expression with side-effects. */ evaluate_bound (block, info->end, ar->end, desc, dim, false, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, save_value); /* Calculate the stride. */ @@ -4856,7 +4870,11 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); gfc_add_block_to_block (block, &se.pre); - info->stride[dim] = gfc_evaluate_now (se.expr, block); + tree value = se.expr; + if (save_value) + info->stride[dim] = gfc_evaluate_now (value, block); + else + info->stride[dim] = value; } } @@ -5991,7 +6009,10 @@ gfc_set_delta (gfc_loopinfo *loop) gfc_array_index_type, info->start[dim], tmp); - info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); + if (ss->is_alloc_lhs) + info->delta[dim] = tmp; + else + info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); } } } @@ -6779,8 +6800,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, else gfc_add_expr_to_block (&se->pre, set_descriptor); - expr->symtree->n.sym->allocated_in_scope = 1; - return true; } @@ -8470,7 +8489,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gcc_assert (n == codim - 1); evaluate_bound (&loop.pre, info->start, ar->start, info->descriptor, n + ndim, true, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, true); loop.from[n + loop.dimen] = info->start[n + ndim]; } else @@ -11206,6 +11225,9 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) gfc_ref * ref; gfc_symbol *sym; + if (!flag_realloc_lhs) + return false; + if (!expr->ref) return false; @@ -11330,6 +11352,53 @@ concat_str_length (gfc_expr* expr) } +static void +update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop) +{ + for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain) + { + if (!s->is_alloc_lhs) + continue; + + gcc_assert (s->info->type == GFC_SS_SECTION); + gfc_array_info *info = &s->info->data.array; + tree desc = info->descriptor; + +#define UPDATE_VALUE(field, value) \ + do \ + { \ + if ((field) && VAR_P ((field))) \ + { \ + tree val = (value); \ + gfc_add_modify (block, (field), val); \ + } \ + else \ + (field) = gfc_evaluate_now ((field), block); \ + } \ + while (0) + + if (save_descriptor_data (desc, info->data)) + UPDATE_VALUE (info->data, gfc_conv_descriptor_data_get (desc)); + UPDATE_VALUE (info->offset, gfc_conv_descriptor_offset_get (desc)); + info->saved_offset = info->offset; + for (int i = 0; i < s->dimen; i++) + { + int dim = s->dim[i]; + tree tree_dim = gfc_rank_cst[dim]; + UPDATE_VALUE (info->start[dim], + gfc_conv_descriptor_lbound_get (desc, tree_dim)); + UPDATE_VALUE (info->end[dim], + gfc_conv_descriptor_ubound_get (desc, tree_dim)); + UPDATE_VALUE (info->stride[dim], + gfc_conv_descriptor_stride_get (desc, tree_dim)); + info->delta[dim] = gfc_evaluate_now (info->delta[dim], block); + } + +#undef UPDATE_VALUE + } +} + + /* Allocate the lhs of an assignment to an allocatable array, otherwise reallocate it. */ @@ -11341,8 +11410,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, stmtblock_t realloc_block; stmtblock_t alloc_block; stmtblock_t fblock; - stmtblock_t loop_pre_block; - gfc_ref *ref; gfc_ss *rss; gfc_ss *lss; gfc_array_info *linfo; @@ -11543,45 +11610,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, array1, build_int_cst (TREE_TYPE (array1), 0)); cond_null= gfc_evaluate_now (cond_null, &fblock); - /* If the data is null, set the descriptor bounds and offset. This suppresses - the maybe used uninitialized warning and forces the use of malloc because - the size is zero in all dimensions. Note that this block is only executed - if the lhs is unallocated and is only applied once in any namespace. - Component references are not subject to the warnings. */ - for (ref = expr1->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - break; - - if (!expr1->symtree->n.sym->allocated_in_scope && !ref) - { - gfc_start_block (&loop_pre_block); - for (n = 0; n < expr1->rank; n++) - { - gfc_conv_descriptor_lbound_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_zero_node); - gfc_conv_descriptor_stride_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_zero_node); - } - - tmp = gfc_conv_descriptor_offset (desc); - gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node); - - tmp = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, array1, - build_int_cst (TREE_TYPE (array1), 0)); - tmp = build3_v (COND_EXPR, tmp, - gfc_finish_block (&loop_pre_block), - build_empty_stmt (input_location)); - gfc_prepend_expr_to_block (&loop->pre, tmp); - - expr1->symtree->n.sym->allocated_in_scope = 1; - } - tmp = build3_v (COND_EXPR, cond_null, build1_v (GOTO_EXPR, jump_label1), build_empty_stmt (input_location)); @@ -11736,9 +11764,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, running offset. Use the saved_offset instead. */ tmp = gfc_conv_descriptor_offset (desc); gfc_add_modify (&fblock, tmp, offset); - if (linfo->saved_offset - && VAR_P (linfo->saved_offset)) - gfc_add_modify (&fblock, linfo->saved_offset, tmp); /* Now set the deltas for the lhs. */ for (n = 0; n < expr1->rank; n++) @@ -11748,8 +11773,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, tmp, loop->from[dim]); - if (linfo->delta[dim] && VAR_P (linfo->delta[dim])) - gfc_add_modify (&fblock, linfo->delta[dim], tmp); } /* Take into account _len of unlimited polymorphic entities, so that span @@ -11972,18 +11995,18 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr); gfc_add_expr_to_block (&fblock, tmp); - /* Make sure that the scalarizer data pointer is updated. */ - if (linfo->data && VAR_P (linfo->data)) - { - tmp = gfc_conv_descriptor_data_get (desc); - gfc_add_modify (&fblock, linfo->data, tmp); - } - /* Add the label for same shape lhs and rhs. */ tmp = build1_v (LABEL_EXPR, jump_label2); gfc_add_expr_to_block (&fblock, tmp); - return gfc_finish_block (&fblock); + tree realloc_code = gfc_finish_block (&fblock); + + stmtblock_t result_block; + gfc_init_block (&result_block); + gfc_add_expr_to_block (&result_block, realloc_code); + update_reallocated_descriptor (&result_block, loop); + + return gfc_finish_block (&result_block); } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 65d0ee4ff235..299acd3e3314 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -12875,11 +12875,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (gfc_is_reallocatable_lhs (expr1)) { lss->no_bounds_check = 1; - if (!(expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym != NULL - && !(expr2->value.function.isym->elemental - || expr2->value.function.isym->conversion))) - lss->is_alloc_lhs = 1; + lss->is_alloc_lhs = 1; } else lss->no_bounds_check = expr1->no_bounds_check; @@ -12962,8 +12958,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Walk the rhs. */ rss = gfc_walk_expr (expr2); if (rss == gfc_ss_terminator) - /* The rhs is scalar. Add a ss for the expression. */ - rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + { + /* The rhs is scalar. Add a ss for the expression. */ + rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + lss->is_alloc_lhs = 0; + } + /* When doing a class assign, then the handle to the rhs needs to be a pointer to allow for polymorphism. */ if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))