The attached patch does some ground-laying work for OpenMP
deep mapping - touching common gfortran code.
It does so by:
(1)gfc_tree_array_size now can determine the array size not only from the
passed Fortran gfc_expr but also using a descriptor, passed as gimple
'tree'.
(2) Adds missingGFC_ARRAY_ASSUMED_RANK_{ALLOCATABLE,POINTER{,_CONT}} to enum
gfc_array_kind to complete the kinds – for non-assumed-rank, those
subtypes already existed, for assumed rank, the pointer/allocatable
flags were missing (and for pointer: contiguous, while allocatables are
always contigous).
Build and regtested on x86-64_gnu-linux.
OK for mainline?
* * *
When doing the change (2) back when I first created the patch, I
encountered an issue, which I could not fix quickly. Hence, I filed
https://gcc.gnu.org/PR104651 - see also the FIXME in the code which
should be IMHO be used but it causes fails. Although, the proper fix is
probably to change how CLASS/attributes in it are represented (cf. PR).
[I don't recall the details - and don't know more anymore than what's
in the FIXME comment and in the problem report.]
* * *
BACKGROUND/EXAMPLE
-> OpenMP + derived-type mapping with allocatable components
(i.e. why I need the modifications; for those changes, I will also
add testcases.)
Namely, assume:
type t
real, allocatable :: x(:)
real, pointer :: p(:)
end type t
type(t) :: var(4)
!$omp target enter data map(to:var)
This is supposed to copy 'var' onto an offloading device
(device = omp_get_default_device()) - by doing a deep
copying/mapping. Thus, the compiler needs to generate code
like - pseudocode:
map (to: var [size: 4*storage_size(type(t))])
for i = 1 to 4:
if (allocated (var(i)%x)
map (to: var(i)%x [size: size(var(i)%x) * sizeof(real)])
[plus attaching the just mapped data to the base_addr
of the array descriptor.]
Namely: var and also var(:)%x have to be copied to the device,
var(:)%p is not touched – as it is a pointer and not an allocatable.
Another example would be:
!$omp target
var(1)%x(2) = 7
!$omp end target
where 'map(tofrom:var)' is implicitly added, which happens
quite late in the game. Thus, the code handles the mapping
both by explicit and implicit mapping and does so very late.
(omp-low.cc calls back to the Fortran front-end to do the
work.)
* * *
Soon/next, I will post the patch that handles code above (for
nonpolymorphic allocatable components). However, if you want to
glance at the code, already you can find an older version at
* https://gcc.gnu.org/pipermail/gcc-patches/2022-March/591144.html
And a re-based commit relative to GCC 14, applied to OG14
(devel/omp/gcc-14) at https://gcc.gnu.org/g:92c3af3d4f8
(or 'git log <hash>' or 'git log devel/omp/gcc-14' in any of
your GCC repos).
Note that the to-be-posted patch will differ a bit as:
- the middle end bits are already in
- the CLASS/polymorphic handling will be removed.
- minor cleanup/fixes
Reason for not including polymorphism support:
* As the vtab is not handled, there is no benefit of having it.
Additionally, the patch changes what's in the vtable/vtab by
adding an entry, breaking all backward compatibility of vtabs.
Thus, I only want to add it when it works properly.
* On the OpenMP spec side, it is similar: OpenMP 6.0 clarified
that mapping polymorphic variables in Fortran is not supported
(5.x was unclear) but it added full support for shared-memory
part (data sharing clauses). Plus there is on-going work to
add polymorphism support to OpenMP 6.1.
[For 6.1, parts of the GCC polymorphism patch will be resurrected
in some way, but for now not having polymorphism is simply better!]
* * *
Tobias
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}}.
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 ec627dddffd..92e933add8a 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 233cc0fcaa9..3e5f92fe2e3 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 0411400e0f2..3374778cb65 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 915f17549c9..5711a02c3fb 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -1021,6 +1021,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
