https://gcc.gnu.org/g:1d87733fb2a12c4ed75b1d84af0731dfa646f0cd
commit 1d87733fb2a12c4ed75b1d84af0731dfa646f0cd
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Tue Feb 4 11:16:32 2025 +0100
Sauvegarde factorisation set_descriptor_from_scalar
Correction régression allocate_with_source_15.f03
Nettoyage correction
Correction régression allocate_with_mold_3
Correction allocate_with_source_16.f90
Correction régression assumed_rank_21.f90
Correction coarray_allocate_8.f08
Correction régression pr86470.f90
Correction régression dummy_3.f90
Diff:
---
gcc/fortran/trans-array.cc | 204 +++++++++++++++++++++++++++++++--------------
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 67 +++++++++------
gcc/fortran/trans-types.cc | 47 +++++++----
gcc/fortran/trans-types.h | 1 +
gcc/fortran/trans.h | 1 +
6 files changed, 218 insertions(+), 104 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 97d9f882ee4c..fd34c64fb16e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -92,6 +92,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans-array.h"
#include "trans-const.h"
#include "dependency.h"
+#include "gimplify.h"
static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
@@ -602,7 +603,7 @@ gfc_conv_descriptor_sm_get (tree desc, tree dim)
}
-static int
+static bt
get_type_info (const bt &type)
{
switch (type)
@@ -613,11 +614,13 @@ get_type_info (const bt &type)
case BT_COMPLEX:
case BT_DERIVED:
case BT_CHARACTER:
- case BT_CLASS:
case BT_VOID:
case BT_UNSIGNED:
return type;
+ case BT_CLASS:
+ return BT_DERIVED;
+
case BT_PROCEDURE:
case BT_ASSUMED:
return BT_VOID;
@@ -674,9 +677,15 @@ get_size_info (gfc_typespec &ts)
class modify_info
{
public:
+ virtual bool set_dtype () const { return is_initialization (); }
+ virtual bool use_tree_type () const { return false; }
virtual bool is_initialization () const { return false; }
virtual bool initialize_data () const { return false; }
+ virtual bool set_span () const { return false; }
+ virtual bool set_token () const { return true; }
virtual tree get_data_value () const { return NULL_TREE; }
+ virtual bt get_type_type (const gfc_typespec &) const { return BT_UNKNOWN; }
+ virtual tree get_length (gfc_typespec *ts) const { return get_size_info
(*ts); }
};
class nullification : public modify_info
@@ -700,8 +709,14 @@ class init_info : public modify_info
public:
virtual bool is_initialization () const { return true; }
virtual gfc_typespec *get_type () const { return nullptr; }
+ virtual bt get_type_type (const gfc_typespec &) const;
};
+bt
+init_info::get_type_type (const gfc_typespec & type_info) const
+{
+ return get_type_info (type_info.type);
+}
class default_init : public init_info
{
@@ -731,23 +746,103 @@ public:
virtual gfc_typespec *get_type () const { return &ts; }
};
-class scalar_value : public init_info
+
+class scalar_value : public modify_info
{
private:
- gfc_typespec &ts;
+ bool initialisation;
+ gfc_typespec *ts;
tree value;
+ bool use_tree_type_;
+ bool clear_token;
+ tree get_elt_type () const;
public:
scalar_value(gfc_typespec &arg_ts, tree arg_value)
- : ts(arg_ts), value(arg_value) { }
+ : initialisation(true), ts(&arg_ts), value(arg_value), use_tree_type_
(false), clear_token(true) { }
+ scalar_value(tree arg_value)
+ : initialisation(true), ts(nullptr), value(arg_value), use_tree_type_
(true), clear_token(false) { }
+ virtual bool is_initialization () const { return initialisation; }
virtual bool initialize_data () const { return true; }
- virtual tree get_data_value () const { return value; }
- virtual gfc_typespec *get_type () const { return &ts; }
+ virtual tree get_data_value () const;
+ virtual gfc_typespec *get_type () const { return ts; }
+ virtual bool set_span () const { return true; }
+ virtual bool use_tree_type () const { return use_tree_type_; }
+ virtual bool set_token () const { return clear_token; }
+ virtual bt get_type_type (const gfc_typespec &) const;
+ virtual tree get_length (gfc_typespec *ts) const;
};
+tree
+scalar_value::get_data_value () const
+{
+ if (POINTER_TYPE_P (TREE_TYPE (value)))
+ return value;
+ else
+ return gfc_build_addr_expr (NULL_TREE, value);
+}
+
+tree
+scalar_value::get_elt_type () const
+{
+ tree tmp = value;
+
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = TREE_TYPE (tmp);
+
+ tree etype = TREE_TYPE (tmp);
+
+ /* For arrays, which are not scalar coarrays. */
+ if (TREE_CODE (etype) == ARRAY_TYPE && !TYPE_STRING_FLAG (etype))
+ etype = TREE_TYPE (etype);
+
+ return etype;
+}
+
+bt
+scalar_value::get_type_type (const gfc_typespec & type_info) const
+{
+ bt n;
+ if (use_tree_type ())
+ {
+ tree etype = get_elt_type ();
+ gfc_get_type_info (etype, &n, nullptr);
+ }
+ else
+ n = get_type_info (type_info.type);
+
+ return n;
+}
+
+tree
+scalar_value::get_length (gfc_typespec * type_info) const
+{
+ bt n;
+ tree size;
+ if (use_tree_type ())
+ {
+ if (TREE_CODE (value) == COMPONENT_REF)
+ {
+ tree parent_obj = TREE_OPERAND (value, 0);
+ tree len;
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (parent_obj))
+ && gfc_class_len_get (parent_obj, &len))
+ return len;
+ }
+
+ tree etype = get_elt_type ();
+ gfc_get_type_info (etype, &n, &size);
+ }
+ else
+ size = modify_info::get_length (type_info);
+
+ return size;
+}
+
+
static tree
-build_dtype (gfc_typespec &ts, int rank, const symbol_attribute &,
+build_dtype (gfc_typespec *ts, int rank, const symbol_attribute &,
const init_info &init)
{
vec<constructor_elt, va_gc> *v = nullptr;
@@ -758,15 +853,17 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
gfc_typespec *type_info = init.get_type ();
if (type_info == nullptr)
- type_info = &ts;
+ type_info = ts;
- if (!(type_info->type == BT_CLASS
- || (type_info->type == BT_CHARACTER
- && type_info->deferred)))
+ if (!(init.is_initialization ()
+ && type_info
+ && (type_info->type == BT_CLASS
+ || (type_info->type == BT_CHARACTER
+ && type_info->deferred))))
{
tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
tree elem_len_val = fold_convert (TREE_TYPE (elem_len_field),
- get_size_info (*type_info));
+ init.get_length (type_info));
CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
}
@@ -782,10 +879,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
}
tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
- tree type_info_val = build_int_cst (TREE_TYPE (type_info_field),
- get_type_info (type_info->type == BT_CLASS
- ? BT_DERIVED
- : type_info->type));
+ bt n = init.get_type_type (*type_info);
+ tree type_info_val = build_int_cst (TREE_TYPE (type_info_field), n);
CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
return build_constructor (type, v);
@@ -809,24 +904,36 @@ get_descriptor_init (tree type, gfc_typespec *ts, int
rank,
{
tree data_field = gfc_advance_chain (fields, DATA_FIELD);
tree data_value = init.get_data_value ();
+ data_value = fold_convert (TREE_TYPE (data_field), data_value);
CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
}
if (init.is_initialization ())
{
tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
- tree dtype_value = build_dtype (*ts, rank, *attr,
+ tree dtype_value = build_dtype (ts, rank, *attr,
static_cast<const init_info &> (init));
CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
}
- if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension)
+ if (init.set_span ())
+ {
+ tree span_field = gfc_advance_chain (fields, SPAN_FIELD);
+ tree span_value = build_zero_cst (TREE_TYPE (span_field));
+ CONSTRUCTOR_APPEND_ELT (v, span_field, span_value);
+ }
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
+ && init.set_token ())
{
/* Declare the variable static so its array descriptor stays present
after leaving the scope. It may still be accessed through another
image. This may happen, for example, with the caf_mpi
implementation. */
- tree token_field = gfc_advance_chain (fields, CAF_TOKEN_FIELD);
+ bool dim_present = GFC_TYPE_ARRAY_RANK (type) > 0
+ || GFC_TYPE_ARRAY_CORANK (type) > 0;
+ tree token_field = gfc_advance_chain (fields,
+ CAF_TOKEN_FIELD - (!dim_present));
tree token_value = fold_convert (TREE_TYPE (token_field),
null_pointer_node);
CONSTRUCTOR_APPEND_ELT (v, token_field, token_value);
@@ -1063,7 +1170,8 @@ init_struct (stmtblock_t *block, tree data_ref, init_kind
kind,
FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (value), i, field,
field_init)
{
tree ref = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field), data_ref,
+ TREE_TYPE (field),
+ unshare_expr (data_ref),
field, NULL_TREE);
init_struct (block, ref, field_init);
}
@@ -1084,7 +1192,8 @@ init_struct (stmtblock_t *block, tree data_ref, init_kind
kind,
{
tree field_decl = ce->index;
tree ref = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field_decl), data_ref,
+ TREE_TYPE (field_decl),
+ unshare_expr (data_ref),
field_decl, NULL_TREE);
init_struct (block, ref, ce->value);
}
@@ -1199,6 +1308,16 @@ gfc_set_scalar_descriptor (stmtblock_t *block, tree
descriptor,
}
+void
+gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+ symbol_attribute *attr)
+{
+ init_struct (block, desc,
+ get_descriptor_init (TREE_TYPE (desc), nullptr, 0, attr,
+ scalar_value (scalar)));
+}
+
+
/* Build a null array descriptor constructor. */
tree
@@ -1828,47 +1947,6 @@ gfc_get_scalar_to_descriptor_type (tree scalar,
symbol_attribute attr)
}
-void
-gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- symbol_attribute scalar_attr, bool is_class,
- tree cond_optional)
-{
- tree type = gfc_get_scalar_to_descriptor_type (scalar, scalar_attr);
- if (POINTER_TYPE_P (type))
- type = TREE_TYPE (type);
-
- tree etype = gfc_get_element_type (type);
- tree dtype_val;
- if (etype == void_type_node)
- dtype_val = gfc_get_dtype_rank_type (0, TREE_TYPE (scalar));
- else
- dtype_val = gfc_get_dtype (type);
-
- tree dtype_ref = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (block, dtype_ref, dtype_val);
-
- gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
-
- tree tmp;
- if (is_class)
- tmp = gfc_class_data_get (scalar);
- else
- tmp = scalar;
-
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- if (cond_optional)
- {
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- cond_optional, tmp,
- fold_convert (TREE_TYPE (scalar),
- null_pointer_node));
- }
-
- gfc_conv_descriptor_data_set (block, desc, tmp);
-}
-
void
gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
bool assumed_rank_lhs)
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index a4e49ba705ee..97cf7f8cb41f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -149,7 +149,7 @@ void gfc_set_descriptor_with_shape (stmtblock_t *, tree,
tree,
gfc_expr *, locus *);
tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
- symbol_attribute, bool, tree);
+ symbol_attribute *);
void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
void gfc_set_gfc_from_cfi (stmtblock_t *, stmtblock_t *, tree, tree, tree,
gfc_symbol *, bool, bool, bool);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7de96638f159..8bf985dcac58 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -167,8 +167,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar,
symbol_attribute attr)
scalar = tmp;
}
- gfc_set_descriptor_from_scalar (&se->pre, desc, scalar, attr,
- false, NULL_TREE);
+ gfc_set_descriptor_from_scalar (&se->pre, desc, scalar, &attr);
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
@@ -311,8 +310,8 @@ gfc_class_vptr_get (tree decl)
}
-tree
-gfc_class_len_get (tree decl)
+bool
+gfc_class_len_get (tree decl, tree * result)
{
tree len;
/* For class arrays decl may be a temporary descriptor handle, the len is
@@ -324,9 +323,22 @@ gfc_class_len_get (tree decl)
decl = build_fold_indirect_ref_loc (input_location, decl);
len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
CLASS_LEN_FIELD);
- return fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (len), decl, len,
- NULL_TREE);
+ if (len == NULL_TREE)
+ return false;
+
+ *result = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (len), decl, len,
+ NULL_TREE);
+ return true;
+}
+
+
+tree
+gfc_class_len_get (tree decl)
+{
+ tree result;
+ gfc_class_len_get (decl, &result);
+ return result;
}
@@ -336,20 +348,11 @@ gfc_class_len_get (tree decl)
static tree
gfc_class_len_or_zero_get (tree decl)
{
- tree len;
- /* For class arrays decl may be a temporary descriptor handle, the vptr is
- then available through the saved descriptor. */
- if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
- && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
- len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
- CLASS_LEN_FIELD);
- return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (len), decl, len,
- NULL_TREE)
- : build_zero_cst (gfc_charlen_type_node);
+ tree result;
+ if (gfc_class_len_get (decl, &result))
+ return result;
+ else
+ return build_zero_cst (gfc_charlen_type_node);
}
@@ -953,9 +956,18 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
/* Scalar to an assumed-rank array. */
if (fsym->ts.u.derived->components->as)
- gfc_set_descriptor_from_scalar (&parmse->pre, ctree,
- parmse->expr, gfc_expr_attr (e),
- false, cond_optional);
+ {
+ tree tmp = parmse->expr;
+ if (cond_optional)
+ {
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ }
+ symbol_attribute attr = gfc_expr_attr (e);
+ gfc_set_descriptor_from_scalar (&parmse->pre, ctree, tmp, &attr);
+ }
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1330,8 +1342,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts,
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
- gfc_set_descriptor_from_scalar (&block, ctree, parmse->expr,
- gfc_expr_attr (e), true, NULL_TREE);
+ {
+ tree data = gfc_class_data_get (parmse->expr);
+ symbol_attribute attr = gfc_expr_attr (e);
+ gfc_set_descriptor_from_scalar (&block, ctree, data, &attr);
+ }
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 3374778cb650..c22d9bffd27a 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1686,23 +1686,13 @@ gfc_get_desc_dim_type (void)
}
-/* Return the DTYPE for an array. This describes the type and type parameters
- of the array. */
-/* TODO: Only call this when the value is actually used, and make all the
- unknown cases abort. */
-
-tree
-gfc_get_dtype_rank_type (int rank, tree etype)
+void
+gfc_get_type_info (tree etype, bt *type, tree *psize)
{
- tree ptype;
tree size;
- int n;
- tree tmp;
- tree dtype;
- tree field;
- vec<constructor_elt, va_gc> *v = NULL;
+ bt n;
- ptype = etype;
+ tree ptype = etype;
while (TREE_CODE (etype) == POINTER_TYPE
|| TREE_CODE (etype) == ARRAY_TYPE)
{
@@ -1757,6 +1747,12 @@ gfc_get_dtype_rank_type (int rank, tree etype)
gcc_unreachable ();
}
+ if (type)
+ *type = n;
+
+ if (psize == nullptr)
+ return;
+
switch (n)
{
case BT_CHARACTER:
@@ -1776,6 +1772,29 @@ gfc_get_dtype_rank_type (int rank, tree etype)
STRIP_NOPS (size);
size = fold_convert (size_type_node, size);
+
+ if (psize)
+ *psize = size;
+}
+
+
+/* Return the DTYPE for an array. This describes the type and type parameters
+ of the array. */
+/* TODO: Only call this when the value is actually used, and make all the
+ unknown cases abort. */
+
+tree
+gfc_get_dtype_rank_type (int rank, tree etype)
+{
+ tree size;
+ bt n;
+ tree tmp;
+ tree dtype;
+ tree field;
+ vec<constructor_elt, va_gc> *v = NULL;
+
+ gfc_get_type_info (etype, &n, &size);
+
tmp = get_dtype_type_node ();
field = gfc_advance_chain (TYPE_FIELDS (tmp),
GFC_DTYPE_ELEM_LEN);
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index aba841da9cb5..1f1281524507 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -116,6 +116,7 @@ bool gfc_return_by_reference (gfc_symbol *);
bool gfc_is_nodesc_array (gfc_symbol *);
/* Return the DTYPE for an array. */
+void gfc_get_type_info (tree, bt *, tree *);
tree gfc_get_dtype_rank_type (int, tree);
tree gfc_get_dtype (tree, int *rank = NULL);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 81d5bb436536..28f81578e591 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -430,6 +430,7 @@ gfc_wrapped_block;
tree gfc_class_set_static_fields (tree, tree, tree);
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
+bool gfc_class_len_get (tree, tree *);
tree gfc_class_len_get (tree);
tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree);
gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold =
false,
