https://gcc.gnu.org/g:8293b9e40f12e94a0fdae61b6ec7f2c25ac5b699
commit r15-7661-g8293b9e40f12e94a0fdae61b6ec7f2c25ac5b699
Author: Tobias Burnus <tbur...@baylibre.com>
Date: Fri Feb 21 08:54:12 2025 +0100
Fortran: Improve gfc_array_kind for assumed rank; gfc_tree_array_size on
'tree'
Improve the internal and debug representation of assumed-rank arrays by
honoring the pointer and allocatable property.
Permit obtaining the array size from only a tree (via the array descriptor)
besides obtaining it from the gfc_expr's array spec. This will be used
by a follow up OpenMP patch for mapping derived types with allocatable
components.
gcc/fortran/ChangeLog:
* trans-array.cc (gfc_full_array_size): Obtain the rank from
the array descriptor for assumed rank.
(gfc_tree_array_size): Likewise; permit expr = NULL to operate
only the tree.
(gfc_conv_descriptor_stride_get): Update for added assumed-rank
array types.
* trans-openmp.cc (gfc_omp_finish_clause): Likewise.
* trans-types.cc (gfc_build_array_type, gfc_get_derived_type,
gfc_get_array_descr_info): Likewise.
* trans.h (enum gfc_array_kind): Add
GFC_ARRAY_ASSUMED_RANK_{ALLOCATABLE,POINTER{,_CONT}}.
Diff:
---
gcc/fortran/trans-array.cc | 41 ++++++++++++++++----------------
gcc/fortran/trans-openmp.cc | 33 ++++++++++++++++++--------
gcc/fortran/trans-types.cc | 57 ++++++++++++++++++++++++++++++++++-----------
gcc/fortran/trans.h | 3 +++
4 files changed, 90 insertions(+), 44 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ec627dddffd4..92e933add8a8 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -483,9 +483,11 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
if (integer_zerop (dim)
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
return gfc_conv_descriptor_stride (desc, dim);
@@ -8746,7 +8748,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
/* Calculate the array size (number of elements); if dim != NULL_TREE,
- return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
*/
+ return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
+ If !expr && descriptor array, the rank is taken from the descriptor. */
tree
gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
{
@@ -8756,20 +8759,15 @@ gfc_tree_array_size (stmtblock_t *block, tree desc,
gfc_expr *expr, tree dim)
return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
}
tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
- symbol_attribute attr = gfc_expr_attr (expr);
- gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
- if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
- || !dim)
- {
- if (expr->rank < 0)
- rank = fold_convert (signed_char_type_node,
- gfc_conv_descriptor_rank (desc));
- else
- rank = build_int_cst (signed_char_type_node, expr->rank);
- }
+ enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
+ if (expr == NULL || expr->rank < 0)
+ rank = fold_convert (signed_char_type_node,
+ gfc_conv_descriptor_rank (desc));
+ else
+ rank = build_int_cst (signed_char_type_node, expr->rank);
- if (dim || expr->rank == 1)
+ if (dim || (expr && expr->rank == 1))
{
if (!dim)
dim = gfc_index_zero_node;
@@ -8786,8 +8784,8 @@ gfc_tree_array_size (stmtblock_t *block, tree desc,
gfc_expr *expr, tree dim)
size = max (0, size); */
size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
size, gfc_index_zero_node);
- if (!attr.pointer && !attr.allocatable
- && as && as->type == AS_ASSUMED_RANK)
+ if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK)
{
tmp = fold_build2_loc (input_location, MINUS_EXPR,
signed_char_type_node,
rank, build_int_cst (signed_char_type_node,
1));
@@ -8828,7 +8826,7 @@ gfc_tree_array_size (stmtblock_t *block, tree desc,
gfc_expr *expr, tree dim)
extent = 0
size *= extent. */
cond = NULL_TREE;
- if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+ if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
{
tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
rank, build_int_cst (signed_char_type_node, 1));
@@ -9456,7 +9454,10 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int
rank)
tree idx;
tree nelems;
tree tmp;
- idx = gfc_rank_cst[rank - 1];
+ if (rank < 0)
+ idx = gfc_conv_descriptor_rank (decl);
+ else
+ idx = gfc_rank_cst[rank - 1];
nelems = gfc_conv_descriptor_ubound_get (decl, idx);
tmp = gfc_conv_descriptor_lbound_get (decl, idx);
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 233cc0fcaa97..3e5f92fe2e34 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -1664,16 +1664,23 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool
openacc)
tree size = create_tmp_var (gfc_array_index_type);
tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
elemsz = fold_convert (gfc_array_index_type, elemsz);
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+ enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
+ if (akind == GFC_ARRAY_ALLOCATABLE
+ || akind == GFC_ARRAY_POINTER
+ || akind == GFC_ARRAY_POINTER_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
{
stmtblock_t cond_block;
tree tem, then_b, else_b, zero, cond;
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_init_block (&cond_block);
- tem = gfc_full_array_size (&cond_block, decl,
- GFC_TYPE_ARRAY_RANK (type));
+ tem = gfc_full_array_size (&cond_block, unshare_expr (decl), rank);
gfc_add_modify (&cond_block, size, tem);
gfc_add_modify (&cond_block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
@@ -1683,7 +1690,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool
openacc)
zero = build_int_cst (gfc_array_index_type, 0);
gfc_add_modify (&cond_block, size, zero);
else_b = gfc_finish_block (&cond_block);
- tem = gfc_conv_descriptor_data_get (decl);
+ tem = gfc_conv_descriptor_data_get (unshare_expr (decl));
tem = fold_convert (pvoid_type_node, tem);
cond = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tem, null_pointer_node);
@@ -1701,10 +1708,13 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool
openacc)
stmtblock_t cond_block;
tree then_b;
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_init_block (&cond_block);
gfc_add_modify (&cond_block, size,
- gfc_full_array_size (&cond_block, decl,
- GFC_TYPE_ARRAY_RANK (type)));
+ gfc_full_array_size (&cond_block, unshare_expr (decl),
+ rank));
gfc_add_modify (&cond_block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
size, elemsz));
@@ -1715,9 +1725,12 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool
openacc)
}
else
{
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_add_modify (&block, size,
- gfc_full_array_size (&block, decl,
- GFC_TYPE_ARRAY_RANK (type)));
+ gfc_full_array_size (&block, unshare_expr (decl),
+ rank));
gfc_add_modify (&block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
size, elemsz));
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 0411400e0f24..3374778cb650 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1628,8 +1628,16 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
: GFC_ARRAY_ASSUMED_SHAPE;
else if (as->type == AS_ASSUMED_RANK)
- akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
- : GFC_ARRAY_ASSUMED_RANK;
+ {
+ if (akind == GFC_ARRAY_ALLOCATABLE)
+ akind = GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE;
+ else if (akind == GFC_ARRAY_POINTER || akind == GFC_ARRAY_POINTER_CONT)
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ : GFC_ARRAY_ASSUMED_RANK_POINTER;
+ else
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+ : GFC_ARRAY_ASSUMED_RANK;
+ }
return gfc_get_array_type_bounds (type, as->rank == -1
? GFC_MAX_DIMENSIONS : as->rank,
corank, lbound, ubound, 0, akind,
@@ -2958,9 +2966,10 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
}
if (derived->components
- && derived->components->ts.type == BT_DERIVED
- && strcmp (derived->components->name, "_data") == 0
- && derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ && derived->components->ts.type == BT_DERIVED
+ && startswith (derived->name, "__class")
+ && strcmp (derived->components->name, "_data") == 0
+ && derived->components->ts.u.derived->attr.unlimited_polymorphic)
unlimited_entity = true;
/* Go through the derived type components, building them as
@@ -3067,11 +3076,24 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
{
enum gfc_array_kind akind;
- if (c->attr.pointer)
+ bool is_ptr = ((c == derived->components
+ && derived->components->ts.type == BT_DERIVED
+ && startswith (derived->name, "__class")
+ && (strcmp (derived->components->name, "_data")
+ == 0))
+ ? c->attr.class_pointer : c->attr.pointer);
+ if (is_ptr)
akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
: GFC_ARRAY_POINTER;
- else
+ else if (c->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
+ else if (c->as->type == AS_ASSUMED_RANK)
+ akind = GFC_ARRAY_ASSUMED_RANK;
+ else
+ /* FIXME – see PR fortran/104651. Additionally, the following
+ gfc_build_array_type should use !is_ptr instead of
+ c->attr.pointer and codim unconditionally without '? :'. */
+ akind = GFC_ARRAY_ASSUMED_SHAPE;
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. Every
array pointer in a coarray derived type needs to provide space
@@ -3753,15 +3775,22 @@ gfc_get_array_descr_info (const_tree type, struct
array_descr_info *info)
t = fold_build_pointer_plus (t, data_off);
t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+ enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
+ if (akind == GFC_ARRAY_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE)
info->allocated = build2 (NE_EXPR, logical_type_node,
info->data_location, null_pointer_node);
- else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+ else if (akind == GFC_ARRAY_POINTER
+ || akind == GFC_ARRAY_POINTER_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
info->associated = build2 (NE_EXPR, logical_type_node,
info->data_location, null_pointer_node);
- if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
+ if ((akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
&& dwarf_version >= 5)
{
rank = 1;
@@ -3792,8 +3821,8 @@ gfc_get_array_descr_info (const_tree type, struct
array_descr_info *info)
dim_off, upper_suboff));
t = build1 (INDIRECT_REF, gfc_array_index_type, t);
info->dimen[dim].upper_bound = t;
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
+ if (akind == GFC_ARRAY_ASSUMED_SHAPE
+ || akind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
{
/* Assumed shape arrays have known lower bounds. */
info->dimen[dim].upper_bound
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index e22e0f18f6fb..69c3d90bb23b 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -1012,6 +1012,9 @@ enum gfc_array_kind
GFC_ARRAY_ASSUMED_SHAPE_CONT,
GFC_ARRAY_ASSUMED_RANK,
GFC_ARRAY_ASSUMED_RANK_CONT,
+ GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE,
+ GFC_ARRAY_ASSUMED_RANK_POINTER,
+ GFC_ARRAY_ASSUMED_RANK_POINTER_CONT,
GFC_ARRAY_ALLOCATABLE,
GFC_ARRAY_POINTER,
GFC_ARRAY_POINTER_CONT
