https://gcc.gnu.org/g:d607595f1f4f4566776000aeedfd4d0bb3ce4b9b
commit d607595f1f4f4566776000aeedfd4d0bb3ce4b9b
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Jan 16 14:00:20 2025 +0100
Factorisation gfc_conv_expr_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 358 +++++++++++++++++++++++----------------------
1 file changed, 186 insertions(+), 172 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 097a9a0d860a..ec0badd0dc33 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1542,6 +1542,25 @@ keep_descriptor_lower_bound (gfc_expr *e)
}
+static void
+copy_descriptor (stmtblock_t *block, tree dest, tree src,
+ gfc_expr *src_expr, bool subref)
+{
+ /* Copy the descriptor for pointer assignments. */
+ gfc_add_modify (block, dest, src);
+
+ /* Add any offsets from subreferences. */
+ gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
+
+ /* ....and set the span field. */
+ tree tmp;
+ if (src_expr->ts.type == BT_CHARACTER)
+ tmp = gfc_conv_descriptor_span_get (src);
+ else
+ tmp = gfc_get_array_span (src, src_expr);
+ gfc_conv_descriptor_span_set (block, dest, tmp);
+}
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
@@ -8991,24 +9010,175 @@ is_explicit_coarray (gfc_expr *expr)
static void
-copy_descriptor (stmtblock_t *block, tree dest, tree src,
- gfc_expr *src_expr, bool subref)
+set_descriptor (stmtblock_t *block, tree dest, tree src, gfc_expr *src_expr,
+ int rank, int corank, gfc_ss *ss, gfc_array_info *info,
+ tree lowers[GFC_MAX_DIMENSIONS],
+ tree uppers[GFC_MAX_DIMENSIONS],
+ bool unlimited_polymorphic, bool data_needed, bool subref)
{
- /* Copy the descriptor for pointer assignments. */
- gfc_add_modify (block, dest, src);
+ int ndim = info->ref ? info->ref->u.ar.dimen : rank;
- /* Add any offsets from subreferences. */
- gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
-
- /* ....and set the span field. */
- tree tmp;
- if (src_expr->ts.type == BT_CHARACTER)
+ /* Set the span field. */
+ tree tmp = NULL_TREE;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
tmp = gfc_conv_descriptor_span_get (src);
else
tmp = gfc_get_array_span (src, src_expr);
- gfc_conv_descriptor_span_set (block, dest, tmp);
+ if (tmp)
+ gfc_conv_descriptor_span_set (block, dest, tmp);
+
+ /* The following can be somewhat confusing. We have two
+ descriptors, a new one and the original array.
+ {dest, parmtype, dim} refer to the new one.
+ {src, type, n, loop} refer to the original, which maybe
+ a descriptorless array.
+ The bounds of the scalarization are the bounds of the section.
+ We don't have to worry about numeric overflows when calculating
+ the offsets because all elements are within the array data. */
+
+ /* Set the dtype. */
+ tmp = gfc_conv_descriptor_dtype (dest);
+ tree dtype;
+ if (unlimited_polymorphic)
+ dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
+ else if (src_expr->ts.type == BT_ASSUMED)
+ {
+ tree tmp2 = src;
+ if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
+ tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
+ if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
+ tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+ dtype = gfc_conv_descriptor_dtype (tmp2);
+ }
+ else
+ dtype = gfc_get_dtype (TREE_TYPE (dest));
+ gfc_add_modify (block, tmp, dtype);
+
+ /* The 1st element in the section. */
+ tree base = gfc_index_zero_node;
+ if (src_expr->ts.type == BT_CHARACTER && src_expr->rank == 0 && corank)
+ base = gfc_index_one_node;
+
+ /* The offset from the 1st element in the section. */
+ tree offset = gfc_index_zero_node;
+
+ for (int n = 0; n < ndim; n++)
+ {
+ tree stride = gfc_conv_array_stride (src, n);
+
+ /* Work out the 1st element in the section. */
+ tree start;
+ if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+ {
+ gcc_assert (info->subscript[n]
+ && info->subscript[n]->info->type == GFC_SS_SCALAR);
+ start = info->subscript[n]->info->data.scalar.value;
+ }
+ else
+ {
+ /* Evaluate and remember the start of the section. */
+ start = info->start[n];
+ stride = gfc_evaluate_now (stride, block);
+ }
+
+ tmp = gfc_conv_array_lbound (src, n);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+ start, tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+ tmp, stride);
+ base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
+ base, tmp);
+
+ if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+ {
+ /* For elemental dimensions, we only need the 1st
+ element in the section. */
+ continue;
+ }
+
+ /* Vector subscripts need copying and are handled elsewhere. */
+ if (info->ref)
+ gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
+
+ /* look for the corresponding scalarizer dimension: dim. */
+ int dim;
+ for (dim = 0; dim < ndim; dim++)
+ if (ss->dim[dim] == n)
+ break;
+
+ /* loop exited early: the DIM being looked for has been found. */
+ gcc_assert (dim < ndim);
+
+ /* Set the new lower bound. */
+ tree from = lowers[dim];
+ tree to = uppers[dim];
+
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[dim], from);
+
+ /* Set the new upper bound. */
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[dim], to);
+
+ /* Multiply the stride by the section stride to get the
+ total stride. */
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ stride, info->stride[n]);
+
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (offset), stride, from);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (offset), offset, tmp);
+
+ /* Store the new stride. */
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[dim], stride);
+ }
+
+ for (int n = rank; n < rank + corank; n++)
+ {
+ tree from = lowers[n];
+ tree to = uppers[n];
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[n], from);
+ if (n < rank + corank - 1)
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[n], to);
+ }
+
+ if (data_needed)
+ /* Point the data pointer at the 1st element in the section. */
+ gfc_get_dataptr_offset (block, dest, src, base,
+ subref, src_expr);
+ else
+ gfc_conv_descriptor_data_set (block, dest,
+ gfc_index_zero_node);
+
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && src_expr->corank)
+ {
+ tmp = INDIRECT_REF_P (src) ? TREE_OPERAND (src, 0) : src;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ tmp = gfc_conv_descriptor_token (tmp);
+ }
+ else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
+ && GFC_DECL_TOKEN (tmp) != NULL_TREE)
+ tmp = GFC_DECL_TOKEN (tmp);
+ else
+ {
+ tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
+ }
+
+ gfc_add_modify (block, gfc_conv_descriptor_token (dest), tmp);
+ }
}
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
@@ -9051,11 +9221,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
tree tmp;
tree desc;
stmtblock_t block;
- tree start;
int full;
bool subref_array_target = false;
bool deferred_array_component = false;
bool substr = false;
+ bool unlimited_polymorphic = false;
gfc_expr *arg, *ss_expr;
if (se->want_coarray || expr->rank == 0)
@@ -9081,7 +9251,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
if (!se->direct_byref)
- se->unlimited_polymorphic = UNLIMITED_POLY (expr);
+ unlimited_polymorphic = UNLIMITED_POLY (expr);
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
@@ -9365,12 +9535,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
int dim, ndim, codim;
tree parm;
tree parmtype;
- tree dtype;
- tree stride;
- tree from;
- tree to;
- tree base;
- tree offset;
ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
@@ -9491,161 +9655,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_get_array_span (desc, expr)));
}
- /* Set the span field. */
- tmp = NULL_TREE;
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- tmp = gfc_conv_descriptor_span_get (desc);
- else
- tmp = gfc_get_array_span (desc, expr);
- if (tmp)
- gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
-
- /* The following can be somewhat confusing. We have two
- descriptors, a new one and the original array.
- {parm, parmtype, dim} refer to the new one.
- {desc, type, n, loop} refer to the original, which maybe
- a descriptorless array.
- The bounds of the scalarization are the bounds of the section.
- We don't have to worry about numeric overflows when calculating
- the offsets because all elements are within the array data. */
-
- /* Set the dtype. */
- tmp = gfc_conv_descriptor_dtype (parm);
- if (se->unlimited_polymorphic)
- dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
- else if (expr->ts.type == BT_ASSUMED)
- {
- tree tmp2 = desc;
- if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
- tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
- if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
- tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
- dtype = gfc_conv_descriptor_dtype (tmp2);
- }
- else
- dtype = gfc_get_dtype (parmtype);
- gfc_add_modify (&loop.pre, tmp, dtype);
- /* The 1st element in the section. */
- base = gfc_index_zero_node;
- if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
- base = gfc_index_one_node;
+ set_descriptor (&se->pre, parm, desc, expr, loop.dimen, codim,
+ ss, info, loop.from, loop.to, unlimited_polymorphic,
+ !se->data_not_needed, subref_array_target);
- /* The offset from the 1st element in the section. */
- offset = gfc_index_zero_node;
-
- for (n = 0; n < ndim; n++)
- {
- stride = gfc_conv_array_stride (desc, n);
-
- /* Work out the 1st element in the section. */
- if (info->ref
- && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
- {
- gcc_assert (info->subscript[n]
- && info->subscript[n]->info->type == GFC_SS_SCALAR);
- start = info->subscript[n]->info->data.scalar.value;
- }
- else
- {
- /* Evaluate and remember the start of the section. */
- start = info->start[n];
- stride = gfc_evaluate_now (stride, &loop.pre);
- }
-
- tmp = gfc_conv_array_lbound (desc, n);
- tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
- start, tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
- tmp, stride);
- base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
- base, tmp);
-
- if (info->ref
- && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
- {
- /* For elemental dimensions, we only need the 1st
- element in the section. */
- continue;
- }
-
- /* Vector subscripts need copying and are handled elsewhere. */
- if (info->ref)
- gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
-
- /* look for the corresponding scalarizer dimension: dim. */
- for (dim = 0; dim < ndim; dim++)
- if (ss->dim[dim] == n)
- break;
-
- /* loop exited early: the DIM being looked for has been found. */
- gcc_assert (dim < ndim);
-
- /* Set the new lower bound. */
- from = loop.from[dim];
- to = loop.to[dim];
-
- gfc_conv_descriptor_lbound_set (&loop.pre, parm,
- gfc_rank_cst[dim], from);
-
- /* Set the new upper bound. */
- gfc_conv_descriptor_ubound_set (&loop.pre, parm,
- gfc_rank_cst[dim], to);
-
- /* Multiply the stride by the section stride to get the
- total stride. */
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- stride, info->stride[n]);
-
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (offset), stride, from);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE (offset), offset, tmp);
-
- /* Store the new stride. */
- gfc_conv_descriptor_stride_set (&loop.pre, parm,
- gfc_rank_cst[dim], stride);
- }
-
- for (n = loop.dimen; n < loop.dimen + codim; n++)
- {
- from = loop.from[n];
- to = loop.to[n];
- gfc_conv_descriptor_lbound_set (&loop.pre, parm,
- gfc_rank_cst[n], from);
- if (n < loop.dimen + codim - 1)
- gfc_conv_descriptor_ubound_set (&loop.pre, parm,
- gfc_rank_cst[n], to);
- }
-
- if (se->data_not_needed)
- gfc_conv_descriptor_data_set (&loop.pre, parm,
- gfc_index_zero_node);
- else
- /* Point the data pointer at the 1st element in the section. */
- gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
- subref_array_target, expr);
-
- gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
-
- if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
- {
- tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
- {
- tmp = gfc_conv_descriptor_token (tmp);
- }
- else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
- && GFC_DECL_TOKEN (tmp) != NULL_TREE)
- tmp = GFC_DECL_TOKEN (tmp);
- else
- {
- tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
- }
-
- gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
- }
desc = parm;
}
